source: devel/pb-modules/lib/ProjectBuilder/VCS.pm @ 2349

Last change on this file since 2349 was 2349, checked in by bruno, 4 months ago

Fix #174 by adding the conf param pbgitremote with its doc

File size: 27.8 KB
Line 
1#!/usr/bin/perl -w
2#
3# Project Builder VCS module
4# VCS subroutines brought by the the Project-Builder project
5# which can be easily used across projects needing to perform
6# VCS related operations
7#
8# $Id$
9#
10# Copyright B. Cornec 2007-today
11# Eric Anderson's changes are (c) Copyright 2012 Hewlett Packard
12# Provided under the GPL v2
13
14package ProjectBuilder::VCS;
15
16use strict 'vars';
17use Carp 'confess';
18use Cwd 'abs_path';
19use Data::Dumper;
20use English;
21use File::Basename;
22use File::Copy;
23use POSIX qw(strftime);
24use lib qw (lib);
25use ProjectBuilder::Version;
26use ProjectBuilder::Base;
27use ProjectBuilder::Conf;
28
29# Inherit from the "Exporter" module which handles exporting functions.
30 
31use vars qw($VERSION $REVISION @ISA @EXPORT);
32use Exporter;
33 
34# Export, by default, all the functions into the namespace of
35# any code which uses this module.
36 
37our @ISA = qw(Exporter);
38our @EXPORT = qw(pb_vcs_init pb_vcs_export pb_vcs_get_uri pb_vcs_copy pb_vcs_checkout pb_vcs_up pb_vcs_checkin pb_vcs_isdiff pb_vcs_add pb_vcs_add_if_not_in pb_vcs_cmd pb_vcs_compliant pb_vcs_conf_update_v0);
39($VERSION,$REVISION) = pb_version_init();
40
41=pod
42
43=head1 NAME
44
45ProjectBuilder::VCS, part of project-builder.org
46
47=head1 DESCRIPTION
48
49This modules provides version control system functions.
50
51=head1 USAGE
52
53=over 4
54
55
56=item B<pb_vcs_init>
57
58This function setup the environment for the VCS system related to the URL given by the pbprojurl configuration parameter.
59The potential parameter indicates whether we should inititate the context or not.
60It sets up environement variables (PBPROJDIR, PBDIR, PBREVISION, PBCMSLOGFILE)
61
62=cut
63
64sub pb_vcs_init {
65
66my $pbinit = shift;
67my $param = shift;
68
69my ($pbprojurl) = pb_conf_get("pbprojurl");
70confess "Undefined pbprojurl for $ENV{'PBPROJ'}\n" if ((not defined $pbprojurl) or (not defined $pbprojurl->{$ENV{'PBPROJ'}}));
71pb_log(2,"DEBUG: Project URL of $ENV{'PBPROJ'}: $pbprojurl->{$ENV{'PBPROJ'}}\n");
72my ($scheme, $account, $host, $port, $path) = pb_get_uri($pbprojurl->{$ENV{'PBPROJ'}});
73my $vcscmd = pb_vcs_cmd($scheme);
74
75my ($pbprojdir) = pb_conf_get_if("pbprojdir");
76
77if ((defined $pbprojdir) && (defined $pbprojdir->{$ENV{'PBPROJ'}})) {
78    $ENV{'PBPROJDIR'} = $pbprojdir->{$ENV{'PBPROJ'}};
79} else {
80    $ENV{'PBPROJDIR'} = "$ENV{'PBDEFDIR'}/$ENV{'PBPROJ'}";
81}
82# Expand potential env variable in it to allow string replacement
83eval { $ENV{'PBPROJDIR'} =~ s/(\$ENV.+\})/$1/eeg };
84
85
86# Computing the default dir for PBDIR.
87# what we have is PBPROJDIR so work from that.
88# Tree identical between PBCONFDIR and PBROOTDIR on one side and
89# PBPROJDIR and PBDIR on the other side.
90
91my $tmp = $ENV{'PBROOTDIR'};
92$tmp =~ s|^$ENV{'PBCONFDIR'}/||;
93# If no subdir, then replace again
94$tmp =~ s|^$ENV{'PBCONFDIR'}||;
95
96#
97# Check project cms compliance
98#
99my $turl = "$pbprojurl->{$ENV{'PBPROJ'}}/$tmp";
100$turl = $pbprojurl->{$ENV{'PBPROJ'}} if ($scheme =~ /^(flat)|(ftp)|(http)|(https)|(file)|(git)\b/o);
101# git svn is like svn
102$turl = "$pbprojurl->{$ENV{'PBPROJ'}}/$tmp"  if ($scheme =~ /^git\+svn/o);
103pb_vcs_compliant(undef,'PBDIR',"$ENV{'PBPROJDIR'}/$tmp",$turl,$pbinit);
104
105
106if ($scheme =~ /^hg/) {
107    $tmp = `(cd "$ENV{'PBDIR'}" ; $vcscmd identify )`;
108    chomp($tmp);
109    $tmp =~ s/^.* //;
110    $ENV{'PBREVISION'}=$tmp;
111    $ENV{'PBCMSLOGFILE'}="hg.log";
112} elsif ($scheme =~ /^git/) {
113    if ($scheme =~ /svn/) {
114        $tmp = `(cd "$ENV{'PBDIR'}" ; LANGUAGE=C $vcscmd info | grep -E '^Revision:' | cut -d: -f2)`;
115        $tmp =~ s/\s+//;
116    } else {
117        $tmp = `(cd "$ENV{'PBDIR'}" ; $vcscmd log | head -1 | cut -f2)`;
118        $tmp =~ s/^.* //;
119        # Reduce length of commit id to 8 digit
120        $tmp = substr($tmp,1,8);
121    }
122    chomp($tmp);
123    $ENV{'PBREVISION'}=$tmp;
124    $ENV{'PBCMSLOGFILE'}="git.log";
125} elsif ($scheme =~ /^(flat)|(ftp)|(http)|(https)|(file)\b/o) {
126    $ENV{'PBREVISION'}="flat";
127    $ENV{'PBCMSLOGFILE'}="flat.log";
128} elsif ($scheme =~ /^svn/) {
129    # svnversion more precise than svn info if sbx
130    if ((defined $param) && ($param eq "CMS")) {
131        $tmp = `(LANGUAGE=C $vcscmd info $pbprojurl->{$ENV{'PBPROJ'}} | grep -E '^Revision:' | cut -d: -f2)`;
132        $tmp =~ s/\s+//;
133    } else {
134        $tmp = `(cd "$ENV{'PBDIR'}" ; $vcscmd"version" .)`;
135    }
136    chomp($tmp);
137    $ENV{'PBREVISION'}=$tmp;
138    $ENV{'PBCMSLOGFILE'}="svn.log";
139} elsif ($scheme =~ /^svk/) {
140    $tmp = `(cd "$ENV{'PBDIR'}" ; LANGUAGE=C $vcscmd info . | grep -E '^Revision:' | cut -d: -f2)`;
141    $tmp =~ s/\s+//;
142    chomp($tmp);
143    $ENV{'PBREVISION'}=$tmp;
144    $ENV{'PBCMSLOGFILE'}="svk.log";
145} elsif ($scheme =~ /^cvs/) {
146    # Way too slow
147    #$ENV{'PBREVISION'}=`(cd "$ENV{'PBROOTDIR'}" ; cvs rannotate  -f . 2>&1 | awk '{print \$1}' | grep -E '^[0-9]' | cut -d. -f2 |sort -nu | tail -1)`;
148    #chomp($ENV{'PBREVISION'});
149    $ENV{'PBREVISION'}="cvs";
150    $ENV{'PBCMSLOGFILE'}="cvs.log";
151    $ENV{'CVS_RSH'} = "ssh" if ($scheme =~ /ssh/);
152} else {
153    die "cms $scheme unknown";
154}
155
156pb_log(1,"pb_vcs_init returns $scheme,$pbprojurl->{$ENV{'PBPROJ'}}\n");
157return($scheme,$pbprojurl->{$ENV{'PBPROJ'}});
158}
159
160
161=item B<pb_vcs_export>
162
163This function exports a VCS content to a directory.
164The first parameter is the URL of the VCS content.
165The second parameter is the directory in which it is locally exposed (result of a checkout). If undef, then use the original VCS content.
166The third parameter is the directory where we want to deliver it (result of export).
167It returns the original tar file if we need to preserve it and undef if we use the produced one.
168
169=cut
170
171sub pb_vcs_export {
172
173my $uri = shift;
174my $source = shift;
175my $destdir = shift;
176my $tmp;
177my $tmp1;
178
179pb_log(1,"pb_vcs_export uri: $uri - destdir: $destdir\n");
180pb_log(1,"pb_vcs_export source: $source\n") if (defined $source);
181my @date = pb_get_date();
182# If it's not flat, then we have a real uri as source
183my ($scheme, $account, $host, $port, $path) = pb_get_uri($uri);
184my $vcscmd = pb_vcs_cmd($scheme);
185$uri = pb_vcs_mod_socks($uri);
186
187if ($scheme =~ /^svn/) {
188    if (defined $source) {
189        if (-d $source) {
190            $tmp = $destdir;
191        } else {
192            $tmp = "$destdir/".basename($source);
193        }
194        $source = pb_vcs_mod_htftp($source,"svn");
195        pb_system("$vcscmd export $source $tmp","Exporting $source from $scheme to $tmp ");
196    } else {
197        $uri = pb_vcs_mod_htftp($uri,"svn");
198        pb_system("$vcscmd export $uri $destdir","Exporting $uri from $scheme to $destdir ");
199    }
200} elsif ($scheme eq "svk") {
201    my $src = $source;
202    if (defined $source) {
203        if (-d $source) {
204            $tmp = $destdir;
205        } else {
206            $tmp = "$destdir/".basename($source);
207            $src = dirname($source);
208        }
209        $source = pb_vcs_mod_htftp($source,"svk");
210        # This doesn't exist !
211        # pb_system("$vcscmd export $path $tmp","Exporting $path from $scheme to $tmp ");
212        pb_log(4,"$uri,$source,$destdir,$scheme, $account, $host, $port, $path,$tmp");
213        if (-d $source) {
214            pb_system("mkdir -p $tmp ; cd $tmp; tar -cf - -C $source . | tar xf -","Exporting $source from $scheme to $tmp ");
215        } else {
216            # If source is file do not use -C with source
217            pb_system("mkdir -p ".dirname($tmp)." ; cd ".dirname($tmp)."; tar -cf - -C $src ".basename($source)." | tar xf -","Exporting $src/".basename($source)." from $scheme to $tmp ");
218        }
219    } else {
220        # Look at svk admin hotcopy
221        confess "Unable to export from svk without a source defined";
222    }
223} elsif ($scheme eq "dir") {
224    pb_system("cp -r $path $destdir","Copying $uri from DIR to $destdir ");
225} elsif ($scheme =~ /^file/) {
226    eval
227    {
228        require File::MimeInfo;
229        File::MimeInfo->import();
230    };
231    if ($@) {
232        # File::MimeInfo not found
233        confess("ERROR: Install File::MimeInfo to handle scheme $scheme\n");
234    }
235
236    my $mm = mimetype($path);
237    pb_log(2,"mimetype: $mm\n");
238
239    # Check whether the file is well formed
240    # (containing already a directory with the project-version name)
241    #
242    # If it's not the case, we try to adapt, but distro needing
243    # to verify the checksum will have issues (Fedora)
244    # Then upstream should be notified that they need to change their rules
245    # This doesn't apply to patches or additional sources of course.
246    my ($pbwf) = pb_conf_get_if("pbwf");
247    if ((defined $pbwf) && (defined $pbwf->{$ENV{'PBPROJ'}}) && ($path !~ /\/pbpatch\//) && ($path !~ /\/pbsrc\//)) {
248        $destdir = dirname($destdir);
249        pb_log(2,"This is a well-formed file so destdir is now $destdir\n");
250    }
251    pb_mkdir_p($destdir);
252
253    if ($mm =~ /\/x-bzip-compressed-tar$/) {
254        # tar+bzip2
255        pb_system("cd $destdir ; tar xfj $path","Extracting $path in $destdir ");
256    } elsif ($mm =~ /\/x-lzma-compressed-tar$/) {
257        # tar+lzma
258        pb_system("cd $destdir ; tar xfY $path","Extracting $path in $destdir ");
259    } elsif ($mm =~ /\/x-compressed-tar$/) {
260        # tar+gzip
261        pb_system("cd $destdir ; tar xfz $path","Extracting $path in $destdir ");
262    } elsif ($mm =~ /\/x-tar$/) {
263        # tar
264        pb_system("cd $destdir ; tar xf $path","Extracting $path in $destdir ");
265    } elsif ($mm =~ /\/zip$/) {
266        # zip
267        pb_system("cd $destdir ; unzip $path","Extracting $path in $destdir ");
268    } else {
269        # simple file: copy it (patch e.g.)
270        copy($path,$destdir);
271    }
272} elsif ($scheme =~ /^hg/) {
273    if (defined $source) {
274        if (-d $source) {
275            $tmp = $destdir;
276        } else {
277            $tmp = "$destdir/".basename($source);
278        }
279        $source = pb_vcs_mod_htftp($source,"hg");
280        pb_system("cd $source ; $vcscmd archive $tmp","Exporting $source from Mercurial to $tmp ");
281    } else {
282        $uri = pb_vcs_mod_htftp($uri,"hg");
283        pb_system("$vcscmd clone $uri $destdir","Exporting $uri from Mercurial to $destdir ");
284    }
285} elsif ($scheme =~ /^git/) {
286    if ($scheme =~ /svn/) {
287        if (defined $source) {
288            if (-d $source) {
289                $tmp = $destdir;
290            } else {
291                $tmp = "$destdir/".basename($source);
292            }
293            $source = pb_vcs_mod_htftp($source,"git");
294            pb_system("cp -a $source $tmp","Exporting $source from $scheme to $tmp ");
295        } else {
296            $uri = pb_vcs_mod_htftp($uri,"git");
297            pb_system("$vcscmd clone $uri $destdir","Exporting $uri from $scheme to $destdir ");
298        }
299    } else {
300        if (defined $source) {
301            if (-d $source) {
302                $tmp = $destdir;
303            } else {
304                $tmp = "$destdir/".basename($source);
305            }
306            $source = pb_vcs_mod_htftp($source,"git");
307            my ($pbpbr) = pb_conf_get_if("pbpbr");
308            if ((defined $pbpbr) && (defined $pbpbr->{$ENV{'PBPROJ'}})) {
309                # The project uses pbr so benefit from it to export data
310                pb_system("cd $source ; mkdir $tmp ; python setup.py sdist --keep-temp --dist-dir $tmp ; cd $tmp ; file=`ls *.tar.gz` ;  if [ _\$file = _ ] || [ ! -f \$file ]; then exit -1; fi; tar xfz \$file ; dir=`tar tvfz \$file | head -1 | awk '{print \$6}'` ; if [ ! -d \$dir ] || [ _\$dir = _ ] || [ \$dir = / ]; then exit -1 ; fi ; mv \$dir/* \$dir/.??* . ; rmdir \$dir ; rm -f \$file ; ls -al ","Exporting current $source from GIT with pbr to $tmp ");
311            } else {
312                # no pbr do it ourselves
313                pb_system("cd $source ; stid=`$vcscmd stash create` ; $vcscmd archive --format=tar \$\{stid:=HEAD\} | (mkdir $tmp && cd $tmp && tar xf -)","Exporting current $source from GIT to $tmp ");
314            }
315        } else {
316            $uri = pb_vcs_mod_htftp($uri,"git");
317            pb_system("$vcscmd clone $uri $destdir","Exporting $uri from GIT to $destdir ");
318        }
319    }
320} elsif ($scheme =~ /^cvs/) {
321    # CVS needs a relative path !
322    my $dir=dirname($destdir);
323    my $base=basename($destdir);
324    if (defined $source) {
325        # CVS also needs a modules name not a dir
326        $tmp1 = basename($source);
327    } else {
328        # Probably not right, should be checked, but that way I'll notice it :-)
329        pb_log(0,"You're in an untested part of project-builder.org, please report any result upstream\n");
330        $tmp1 = $uri;
331    }
332    # If we're working on the CVS itself
333    my $cvstag = basename($ENV{'PBROOTDIR'});
334    my $cvsopt = "";
335    if ($cvstag eq "cvs") {
336        my $pbdate = strftime("%Y-%m-%d %H:%M:%S", @date);
337        $cvsopt = "-D \"$pbdate\"";
338    } else {
339        # we're working on a tag which should be the last part of PBROOTDIR
340        $cvsopt = "-r $cvstag";
341    }
342    pb_system("cd $dir ; $vcscmd -d $account\@$host:$path export $cvsopt -d $base $tmp1","Exporting $tmp1 from $source under CVS to $destdir ");
343} elsif (($scheme =~ /http/) || ($scheme eq "ftp")) {
344    my $f = basename($path);
345    unlink "$ENV{'PBTMP'}/$f";
346    pb_system("$vcscmd $ENV{'PBTMP'}/$f $uri","Downloading $uri with $vcscmd to $ENV{'PBTMP'}/$f\n");
347    # We want to preserve the original tar file
348    pb_vcs_export("file://$ENV{'PBTMP'}/$f",$source,$destdir);
349    return("$ENV{'PBTMP'}/$f");
350} else {
351    confess "cms $scheme unknown";
352}
353return(undef);
354}
355
356=item B<pb_vcs_get_uri>
357
358This function is only called with a real VCS system and gives the URL stored in the checked out directory.
359The first parameter is the schema of the VCS systems (svn, cvs, svn+ssh, ...)
360The second parameter is the directory in which it is locally exposed (result of a checkout).
361
362=cut
363
364sub pb_vcs_get_uri {
365
366my $scheme = shift;
367my $dir = shift;
368
369my $res = "";
370my $void = "";
371my $vcscmd = pb_vcs_cmd($scheme);
372
373if ($scheme =~ /^svn/) {
374    open(PIPE,"LANGUAGE=C $vcscmd info $dir 2> /dev/null |") || return("");
375    while (<PIPE>) {
376        ($void,$res) = split(/^URL:/) if (/^URL:/);
377    }
378    $res =~ s/^\s*//;
379    close(PIPE);
380    chomp($res);
381} elsif ($scheme =~ /^svk/) {
382    open(PIPE,"LANGUAGE=C $vcscmd info $dir 2> /dev/null |") || return("");
383    my $void2 = "";
384    while (<PIPE>) {
385        ($void,$void2,$res) = split(/ /) if (/^Depot/);
386    }
387    $res =~ s/^\s*//;
388    close(PIPE);
389    chomp($res);
390} elsif ($scheme =~ /^hg/) {
391    open(HGRC,".hg/hgrc/") || return("");
392    while (<HGRC>) {
393        ($void,$res) = split(/^default.*=/) if (/^default.*=/);
394    }
395    close(HGRC);
396    chomp($res);
397} elsif ($scheme =~ /^git/) {
398    if ($scheme =~ /svn/) {
399        my $cwd = abs_path();
400        chdir($dir) || return("");;
401        open(PIPE,"LANGUAGE=C $vcscmd info . 2> /dev/null |") || return("");
402        chdir($cwd) || return("");
403        while (<PIPE>) {
404            ($void,$res) = split(/^URL:/) if (/^URL:/);
405        }
406        $res =~ s/^\s*//;
407        close(PIPE);
408        chomp($res);
409        # We've got an SVN ref so add git in front of it for coherency
410        $res = "git+".$res;
411    } else {
412        # Pure git
413        # First we may deal with a separate git repo under $dir
414        if ( -d "$dir/.git" ) {
415            open(GIT,"LANGUAGE=C $vcscmd --git-dir=$dir/.git remote -v 2> /dev/null |") || return("");
416        } else {
417            # If not, the pbconf dir may be in the pbprojdir so sharing the .git dir
418            my $cwd = abs_path();
419            chdir($ENV{'PBPROJDIR'}) || return("");;
420            open(GIT,"LANGUAGE=C $vcscmd remote -v 2> /dev/null |") || return("");
421            chdir($cwd) || return("");
422        }
423        my ($pborigin) = pb_conf_get("pbgitremote");
424        while (<GIT>) {
425            next unless (/^$pborigin->{$ENV{'PBPROJ'}}\s+(\S+) \(push\)$/);
426            $res = $1;
427            if (($res =~ /@/) && ($res !~ /:\/\//)) {
428                # we have an ssh connection, return it
429                $res = "ssh://$res";
430            }
431            return $res;
432        }
433        close(GIT);
434        warn "Unable to find a remote git $pborigin->{$ENV{'PBPROJ'}} under $dir nor $ENV{'PBPROJDIR'}";
435        return "";
436    }
437} elsif ($scheme =~ /^cvs/) {
438    # This path is always the root path of CVS, but we may be below
439    open(FILE,"$dir/CVS/Root") || confess "$dir isn't CVS controlled";
440    $res = <FILE>;
441    chomp($res);
442    close(FILE);
443    # Find where we are in the tree
444    my $rdir = $dir;
445    while ((! -d "$rdir/CVSROOT") && ($rdir ne "/")) {
446        $rdir = dirname($rdir);
447    }
448    confess "Unable to find a CVSROOT dir in the parents of $dir" if (! -d "$rdir/CVSROOT");
449    #compute our place under that root dir - should be a relative path
450    $dir =~ s|^$rdir||;
451    my $suffix = "";
452    $suffix = "$dir" if ($dir ne "");
453
454    my $prefix = "";
455    if ($scheme =~ /ssh/) {
456        $prefix = "cvs+ssh://";
457    } else {
458        $prefix = "cvs://";
459    }
460    $res = $prefix.$res.$suffix;
461} else {
462    confess "cms $scheme unknown";
463}
464pb_log(1,"pb_vcs_get_uri returns $res\n");
465return($res);
466}
467
468=item B<pb_vcs_copy>
469
470This function copies a VCS content to another.
471The first parameter is the schema of the VCS systems (svn, cvs, svn+ssh, ...)
472The second parameter is the URL of the original VCS content.
473The third parameter is the URL of the destination VCS content.
474
475Only coded for SVN now as used for pbconf itself not the project
476
477=cut
478
479sub pb_vcs_copy {
480my $scheme = shift;
481my $oldurl = shift;
482my $newurl = shift;
483my $vcscmd = pb_vcs_cmd($scheme);
484$oldurl = pb_vcs_mod_socks($oldurl);
485$newurl = pb_vcs_mod_socks($newurl);
486
487if ($scheme =~ /^svn/) {
488    $oldurl = pb_vcs_mod_htftp($oldurl,"svn");
489    $newurl = pb_vcs_mod_htftp($newurl,"svn");
490    pb_system("$vcscmd copy -m \"Creation of $newurl from $oldurl\" $oldurl $newurl","Copying $oldurl to $newurl ");
491} elsif ($scheme =~ /^(flat)|(ftp)|(http)|(https)|(file)\b/o) {
492    # Nothing to do.
493} else {
494    confess "cms $scheme unknown for project management";
495}
496}
497
498=item B<pb_vcs_checkout>
499
500This function checks a VCS content out to a directory.
501The first parameter is the schema of the VCS systems (svn, cvs, svn+ssh, ...)
502The second parameter is the URL of the VCS content.
503The third parameter is the directory where we want to deliver it (result of export).
504
505=cut
506
507sub pb_vcs_checkout {
508my $scheme = shift;
509my $url = shift;
510my $destination = shift;
511my $vcscmd = pb_vcs_cmd($scheme);
512$url = pb_vcs_mod_socks($url);
513
514if ($scheme =~ /^svn/) {
515    $url = pb_vcs_mod_htftp($url,"svn");
516    pb_system("$vcscmd co $url $destination","Checking out $url to $destination ");
517} elsif ($scheme =~ /^svk/) {
518    $url = pb_vcs_mod_htftp($url,"svk");
519    pb_system("$vcscmd co $url $destination","Checking out $url to $destination ");
520} elsif ($scheme =~ /^hg/) {
521    $url = pb_vcs_mod_htftp($url,"hg");
522    pb_system("$vcscmd clone $url $destination","Checking out $url to $destination ");
523} elsif ($scheme =~ /^git/) {
524    $url = pb_vcs_mod_htftp($url,"git");
525    pb_system("$vcscmd clone $url $destination","Checking out $url to $destination ");
526} elsif (($scheme eq "ftp") || ($scheme =~ /http/)) {
527    return;
528} elsif ($scheme =~ /^cvs/) {
529    my ($scheme, $account, $host, $port, $path) = pb_get_uri($url);
530
531    # If we're working on the CVS itself
532    my $cvstag = basename($ENV{'PBROOTDIR'});
533    my $cvsopt = "";
534    if ($cvstag eq "cvs") {
535        my @date = pb_get_date();
536        my $pbdate = strftime("%Y-%m-%d %H:%M:%S", @date);
537        $cvsopt = "-D \"$pbdate\"";
538    } else {
539        # we're working on a tag which should be the last part of PBROOTDIR
540        $cvsopt = "-r $cvstag";
541    }
542    pb_mkdir_p("$destination");
543    pb_system("cd $destination ; $vcscmd -d $account\@$host:$path co $cvsopt .","Checking out $url to $destination ");
544} elsif ($scheme =~ /^file/) {
545    pb_vcs_export($url,undef,$destination);
546} else {
547    confess "cms $scheme unknown";
548}
549}
550
551=item B<pb_vcs_up>
552
553This function updates a local directory with the VCS content.
554The first parameter is the schema of the VCS systems (svn, cvs, svn+ssh, ...)
555The second parameter is the list of directory to update.
556
557=cut
558
559sub pb_vcs_up {
560my $scheme = shift;
561my @dir = @_;
562my $vcscmd = pb_vcs_cmd($scheme);
563
564if ($scheme =~ /^((svn)|(cvs)|(svk))/o) {
565    pb_system("$vcscmd up ".join(' ',@dir),"Updating ".join(' ',@dir));
566} elsif ($scheme =~ /^((hg)|(git))/o) {
567    foreach my $d (@dir) {
568        pb_system("(cd $d && $vcscmd fetch)", "Updating $d ");
569    }
570} elsif ($scheme =~ /^(flat)|(ftp)|(http)|(https)|(file)\b/o) {
571    # Nothing to do.
572} else {
573    confess "cms $scheme unknown";
574}
575}
576
577=item B<pb_vcs_checkin>
578
579This function updates a VCS content from a local directory.
580The first parameter is the schema of the VCS systems (svn, cvs, svn+ssh, ...)
581The second parameter is the directory to update from.
582The third parameter is the comment to pass during the commit
583
584=cut
585
586sub pb_vcs_checkin {
587my $scheme = shift;
588my $dir = shift;
589my $msg = shift;
590my $vcscmd = pb_vcs_cmd($scheme);
591
592if ($scheme =~ /^((svn)|(cvs)|(svk))/o) {
593    pb_system("cd $dir && $vcscmd ci -m \"$msg\" .","Checking in $dir ");
594} elsif ($scheme =~ /^git/) {
595    pb_system("cd $dir && git commit -m \"$msg\"", "Checking in $dir ");
596} elsif ($scheme =~ /^(flat)|(ftp)|(http)|(https)|(file)\b/o) {
597    # Nothing to do.
598} else {
599    confess "cms $scheme unknown";
600}
601pb_vcs_up($scheme,$dir);
602}
603
604=item B<pb_vcs_add_if_not_in>
605
606This function adds to a VCS content from a local directory if the content wasn't already managed under the VCS.
607The first parameter is the schema of the VCS systems (svn, cvs, svn+ssh, ...)
608The second parameter is a list of directory/file to add.
609
610=cut
611
612sub pb_vcs_add_if_not_in {
613my $scheme = shift;
614my @f = @_;
615my $vcscmd = pb_vcs_cmd($scheme);
616
617if ($scheme =~ /^((hg)|(git)|(svn)|(svk)|(cvs))/o) {
618    for my $f (@f) {
619        my $uri = pb_vcs_get_uri($scheme,$f);
620        pb_vcs_add($scheme,$f) if ($uri !~ /^$scheme/);
621    }
622} elsif ($scheme =~ /^(flat)|(ftp)|(http)|(https)|(file)\b/o) {
623    # Nothing to do.
624} else {
625    confess "cms $scheme unknown";
626}
627}
628
629=item B<pb_vcs_add>
630
631This function adds to a VCS content from a local directory.
632The first parameter is the schema of the VCS systems (svn, cvs, svn+ssh, ...)
633The second parameter is a list of directory/file to add.
634
635=cut
636
637sub pb_vcs_add {
638my $scheme = shift;
639my @f = @_;
640my $vcscmd = pb_vcs_cmd($scheme);
641
642if ($scheme =~ /^((hg)|(git)|(svn)|(svk)|(cvs))/o) {
643    $vcscmd =~ s/ svn// if (($scheme =~ /git/) && ($scheme =~ /svn/));
644    if ($scheme =~ /git/) {
645        # Here we need to be in the right place to add
646        for my $f (@f) {
647            my $dir = dirname($f);
648            pb_system("cd $dir ; $vcscmd add ".basename($f),"Adding $f to VCS ");
649        }
650    } else {
651        pb_system("$vcscmd add ".join(' ',@f),"Adding ".join(' ',@f)." to VCS ");
652    }
653} elsif ($scheme =~ /^(flat)|(ftp)|(http)|(https)|(file)\b/o) {
654    # Nothing to do.
655} else {
656    confess "cms $scheme unknown";
657}
658my @f1;
659foreach my $f (@f) {
660    push(@f1,$f) if (-d $f);
661    push(@f1,dirname($f)) if (-f $f);
662}
663pb_vcs_up($scheme,@f1);
664}
665
666=item B<pb_vcs_isdiff>
667
668This function returns a integer indicating the number of differences between the VCS content and the local directory where it's checked out.
669The first parameter is the schema of the VCS systems (svn, cvs, svn+ssh, ...)
670The second parameter is the directory to consider.
671
672=cut
673
674sub pb_vcs_isdiff {
675my $scheme = shift;
676my $dir =shift;
677my $vcscmd = pb_vcs_cmd($scheme);
678my $l = undef;
679
680if ($scheme =~ /^((svn)|(cvs)|(svk)|(git))/o) {
681    $vcscmd =~ s/ svn// if (($scheme =~ /git/) && ($scheme =~ /svn/));
682    open(PIPE,"$vcscmd diff $dir |") || confess "Unable to get $vcscmd diff from $dir";
683    $l = 0;
684    while (<PIPE>) {
685        # Skipping normal messages in case of CVS
686        next if (/^cvs diff:/);
687        $l++;
688    }
689} elsif ($scheme =~ /^(flat)|(ftp)|(http)|(https)|(file)\b/o) {
690    $l = 0;
691} else {
692    confess "cms $scheme unknown";
693}
694pb_log(1,"pb_vcs_isdiff returns $l\n");
695return($l);
696}
697
698sub pb_vcs_mod_htftp {
699
700my $url = shift;
701my $proto = shift;
702
703$url =~ s/^$proto\+((ht|f)tp[s]*):/$1:/;
704pb_log(1,"pb_vcs_mod_htftp returns $url\n");
705return($url);
706}
707
708sub pb_vcs_mod_socks {
709
710my $url = shift;
711
712$url =~ s/^([A-z0-9]+)\+(socks):/$1:/;
713pb_log(1,"pb_vcs_mod_socks returns $url\n");
714return($url);
715}
716
717
718sub pb_vcs_cmd {
719
720my $scheme = shift;
721my $cmd = "";
722my $cmdopt = "";
723
724# If there is a socks proxy to use
725if ($scheme =~ /socks/) {
726    # Get the socks proxy command from the conf file
727    my ($pbsockscmd) = pb_conf_get("pbsockscmd");
728    $cmd = "$pbsockscmd->{$ENV{'PBPROJ'}} ";
729}
730
731if (defined $ENV{'PBVCSOPT'}) {
732    $cmdopt .= " $ENV{'PBVCSOPT'}";
733}
734
735if ($scheme =~ /hg/) {
736    $cmd .= "hg".$cmdopt;
737} elsif ($scheme =~ /git/) {
738    if ($scheme =~ /svn/) {
739        $cmd .= "git svn".$cmdopt;
740    } else {
741        $cmd .= "git".$cmdopt;
742    }
743} elsif ($scheme =~ /svn/) {
744    $cmd .= "svn".$cmdopt;
745} elsif ($scheme =~ /svk/) {
746    $cmd .= "svk".$cmdopt;
747} elsif ($scheme =~ /cvs/) {
748    $cmd .= "cvs".$cmdopt;
749} elsif (($scheme =~ /http/) || ($scheme =~ /ftp/)) {
750    my $command = pb_check_req("wget",1);
751    if (-x $command) {
752        $cmd .= "$command -nv -O ";
753    } else {
754        $command = pb_check_req("curl",1);
755        if (-x $command) {
756            $cmd .= "$command -o ";
757        } else {
758            confess "Unable to handle $scheme.\nNo wget/curl available, please install one of those";
759        }
760    }
761} else {
762    $cmd = "";
763}
764pb_log(3,"pb_vcs_cmd returns $cmd\n");
765return($cmd);
766}
767
768=item B<pb_vcs_compliant>
769
770This function checks the compliance of the project and the pbconf directory.
771The first parameter is the key name of the value that needs to be read in the configuration file.
772The second parameter is the environment variable this key will populate.
773The third parameter is the location of the pbconf dir.
774The fourth parameter is the URI of the VCS content related to the pbconf dir.
775The fifth parameter indicates whether we should inititate the context or not.
776
777=cut
778
779sub pb_vcs_compliant {
780
781my $param = shift;
782my $envar = shift;
783my $defdir = shift;
784my $uri = shift;
785my $pbinit = shift;
786my %pdir;
787
788pb_log(1,"pb_vcs_compliant: envar: $envar - defdir: $defdir - uri: $uri\n");
789my ($pdir) = pb_conf_get_if($param) if (defined $param);
790if (defined $pdir) {
791    %pdir = %$pdir;
792}
793
794if ((defined $pdir) && (%pdir) && (defined $pdir{$ENV{'PBPROJ'}})) {
795    # That's always the environment variable that will be used
796    $ENV{$envar} = $pdir{$ENV{'PBPROJ'}};
797} else {
798    if (defined $param) {
799        pb_log(1,"WARNING: no $param defined, using $defdir\n");
800        pb_log(1,"         Please create a $param reference for project $ENV{'PBPROJ'} in $ENV{'PBETC'}\n");
801        pb_log(1,"         if you want to use another directory\n");
802    }
803    $ENV{$envar} = "$defdir";
804}
805
806# Expand potential env variable in it
807eval { $ENV{$envar} =~ s/(\$ENV.+\})/$1/eeg };
808pb_log(2,"$envar: $ENV{$envar}\n");
809
810my ($scheme, $account, $host, $port, $path) = pb_get_uri($uri);
811
812if (($scheme !~ /^cvs/) && ($scheme !~ /^svn/) && ($scheme !~ /^svk/) && ($scheme !~ /^hg/) && ($scheme !~ /^git/)) {
813    # Do not compare if it's not a real cms
814    pb_log(1,"pb_vcs_compliant useless\n");
815    return;
816} elsif ((defined $pbinit) || (! -d "$ENV{$envar}")) {
817    my $exportdir = $ENV{$envar};
818    # Either we have a version in the uri, and it should be the same
819    # as the one in the envar. Or we should add the version to the uri
820    # But not if it's git as it manages version branches internally
821    if ((basename($uri) ne basename($exportdir)) && ($scheme !~ /git/)) {
822        $uri .= "/".basename($exportdir);
823    }
824    if ((defined $pbinit) && ($scheme =~ /git/)) {
825        # If initializing remove the potential pbconf part if we treat pbconfdir
826        $exportdir =~ s|pbconf[/]*||;
827    }
828    pb_log(1,"Checking out $uri\n");
829    # Create structure and remove end dir before exporting
830    pb_mkdir_p("$exportdir");
831    pb_rm_rf($exportdir);
832    pb_vcs_checkout($scheme,$uri,$exportdir);
833    if ((defined $pbinit) && ($scheme =~ /git/)) {
834        # And now created the potentially missin gpbconf dir
835        pb_mkdir_p("$exportdir/pbconf");
836    }
837} else {
838    pb_log(1,"$uri found locally, checking content\n");
839    my $cmsurl = pb_vcs_get_uri($scheme,$ENV{$envar});
840    my ($scheme2, $account2, $host2, $port2, $path2) = pb_get_uri($cmsurl);
841    # For svk, scheme doesn't appear in svk info so remove it here in uri coming from conf file
842    # which needs it to trigger correct behaviour
843    $uri =~ s/^svk://;
844    if ($scheme2 =~ /^git/) {
845        # remove schema from `git+file:` and `git+dir:` urls
846        # TODO: handle query-parameters
847        $uri =~ s/^git\+(file|dir):[\/]*//;
848        # Expand potential env variable in it -- this is required due to the consistency check
849        $uri =~ s/(\$ENV.+\})/$1/eeg;
850    } elsif ($scheme2 =~ /^hg/) {
851        # This VCS manages branches internally not with different tree structures
852        # Assuming it's correct for now.
853        return;
854    }
855    # Remove git+ part if only in scheme
856    $uri =~ s/^git\+// if (($scheme =~ /^git\+/) && ($scheme2 !~ /^git\+/));
857
858    if ($cmsurl ne $uri) {
859        # The local content doesn't correpond to the repository
860        pb_log(0,"ERROR: Inconsistency detected:\n");
861        pb_log(0,"       * $ENV{$envar} ($envar) refers to $cmsurl but\n");
862        pb_log(0,"       * $ENV{'PBETC'} refers to $uri\n");
863        die "Project $ENV{'PBPROJ'} is not Project-Builder compliant.";
864    } else {
865        pb_log(1,"Content correct - doing nothing - you may want to update your repository however\n");
866        # they match - do nothing - there may be local changes
867    }
868}
869pb_log(1,"pb_vcs_compliant end\n");
870}
871
872=item B<pb_vcs_conf_update_v0>
873
874This function transform the old configuration v0 file as first param into a new v1 one as second param  by calling a COnf.pm function and then adds the resulting file into VCS
875
876=cut
877
878
879sub pb_vcs_conf_update_v0 {
880
881my $orig = shift;
882my $dest = shift;
883
884pb_conf_update_v0($orig,$dest);
885# Adding this new file to VCS (not removing the previous one)
886my ($pbprojurl) = pb_conf_get("pbprojurl");
887my ($scheme, $account, $host, $port, $path) = pb_get_uri($pbprojurl->{$ENV{'PBPROJ'}});
888pb_vcs_add_if_not_in($scheme,$dest);
889}
890
891=back
892
893=head1 WEB SITES
894
895The main Web site of the project is available at L<http://www.project-builder.org/>. Bug reports should be filled using the trac instance of the project at L<http://trac.project-builder.org/>.
896
897=head1 USER MAILING LIST
898
899None exists for the moment.
900
901=head1 AUTHORS
902
903The Project-Builder.org team L<http://trac.project-builder.org/> lead by Bruno Cornec L<mailto:bruno@project-builder.org>.
904
905=head1 COPYRIGHT
906
907Project-Builder.org is distributed under the GPL v2.0 license
908described in the file C<COPYING> included with the distribution.
909
910=cut
911
9121;
Note: See TracBrowser for help on using the repository browser.