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

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

initiate pbgitremote variable if not defined to origin

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