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

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

Do not commit -a it's BAD !

File size: 23.8 KB
Line 
1#!/usr/bin/perl -w
2#
3# Project Builder VCS module
4# VCS subroutines brought by the the Project-Builder project
5# which can be easily used across projects needing to perform
6# VCS related operations
7#
8# $Id$
9#
10# Copyright B. Cornec 2007-today
11# Eric Anderson's changes are (c) Copyright 2012 Hewlett Packard
12# Provided under the GPL v2
13
14package ProjectBuilder::VCS;
15
16use strict 'vars';
17use Carp 'confess';
18use Cwd 'abs_path';
19use Data::Dumper;
20use English;
21use File::Basename;
22use File::Copy;
23use POSIX qw(strftime);
24use lib qw (lib);
25use ProjectBuilder::Version;
26use ProjectBuilder::Base;
27use ProjectBuilder::Conf;
28
29# Inherit from the "Exporter" module which handles exporting functions.
30 
31use vars qw($VERSION $REVISION @ISA @EXPORT);
32use Exporter;
33 
34# Export, by default, all the functions into the namespace of
35# any code which uses this module.
36 
37our @ISA = qw(Exporter);
38our @EXPORT = qw(pb_vcs_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    pb_system("$vcscmd add ".join(' ',@f),"Adding ".join(' ',@f)." to VCS ");
533} elsif ($scheme =~ /^(flat)|(ftp)|(http)|(https)|(file)\b/o) {
534    # Nothing to do.
535} else {
536    confess "cms $scheme unknown";
537}
538my @f1;
539foreach my $f (@f) {
540    push(@f1,$f) if (-d $f);
541    push(@f1,dirname($f)) if (-f $f);
542}
543pb_vcs_up($scheme,@f1);
544}
545
546=item B<pb_vcs_isdiff>
547
548This function returns a integer indicating the number of differences between the VCS content and the local directory where it's checked out.
549The first parameter is the schema of the VCS systems (svn, cvs, svn+ssh, ...)
550The second parameter is the directory to consider.
551
552=cut
553
554sub pb_vcs_isdiff {
555my $scheme = shift;
556my $dir =shift;
557my $vcscmd = pb_vcs_cmd($scheme);
558my $l = undef;
559
560if ($scheme =~ /^((svn)|(cvs)|(svk)|(git))/o) {
561    $vcscmd =~ s/ svn// if (($scheme =~ /git/) && ($scheme =~ /svn/));
562    open(PIPE,"$vcscmd diff $dir |") || confess "Unable to get $vcscmd diff from $dir";
563    $l = 0;
564    while (<PIPE>) {
565        # Skipping normal messages in case of CVS
566        next if (/^cvs diff:/);
567        $l++;
568    }
569} elsif ($scheme =~ /^(flat)|(ftp)|(http)|(https)|(file)\b/o) {
570    $l = 0;
571} else {
572    confess "cms $scheme unknown";
573}
574pb_log(1,"pb_vcs_isdiff returns $l\n");
575return($l);
576}
577
578sub pb_vcs_mod_htftp {
579
580my $url = shift;
581my $proto = shift;
582
583$url =~ s/^$proto\+((ht|f)tp[s]*):/$1:/;
584pb_log(1,"pb_vcs_mod_htftp returns $url\n");
585return($url);
586}
587
588sub pb_vcs_mod_socks {
589
590my $url = shift;
591
592$url =~ s/^([A-z0-9]+)\+(socks):/$1:/;
593pb_log(1,"pb_vcs_mod_socks returns $url\n");
594return($url);
595}
596
597
598sub pb_vcs_cmd {
599
600my $scheme = shift;
601my $cmd = "";
602my $cmdopt = "";
603
604# If there is a socks proxy to use
605if ($scheme =~ /socks/) {
606    # Get the socks proxy command from the conf file
607    my ($pbsockscmd) = pb_conf_get("pbsockscmd");
608    $cmd = "$pbsockscmd->{$ENV{'PBPROJ'}} ";
609}
610
611if (defined $ENV{'PBVCSOPT'}) {
612    $cmdopt .= " $ENV{'PBVCSOPT'}";
613}
614
615if ($scheme =~ /hg/) {
616    $cmd .= "hg".$cmdopt;
617} elsif ($scheme =~ /git/) {
618    if ($scheme =~ /svn/) {
619        $cmd .= "git svn".$cmdopt;
620    } else {
621        $cmd .= "git".$cmdopt;
622    }
623} elsif ($scheme =~ /svn/) {
624    $cmd .= "svn".$cmdopt;
625} elsif ($scheme =~ /svk/) {
626    $cmd .= "svk".$cmdopt;
627} elsif ($scheme =~ /cvs/) {
628    $cmd .= "cvs".$cmdopt;
629} elsif (($scheme =~ /http/) || ($scheme =~ /ftp/)) {
630    my $command = pb_check_req("wget",1);
631    if (-x $command) {
632        $cmd .= "$command -nv -O ";
633    } else {
634        $command = pb_check_req("curl",1);
635        if (-x $command) {
636            $cmd .= "$command -o ";
637        } else {
638            confess "Unable to handle $scheme.\nNo wget/curl available, please install one of those";
639        }
640    }
641} else {
642    $cmd = "";
643}
644pb_log(3,"pb_vcs_cmd returns $cmd\n");
645return($cmd);
646}
647
648=item B<pb_vcs_compliant>
649
650This function checks the compliance of the project and the pbconf directory.
651The first parameter is the key name of the value that needs to be read in the configuration file.
652The second parameter is the environment variable this key will populate.
653The third parameter is the location of the pbconf dir.
654The fourth parameter is the URI of the CMS content related to the pbconf dir.
655The fifth parameter indicates whether we should inititate the context or not.
656
657=cut
658
659sub pb_vcs_compliant {
660
661my $param = shift;
662my $envar = shift;
663my $defdir = shift;
664my $uri = shift;
665my $pbinit = shift;
666my %pdir;
667
668pb_log(1,"pb_vcs_compliant: envar: $envar - defdir: $defdir - uri: $uri\n");
669my ($pdir) = pb_conf_get_if($param) if (defined $param);
670if (defined $pdir) {
671    %pdir = %$pdir;
672}
673
674if ((defined $pdir) && (%pdir) && (defined $pdir{$ENV{'PBPROJ'}})) {
675    # That's always the environment variable that will be used
676    $ENV{$envar} = $pdir{$ENV{'PBPROJ'}};
677} else {
678    if (defined $param) {
679        pb_log(1,"WARNING: no $param defined, using $defdir\n");
680        pb_log(1,"         Please create a $param reference for project $ENV{'PBPROJ'} in $ENV{'PBETC'}\n");
681        pb_log(1,"         if you want to use another directory\n");
682    }
683    $ENV{$envar} = "$defdir";
684}
685
686# Expand potential env variable in it
687eval { $ENV{$envar} =~ s/(\$ENV.+\})/$1/eeg };
688pb_log(2,"$envar: $ENV{$envar}\n");
689
690my ($scheme, $account, $host, $port, $path) = pb_get_uri($uri);
691
692if (($scheme !~ /^cvs/) && ($scheme !~ /^svn/) && ($scheme !~ /^svk/) && ($scheme !~ /^hg/) && ($scheme !~ /^git/)) {
693    # Do not compare if it's not a real cms
694    pb_log(1,"pb_vcs_compliant useless\n");
695    return;
696} elsif ((defined $pbinit) || (! -d "$ENV{$envar}")) {
697    my $exportdir = $ENV{$envar};
698    # Either we have a version in the uri, and it should be the same
699    # as the one in the envar. Or we should add the version to the uri
700    # But not if it's git as it manages version branches internally
701    if ((basename($uri) ne basename($exportdir)) && ($scheme !~ /git/)) {
702        $uri .= "/".basename($exportdir);
703    }
704    if ((defined $pbinit) && ($scheme =~ /git/)) {
705        # If initializing remove the potential pbconf part if we treat pbconfdir
706        $exportdir =~ s|pbconf[/]*||;
707    }
708    pb_log(1,"Checking out $uri\n");
709    # Create structure and remove end dir before exporting
710    pb_mkdir_p("$exportdir");
711    pb_rm_rf($exportdir);
712    pb_vcs_checkout($scheme,$uri,$exportdir);
713    if ((defined $pbinit) && ($scheme =~ /git/)) {
714        # And now created the potentially missin gpbconf dir
715        pb_mkdir_p("$exportdir/pbconf");
716    }
717} else {
718    pb_log(1,"$uri found locally, checking content\n");
719    my $cmsurl = pb_vcs_get_uri($scheme,$ENV{$envar});
720    my ($scheme2, $account2, $host2, $port2, $path2) = pb_get_uri($cmsurl);
721    # For svk, scheme doesn't appear in svk info so remove it here in uri coming from conf file
722    # which needs it to trigger correct behaviour
723    $uri =~ s/^svk://;
724    if ($scheme2 =~ /^git/) {
725        # remove schema from `git+file:` and `git+dir:` urls
726        # TODO: handle query-parameters
727        $uri =~ s/^git\+(file|dir|ssh):[\/]*//;
728        # Expand potential env variable in it -- this is required due to the consistency check
729        $uri =~ s/(\$ENV.+\})/$1/eeg;
730    } elsif ($scheme2 =~ /^hg/) {
731        # This VCS manages branches internally not with different tree structures
732        # Assuming it's correct for now.
733        return;
734    }
735    # Remove git+ part if only in scheme
736    $uri =~ s/^git\+// if (($scheme =~ /^git\+/) && ($scheme2 !~ /^git\+/));
737
738    if ($cmsurl ne $uri) {
739        # The local content doesn't correpond to the repository
740        pb_log(0,"ERROR: Inconsistency detected:\n");
741        pb_log(0,"       * $ENV{$envar} ($envar) refers to $cmsurl but\n");
742        pb_log(0,"       * $ENV{'PBETC'} refers to $uri\n");
743        die "Project $ENV{'PBPROJ'} is not Project-Builder compliant.";
744    } else {
745        pb_log(1,"Content correct - doing nothing - you may want to update your repository however\n");
746        # they match - do nothing - there may be local changes
747    }
748}
749pb_log(1,"pb_vcs_compliant end\n");
750}
751
752=item B<pb_vcs_conf_update_v0>
753
754This 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
755
756=cut
757
758
759sub pb_vcs_conf_update_v0 {
760
761my $orig = shift;
762my $dest = shift;
763
764pb_conf_update_v0($orig,$dest);
765# Adding this new file to VCS (not removing the previous one)
766my ($pbprojurl) = pb_conf_get("pbprojurl");
767my ($scheme, $account, $host, $port, $path) = pb_get_uri($pbprojurl->{$ENV{'PBPROJ'}});
768pb_vcs_add_if_not_in($scheme,$dest);
769}
770
771=back
772
773=head1 WEB SITES
774
775The 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/>.
776
777=head1 USER MAILING LIST
778
779None exists for the moment.
780
781=head1 AUTHORS
782
783The Project-Builder.org team L<http://trac.project-builder.org/> lead by Bruno Cornec L<mailto:bruno@project-builder.org>.
784
785=head1 COPYRIGHT
786
787Project-Builder.org is distributed under the GPL v2.0 license
788described in the file C<COPYING> included with the distribution.
789
790=cut
791
7921;
Note: See TracBrowser for help on using the repository browser.