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

Last change on this file since 2348 was 2348, checked in by bruno, 8 months ago

Fix check of PBPROJDIR when .git dir not found in pbconf

File size: 27.6 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        while (<GIT>) {
424            next unless (/^origin\s+(\S+) \(push\)$/);
425            return $1;
426        }
427        close(GIT);
428        warn "Unable to find a remote git origin under $dir nor $ENV{'PBPROJDIR'}";
429        return "";
430    }
431} elsif ($scheme =~ /^cvs/) {
432    # This path is always the root path of CVS, but we may be below
433    open(FILE,"$dir/CVS/Root") || confess "$dir isn't CVS controlled";
434    $res = <FILE>;
435    chomp($res);
436    close(FILE);
437    # Find where we are in the tree
438    my $rdir = $dir;
439    while ((! -d "$rdir/CVSROOT") && ($rdir ne "/")) {
440        $rdir = dirname($rdir);
441    }
442    confess "Unable to find a CVSROOT dir in the parents of $dir" if (! -d "$rdir/CVSROOT");
443    #compute our place under that root dir - should be a relative path
444    $dir =~ s|^$rdir||;
445    my $suffix = "";
446    $suffix = "$dir" if ($dir ne "");
447
448    my $prefix = "";
449    if ($scheme =~ /ssh/) {
450        $prefix = "cvs+ssh://";
451    } else {
452        $prefix = "cvs://";
453    }
454    $res = $prefix.$res.$suffix;
455} else {
456    confess "cms $scheme unknown";
457}
458pb_log(1,"pb_vcs_get_uri returns $res\n");
459return($res);
460}
461
462=item B<pb_vcs_copy>
463
464This function copies a VCS content to another.
465The first parameter is the schema of the VCS systems (svn, cvs, svn+ssh, ...)
466The second parameter is the URL of the original VCS content.
467The third parameter is the URL of the destination VCS content.
468
469Only coded for SVN now as used for pbconf itself not the project
470
471=cut
472
473sub pb_vcs_copy {
474my $scheme = shift;
475my $oldurl = shift;
476my $newurl = shift;
477my $vcscmd = pb_vcs_cmd($scheme);
478$oldurl = pb_vcs_mod_socks($oldurl);
479$newurl = pb_vcs_mod_socks($newurl);
480
481if ($scheme =~ /^svn/) {
482    $oldurl = pb_vcs_mod_htftp($oldurl,"svn");
483    $newurl = pb_vcs_mod_htftp($newurl,"svn");
484    pb_system("$vcscmd copy -m \"Creation of $newurl from $oldurl\" $oldurl $newurl","Copying $oldurl to $newurl ");
485} elsif ($scheme =~ /^(flat)|(ftp)|(http)|(https)|(file)\b/o) {
486    # Nothing to do.
487} else {
488    confess "cms $scheme unknown for project management";
489}
490}
491
492=item B<pb_vcs_checkout>
493
494This function checks a VCS content out to a directory.
495The first parameter is the schema of the VCS systems (svn, cvs, svn+ssh, ...)
496The second parameter is the URL of the VCS content.
497The third parameter is the directory where we want to deliver it (result of export).
498
499=cut
500
501sub pb_vcs_checkout {
502my $scheme = shift;
503my $url = shift;
504my $destination = shift;
505my $vcscmd = pb_vcs_cmd($scheme);
506$url = pb_vcs_mod_socks($url);
507
508if ($scheme =~ /^svn/) {
509    $url = pb_vcs_mod_htftp($url,"svn");
510    pb_system("$vcscmd co $url $destination","Checking out $url to $destination ");
511} elsif ($scheme =~ /^svk/) {
512    $url = pb_vcs_mod_htftp($url,"svk");
513    pb_system("$vcscmd co $url $destination","Checking out $url to $destination ");
514} elsif ($scheme =~ /^hg/) {
515    $url = pb_vcs_mod_htftp($url,"hg");
516    pb_system("$vcscmd clone $url $destination","Checking out $url to $destination ");
517} elsif ($scheme =~ /^git/) {
518    $url = pb_vcs_mod_htftp($url,"git");
519    pb_system("$vcscmd clone $url $destination","Checking out $url to $destination ");
520} elsif (($scheme eq "ftp") || ($scheme =~ /http/)) {
521    return;
522} elsif ($scheme =~ /^cvs/) {
523    my ($scheme, $account, $host, $port, $path) = pb_get_uri($url);
524
525    # If we're working on the CVS itself
526    my $cvstag = basename($ENV{'PBROOTDIR'});
527    my $cvsopt = "";
528    if ($cvstag eq "cvs") {
529        my @date = pb_get_date();
530        my $pbdate = strftime("%Y-%m-%d %H:%M:%S", @date);
531        $cvsopt = "-D \"$pbdate\"";
532    } else {
533        # we're working on a tag which should be the last part of PBROOTDIR
534        $cvsopt = "-r $cvstag";
535    }
536    pb_mkdir_p("$destination");
537    pb_system("cd $destination ; $vcscmd -d $account\@$host:$path co $cvsopt .","Checking out $url to $destination ");
538} elsif ($scheme =~ /^file/) {
539    pb_vcs_export($url,undef,$destination);
540} else {
541    confess "cms $scheme unknown";
542}
543}
544
545=item B<pb_vcs_up>
546
547This function updates a local directory with the VCS content.
548The first parameter is the schema of the VCS systems (svn, cvs, svn+ssh, ...)
549The second parameter is the list of directory to update.
550
551=cut
552
553sub pb_vcs_up {
554my $scheme = shift;
555my @dir = @_;
556my $vcscmd = pb_vcs_cmd($scheme);
557
558if ($scheme =~ /^((svn)|(cvs)|(svk))/o) {
559    pb_system("$vcscmd up ".join(' ',@dir),"Updating ".join(' ',@dir));
560} elsif ($scheme =~ /^((hg)|(git))/o) {
561    foreach my $d (@dir) {
562        pb_system("(cd $d && $vcscmd fetch)", "Updating $d ");
563    }
564} elsif ($scheme =~ /^(flat)|(ftp)|(http)|(https)|(file)\b/o) {
565    # Nothing to do.
566} else {
567    confess "cms $scheme unknown";
568}
569}
570
571=item B<pb_vcs_checkin>
572
573This function updates a VCS content from a local directory.
574The first parameter is the schema of the VCS systems (svn, cvs, svn+ssh, ...)
575The second parameter is the directory to update from.
576The third parameter is the comment to pass during the commit
577
578=cut
579
580sub pb_vcs_checkin {
581my $scheme = shift;
582my $dir = shift;
583my $msg = shift;
584my $vcscmd = pb_vcs_cmd($scheme);
585
586if ($scheme =~ /^((svn)|(cvs)|(svk))/o) {
587    pb_system("cd $dir && $vcscmd ci -m \"$msg\" .","Checking in $dir ");
588} elsif ($scheme =~ /^git/) {
589    pb_system("cd $dir && git commit -m \"$msg\"", "Checking in $dir ");
590} elsif ($scheme =~ /^(flat)|(ftp)|(http)|(https)|(file)\b/o) {
591    # Nothing to do.
592} else {
593    confess "cms $scheme unknown";
594}
595pb_vcs_up($scheme,$dir);
596}
597
598=item B<pb_vcs_add_if_not_in>
599
600This function adds to a VCS content from a local directory if the content wasn't already managed under the VCS.
601The first parameter is the schema of the VCS systems (svn, cvs, svn+ssh, ...)
602The second parameter is a list of directory/file to add.
603
604=cut
605
606sub pb_vcs_add_if_not_in {
607my $scheme = shift;
608my @f = @_;
609my $vcscmd = pb_vcs_cmd($scheme);
610
611if ($scheme =~ /^((hg)|(git)|(svn)|(svk)|(cvs))/o) {
612    for my $f (@f) {
613        my $uri = pb_vcs_get_uri($scheme,$f);
614        pb_vcs_add($scheme,$f) if ($uri !~ /^$scheme/);
615    }
616} elsif ($scheme =~ /^(flat)|(ftp)|(http)|(https)|(file)\b/o) {
617    # Nothing to do.
618} else {
619    confess "cms $scheme unknown";
620}
621}
622
623=item B<pb_vcs_add>
624
625This function adds to a VCS content from a local directory.
626The first parameter is the schema of the VCS systems (svn, cvs, svn+ssh, ...)
627The second parameter is a list of directory/file to add.
628
629=cut
630
631sub pb_vcs_add {
632my $scheme = shift;
633my @f = @_;
634my $vcscmd = pb_vcs_cmd($scheme);
635
636if ($scheme =~ /^((hg)|(git)|(svn)|(svk)|(cvs))/o) {
637    $vcscmd =~ s/ svn// if (($scheme =~ /git/) && ($scheme =~ /svn/));
638    if ($scheme =~ /git/) {
639        # Here we need to be in the right place to add
640        for my $f (@f) {
641            my $dir = dirname($f);
642            pb_system("cd $dir ; $vcscmd add ".basename($f),"Adding $f to VCS ");
643        }
644    } else {
645        pb_system("$vcscmd add ".join(' ',@f),"Adding ".join(' ',@f)." to VCS ");
646    }
647} elsif ($scheme =~ /^(flat)|(ftp)|(http)|(https)|(file)\b/o) {
648    # Nothing to do.
649} else {
650    confess "cms $scheme unknown";
651}
652my @f1;
653foreach my $f (@f) {
654    push(@f1,$f) if (-d $f);
655    push(@f1,dirname($f)) if (-f $f);
656}
657pb_vcs_up($scheme,@f1);
658}
659
660=item B<pb_vcs_isdiff>
661
662This function returns a integer indicating the number of differences between the VCS content and the local directory where it's checked out.
663The first parameter is the schema of the VCS systems (svn, cvs, svn+ssh, ...)
664The second parameter is the directory to consider.
665
666=cut
667
668sub pb_vcs_isdiff {
669my $scheme = shift;
670my $dir =shift;
671my $vcscmd = pb_vcs_cmd($scheme);
672my $l = undef;
673
674if ($scheme =~ /^((svn)|(cvs)|(svk)|(git))/o) {
675    $vcscmd =~ s/ svn// if (($scheme =~ /git/) && ($scheme =~ /svn/));
676    open(PIPE,"$vcscmd diff $dir |") || confess "Unable to get $vcscmd diff from $dir";
677    $l = 0;
678    while (<PIPE>) {
679        # Skipping normal messages in case of CVS
680        next if (/^cvs diff:/);
681        $l++;
682    }
683} elsif ($scheme =~ /^(flat)|(ftp)|(http)|(https)|(file)\b/o) {
684    $l = 0;
685} else {
686    confess "cms $scheme unknown";
687}
688pb_log(1,"pb_vcs_isdiff returns $l\n");
689return($l);
690}
691
692sub pb_vcs_mod_htftp {
693
694my $url = shift;
695my $proto = shift;
696
697$url =~ s/^$proto\+((ht|f)tp[s]*):/$1:/;
698pb_log(1,"pb_vcs_mod_htftp returns $url\n");
699return($url);
700}
701
702sub pb_vcs_mod_socks {
703
704my $url = shift;
705
706$url =~ s/^([A-z0-9]+)\+(socks):/$1:/;
707pb_log(1,"pb_vcs_mod_socks returns $url\n");
708return($url);
709}
710
711
712sub pb_vcs_cmd {
713
714my $scheme = shift;
715my $cmd = "";
716my $cmdopt = "";
717
718# If there is a socks proxy to use
719if ($scheme =~ /socks/) {
720    # Get the socks proxy command from the conf file
721    my ($pbsockscmd) = pb_conf_get("pbsockscmd");
722    $cmd = "$pbsockscmd->{$ENV{'PBPROJ'}} ";
723}
724
725if (defined $ENV{'PBVCSOPT'}) {
726    $cmdopt .= " $ENV{'PBVCSOPT'}";
727}
728
729if ($scheme =~ /hg/) {
730    $cmd .= "hg".$cmdopt;
731} elsif ($scheme =~ /git/) {
732    if ($scheme =~ /svn/) {
733        $cmd .= "git svn".$cmdopt;
734    } else {
735        $cmd .= "git".$cmdopt;
736    }
737} elsif ($scheme =~ /svn/) {
738    $cmd .= "svn".$cmdopt;
739} elsif ($scheme =~ /svk/) {
740    $cmd .= "svk".$cmdopt;
741} elsif ($scheme =~ /cvs/) {
742    $cmd .= "cvs".$cmdopt;
743} elsif (($scheme =~ /http/) || ($scheme =~ /ftp/)) {
744    my $command = pb_check_req("wget",1);
745    if (-x $command) {
746        $cmd .= "$command -nv -O ";
747    } else {
748        $command = pb_check_req("curl",1);
749        if (-x $command) {
750            $cmd .= "$command -o ";
751        } else {
752            confess "Unable to handle $scheme.\nNo wget/curl available, please install one of those";
753        }
754    }
755} else {
756    $cmd = "";
757}
758pb_log(3,"pb_vcs_cmd returns $cmd\n");
759return($cmd);
760}
761
762=item B<pb_vcs_compliant>
763
764This function checks the compliance of the project and the pbconf directory.
765The first parameter is the key name of the value that needs to be read in the configuration file.
766The second parameter is the environment variable this key will populate.
767The third parameter is the location of the pbconf dir.
768The fourth parameter is the URI of the VCS content related to the pbconf dir.
769The fifth parameter indicates whether we should inititate the context or not.
770
771=cut
772
773sub pb_vcs_compliant {
774
775my $param = shift;
776my $envar = shift;
777my $defdir = shift;
778my $uri = shift;
779my $pbinit = shift;
780my %pdir;
781
782pb_log(1,"pb_vcs_compliant: envar: $envar - defdir: $defdir - uri: $uri\n");
783my ($pdir) = pb_conf_get_if($param) if (defined $param);
784if (defined $pdir) {
785    %pdir = %$pdir;
786}
787
788if ((defined $pdir) && (%pdir) && (defined $pdir{$ENV{'PBPROJ'}})) {
789    # That's always the environment variable that will be used
790    $ENV{$envar} = $pdir{$ENV{'PBPROJ'}};
791} else {
792    if (defined $param) {
793        pb_log(1,"WARNING: no $param defined, using $defdir\n");
794        pb_log(1,"         Please create a $param reference for project $ENV{'PBPROJ'} in $ENV{'PBETC'}\n");
795        pb_log(1,"         if you want to use another directory\n");
796    }
797    $ENV{$envar} = "$defdir";
798}
799
800# Expand potential env variable in it
801eval { $ENV{$envar} =~ s/(\$ENV.+\})/$1/eeg };
802pb_log(2,"$envar: $ENV{$envar}\n");
803
804my ($scheme, $account, $host, $port, $path) = pb_get_uri($uri);
805
806if (($scheme !~ /^cvs/) && ($scheme !~ /^svn/) && ($scheme !~ /^svk/) && ($scheme !~ /^hg/) && ($scheme !~ /^git/)) {
807    # Do not compare if it's not a real cms
808    pb_log(1,"pb_vcs_compliant useless\n");
809    return;
810} elsif ((defined $pbinit) || (! -d "$ENV{$envar}")) {
811    my $exportdir = $ENV{$envar};
812    # Either we have a version in the uri, and it should be the same
813    # as the one in the envar. Or we should add the version to the uri
814    # But not if it's git as it manages version branches internally
815    if ((basename($uri) ne basename($exportdir)) && ($scheme !~ /git/)) {
816        $uri .= "/".basename($exportdir);
817    }
818    if ((defined $pbinit) && ($scheme =~ /git/)) {
819        # If initializing remove the potential pbconf part if we treat pbconfdir
820        $exportdir =~ s|pbconf[/]*||;
821    }
822    pb_log(1,"Checking out $uri\n");
823    # Create structure and remove end dir before exporting
824    pb_mkdir_p("$exportdir");
825    pb_rm_rf($exportdir);
826    pb_vcs_checkout($scheme,$uri,$exportdir);
827    if ((defined $pbinit) && ($scheme =~ /git/)) {
828        # And now created the potentially missin gpbconf dir
829        pb_mkdir_p("$exportdir/pbconf");
830    }
831} else {
832    pb_log(1,"$uri found locally, checking content\n");
833    my $cmsurl = pb_vcs_get_uri($scheme,$ENV{$envar});
834    my ($scheme2, $account2, $host2, $port2, $path2) = pb_get_uri($cmsurl);
835    # For svk, scheme doesn't appear in svk info so remove it here in uri coming from conf file
836    # which needs it to trigger correct behaviour
837    $uri =~ s/^svk://;
838    if ($scheme2 =~ /^git/) {
839        # remove schema from `git+file:` and `git+dir:` urls
840        # TODO: handle query-parameters
841        $uri =~ s/^git\+(file|dir):[\/]*//;
842        # Expand potential env variable in it -- this is required due to the consistency check
843        $uri =~ s/(\$ENV.+\})/$1/eeg;
844    } elsif ($scheme2 =~ /^hg/) {
845        # This VCS manages branches internally not with different tree structures
846        # Assuming it's correct for now.
847        return;
848    }
849    # Remove git+ part if only in scheme
850    $uri =~ s/^git\+// if (($scheme =~ /^git\+/) && ($scheme2 !~ /^git\+/));
851
852    if ($cmsurl ne $uri) {
853        # The local content doesn't correpond to the repository
854        pb_log(0,"ERROR: Inconsistency detected:\n");
855        pb_log(0,"       * $ENV{$envar} ($envar) refers to $cmsurl but\n");
856        pb_log(0,"       * $ENV{'PBETC'} refers to $uri\n");
857        die "Project $ENV{'PBPROJ'} is not Project-Builder compliant.";
858    } else {
859        pb_log(1,"Content correct - doing nothing - you may want to update your repository however\n");
860        # they match - do nothing - there may be local changes
861    }
862}
863pb_log(1,"pb_vcs_compliant end\n");
864}
865
866=item B<pb_vcs_conf_update_v0>
867
868This 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
869
870=cut
871
872
873sub pb_vcs_conf_update_v0 {
874
875my $orig = shift;
876my $dest = shift;
877
878pb_conf_update_v0($orig,$dest);
879# Adding this new file to VCS (not removing the previous one)
880my ($pbprojurl) = pb_conf_get("pbprojurl");
881my ($scheme, $account, $host, $port, $path) = pb_get_uri($pbprojurl->{$ENV{'PBPROJ'}});
882pb_vcs_add_if_not_in($scheme,$dest);
883}
884
885=back
886
887=head1 WEB SITES
888
889The 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/>.
890
891=head1 USER MAILING LIST
892
893None exists for the moment.
894
895=head1 AUTHORS
896
897The Project-Builder.org team L<http://trac.project-builder.org/> lead by Bruno Cornec L<mailto:bruno@project-builder.org>.
898
899=head1 COPYRIGHT
900
901Project-Builder.org is distributed under the GPL v2.0 license
902described in the file C<COPYING> included with the distribution.
903
904=cut
905
9061;
Note: See TracBrowser for help on using the repository browser.