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

Last change on this file since 2307 was 2307, checked in by bruno, 21 months ago

git add needs to be done in the subtree

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