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

Last change on this file since 2308 was 2308, checked in by Bruno Cornec, 7 years ago

Fix vcs_compliant for git+ssh

the URL computed was removing a git+ssh scheme abusively IMO

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):[\/]*//;
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.