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

Revision 1492, 16.0 KB checked in by bruno, 13 months ago (diff)
  • pb_vcs_add and pb_vcs_up now support a list of dirs/files as second parameter
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-2012
11# Provided under the GPL v2
12
13package ProjectBuilder::VCS;
14
15use strict 'vars';
16use Data::Dumper;
17use English;
18use File::Basename;
19use File::Copy;
20use POSIX qw(strftime);
21use lib qw (lib);
22use ProjectBuilder::Version;
23use ProjectBuilder::Base;
24use ProjectBuilder::Conf;
25
26# Inherit from the "Exporter" module which handles exporting functions.
27 
28use vars qw($VERSION $REVISION @ISA @EXPORT);
29use Exporter;
30 
31# Export, by default, all the functions into the namespace of
32# any code which uses this module.
33 
34our @ISA = qw(Exporter);
35our @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_cmd);
36($VERSION,$REVISION) = pb_version_init();
37
38=pod
39
40=head1 NAME
41
42ProjectBuilder::VCS, part of the project-builder.org
43
44=head1 DESCRIPTION
45
46This modules provides version control system functions.
47
48=head1 USAGE
49
50=over 4
51
52=item B<pb_vcs_export>
53
54This function exports a VCS content to a directory.
55The first parameter is the URL of the VCS content.
56The second parameter is the directory in which it is locally exposed (result of a checkout). If undef, then use the original VCS content.
57The third parameter is the directory where we want to deliver it (result of export).
58It returns the original tar file if we need to preserve it and undef if we use the produced one.
59
60=cut
61
62sub pb_vcs_export {
63
64my $uri = shift;
65my $source = shift;
66my $destdir = shift;
67my $tmp;
68my $tmp1;
69
70pb_log(1,"pb_vcs_export uri: $uri - destdir: $destdir\n");
71pb_log(1,"pb_vcs_export source: $source\n") if (defined $source);
72my @date = pb_get_date();
73# If it's not flat, then we have a real uri as source
74my ($scheme, $account, $host, $port, $path) = pb_get_uri($uri);
75my $vcscmd = pb_vcs_cmd($scheme);
76$uri = pb_vcs_mod_socks($uri);
77
78if ($scheme =~ /^svn/) {
79        if (defined $source) {
80                if (-d $source) {
81                        $tmp = $destdir;
82                } else {
83                        $tmp = "$destdir/".basename($source);
84                }
85                $source = pb_vcs_mod_htftp($source,"svn");
86                pb_system("$vcscmd export $source $tmp","Exporting $source from $scheme to $tmp ");
87        } else {
88                $uri = pb_vcs_mod_htftp($uri,"svn");
89                pb_system("$vcscmd export $uri $destdir","Exporting $uri from $scheme to $destdir ");
90        }
91} elsif ($scheme eq "svk") {
92        my $src = $source;
93        if (defined $source) {
94                if (-d $source) {
95                        $tmp = $destdir;
96                } else {
97                        $tmp = "$destdir/".basename($source);
98                        $src = dirname($source);
99                }
100                $source = pb_vcs_mod_htftp($source,"svk");
101                # This doesn't exist !
102                # pb_system("$vcscmd export $path $tmp","Exporting $path from $scheme to $tmp ");
103                pb_log(4,"$uri,$source,$destdir,$scheme, $account, $host, $port, $path,$tmp");
104                if (-d $source) {
105                        pb_system("mkdir -p $tmp ; cd $tmp; tar -cf - -C $source . | tar xf -","Exporting $source from $scheme to $tmp ");
106                } else {
107                        # If source is file do not use -C with source
108                        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 ");
109                }
110        } else {
111                # Look at svk admin hotcopy
112                die "Unable to export from svk without a source defined";
113        }
114} elsif ($scheme eq "dir") {
115        pb_system("cp -r $path $destdir","Copying $uri from DIR to $destdir ");
116} elsif (($scheme eq "http") || ($scheme eq "ftp")) {
117        my $f = basename($path);
118        unlink "$ENV{'PBTMP'}/$f";
119        pb_system("$vcscmd $ENV{'PBTMP'}/$f $uri","Downloading $uri with $vcscmd to $ENV{'PBTMP'}/$f\n");
120        # We want to preserve the original tar file
121        pb_vcs_export("file://$ENV{'PBTMP'}/$f",$source,$destdir);
122        return("$ENV{'PBTMP'}/$f");
123} elsif ($scheme =~ /^file/) {
124        eval
125        {
126                require File::MimeInfo;
127                File::MimeInfo->import();
128        };
129        if ($@) {
130                # File::MimeInfo not found
131                die("ERROR: Install File::MimeInfo to handle scheme $scheme\n");
132        }
133
134        my $mm = mimetype($path);
135        pb_log(2,"mimetype: $mm\n");
136
137        # Check whether the file is well formed
138        # (containing already a directory with the project-version name)
139        #
140        # If it's not the case, we try to adapt, but distro needing
141        # to verify the checksum will have issues (Fedora)
142        # Then upstream should be notified that they need to change their rules
143        # This doesn't apply to patches or additional sources of course.
144        my ($pbwf) = pb_conf_get_if("pbwf");
145        if ((defined $pbwf) && (defined $pbwf->{$ENV{'PBPROJ'}}) && ($path !~ /\/pbpatch\//) && ($path !~ /\/pbsrc\//)) {
146                $destdir = dirname($destdir);
147                pb_log(2,"This is a well-formed file so destdir is now $destdir\n");
148        }
149        pb_mkdir_p($destdir);
150
151        if ($mm =~ /\/x-bzip-compressed-tar$/) {
152                # tar+bzip2
153                pb_system("cd $destdir ; tar xfj $path","Extracting $path in $destdir ");
154        } elsif ($mm =~ /\/x-lzma-compressed-tar$/) {
155                # tar+lzma
156                pb_system("cd $destdir ; tar xfY $path","Extracting $path in $destdir ");
157        } elsif ($mm =~ /\/x-compressed-tar$/) {
158                # tar+gzip
159                pb_system("cd $destdir ; tar xfz $path","Extracting $path in $destdir ");
160        } elsif ($mm =~ /\/x-tar$/) {
161                # tar
162                pb_system("cd $destdir ; tar xf $path","Extracting $path in $destdir ");
163        } elsif ($mm =~ /\/zip$/) {
164                # zip
165                pb_system("cd $destdir ; unzip $path","Extracting $path in $destdir ");
166        } else {
167                # simple file: copy it (patch e.g.)
168                copy($path,$destdir);
169        }
170} elsif ($scheme =~ /^hg/) {
171        if (defined $source) {
172                if (-d $source) {
173                        $tmp = $destdir;
174                } else {
175                        $tmp = "$destdir/".basename($source);
176                }
177                $source = pb_vcs_mod_htftp($source,"hg");
178                pb_system("cd $source ; $vcscmd archive $tmp","Exporting $source from Mercurial to $tmp ");
179        } else {
180                $uri = pb_vcs_mod_htftp($uri,"hg");
181                pb_system("$vcscmd clone $uri $destdir","Exporting $uri from Mercurial to $destdir ");
182        }
183} elsif ($scheme =~ /^git/) {
184        if (defined $source) {
185                if (-d $source) {
186                        $tmp = $destdir;
187                } else {
188                        $tmp = "$destdir/".basename($source);
189                }
190                $source = pb_vcs_mod_htftp($source,"git");
191                pb_system("cd $source ; $vcscmd archive --format=tar HEAD | (mkdir $tmp && cd $tmp && tar xf -)","Exporting $source/HEAD from GIT to $tmp ");
192        } else {
193                $uri = pb_vcs_mod_htftp($uri,"git");
194                pb_system("$vcscmd clone $uri $destdir","Exporting $uri from GIT to $destdir ");
195        }
196} elsif ($scheme =~ /^cvs/) {
197        # CVS needs a relative path !
198        my $dir=dirname($destdir);
199        my $base=basename($destdir);
200        if (defined $source) {
201                # CVS also needs a modules name not a dir
202                $tmp1 = basename($source);
203        } else {
204                # Probably not right, should be checked, but that way I'll notice it :-)
205                pb_log(0,"You're in an untested part of project-builder.org, please report any result upstream\n");
206                $tmp1 = $uri;
207        }
208        # If we're working on the CVS itself
209        my $cvstag = basename($ENV{'PBROOTDIR'});
210        my $cvsopt = "";
211        if ($cvstag eq "cvs") {
212                my $pbdate = strftime("%Y-%m-%d %H:%M:%S", @date);
213                $cvsopt = "-D \"$pbdate\"";
214        } else {
215                # we're working on a tag which should be the last part of PBROOTDIR
216                $cvsopt = "-r $cvstag";
217        }
218        pb_system("cd $dir ; $vcscmd -d $account\@$host:$path export $cvsopt -d $base $tmp1","Exporting $tmp1 from $source under CVS to $destdir ");
219} else {
220        die "cms $scheme unknown";
221}
222return(undef);
223}
224
225=item B<pb_vcs_get_uri>
226
227This function is only called with a real VCS system and gives the URL stored in the checked out directory.
228The first parameter is the schema of the VCS systems (svn, cvs, svn+ssh, ...)
229The second parameter is the directory in which it is locally exposed (result of a checkout).
230
231=cut
232
233sub pb_vcs_get_uri {
234
235my $scheme = shift;
236my $dir = shift;
237
238my $res = "";
239my $void = "";
240my $vcscmd = pb_vcs_cmd($scheme);
241
242if ($scheme =~ /^svn/) {
243        open(PIPE,"LANGUAGE=C $vcscmd info $dir |") || return("");
244        while (<PIPE>) {
245                ($void,$res) = split(/^URL:/) if (/^URL:/);
246        }
247        $res =~ s/^\s*//;
248        close(PIPE);
249        chomp($res);
250} elsif ($scheme =~ /^svk/) {
251        open(PIPE,"LANGUAGE=C $vcscmd info $dir |") || return("");
252        my $void2 = "";
253        while (<PIPE>) {
254                ($void,$void2,$res) = split(/ /) if (/^Depot/);
255        }
256        $res =~ s/^\s*//;
257        close(PIPE);
258        chomp($res);
259} elsif ($scheme =~ /^hg/) {
260        open(HGRC,".hg/hgrc/") || return("");
261        while (<HGRC>) {
262                ($void,$res) = split(/^default.*=/) if (/^default.*=/);
263        }
264        close(HGRC);
265        chomp($res);
266} elsif ($scheme =~ /^git/) {
267        open(GITRC,".git/gitrc/") || return("");
268        while (<GITRC>) {
269                ($void,$res) = split(/^default.*=/) if (/^default.*=/);
270        }
271        close(GITRC);
272        chomp($res);
273} elsif ($scheme =~ /^cvs/) {
274        # This path is always the root path of CVS, but we may be below
275        open(FILE,"$dir/CVS/Root") || die "$dir isn't CVS controlled";
276        $res = <FILE>;
277        chomp($res);
278        close(FILE);
279        # Find where we are in the tree
280        my $rdir = $dir;
281        while ((! -d "$rdir/CVSROOT") && ($rdir ne "/")) {
282                $rdir = dirname($rdir);
283        }
284        die "Unable to find a CVSROOT dir in the parents of $dir" if (! -d "$rdir/CVSROOT");
285        #compute our place under that root dir - should be a relative path
286        $dir =~ s|^$rdir||;
287        my $suffix = "";
288        $suffix = "$dir" if ($dir ne "");
289
290        my $prefix = "";
291        if ($scheme =~ /ssh/) {
292                $prefix = "cvs+ssh://";
293        } else {
294                $prefix = "cvs://";
295        }
296        $res = $prefix.$res.$suffix;
297} else {
298        die "cms $scheme unknown";
299}
300pb_log(1,"pb_vcs_get_uri returns $res\n");
301return($res);
302}
303
304=item B<pb_vcs_copy>
305
306This function copies a VCS content to another.
307The first parameter is the schema of the VCS systems (svn, cvs, svn+ssh, ...)
308The second parameter is the URL of the original VCS content.
309The third parameter is the URL of the destination VCS content.
310
311Only coded for SVN now as used for pbconf itself not the project
312
313=cut
314
315sub pb_vcs_copy {
316my $scheme = shift;
317my $oldurl = shift;
318my $newurl = shift;
319my $vcscmd = pb_vcs_cmd($scheme);
320$oldurl = pb_vcs_mod_socks($oldurl);
321$newurl = pb_vcs_mod_socks($newurl);
322
323if ($scheme =~ /^svn/) {
324        $oldurl = pb_vcs_mod_htftp($oldurl,"svn");
325        $newurl = pb_vcs_mod_htftp($newurl,"svn");
326        pb_system("$vcscmd copy -m \"Creation of $newurl from $oldurl\" $oldurl $newurl","Copying $oldurl to $newurl ");
327} elsif (($scheme eq "flat") || ($scheme eq "ftp") || ($scheme eq "http"))   {
328} else {
329        die "cms $scheme unknown for project management";
330}
331}
332
333=item B<pb_vcs_checkout>
334
335This function checks a VCS content out to a directory.
336The first parameter is the schema of the VCS systems (svn, cvs, svn+ssh, ...)
337The second parameter is the URL of the VCS content.
338The third parameter is the directory where we want to deliver it (result of export).
339
340=cut
341
342sub pb_vcs_checkout {
343my $scheme = shift;
344my $url = shift;
345my $destination = shift;
346my $vcscmd = pb_vcs_cmd($scheme);
347$url = pb_vcs_mod_socks($url);
348
349if ($scheme =~ /^svn/) {
350        $url = pb_vcs_mod_htftp($url,"svn");
351        pb_system("$vcscmd co $url $destination","Checking out $url to $destination ");
352} elsif ($scheme =~ /^svk/) {
353        $url = pb_vcs_mod_htftp($url,"svk");
354        pb_system("$vcscmd co $url $destination","Checking out $url to $destination ");
355} elsif ($scheme =~ /^hg/) {
356        $url = pb_vcs_mod_htftp($url,"hg");
357        pb_system("$vcscmd clone $url $destination","Checking out $url to $destination ");
358} elsif ($scheme =~ /^git/) {
359        $url = pb_vcs_mod_htftp($url,"git");
360        pb_system("$vcscmd clone $url $destination","Checking out $url to $destination ");
361} elsif (($scheme eq "ftp") || ($scheme eq "http")) {
362        return;
363} elsif ($scheme =~ /^cvs/) {
364        my ($scheme, $account, $host, $port, $path) = pb_get_uri($url);
365
366        # If we're working on the CVS itself
367        my $cvstag = basename($ENV{'PBROOTDIR'});
368        my $cvsopt = "";
369        if ($cvstag eq "cvs") {
370                my @date = pb_get_date();
371                my $pbdate = strftime("%Y-%m-%d %H:%M:%S", @date);
372                $cvsopt = "-D \"$pbdate\"";
373        } else {
374                # we're working on a tag which should be the last part of PBROOTDIR
375                $cvsopt = "-r $cvstag";
376        }
377        pb_mkdir_p("$destination");
378        pb_system("cd $destination ; $vcscmd -d $account\@$host:$path co $cvsopt .","Checking out $url to $destination ");
379} elsif ($scheme =~ /^file/) {
380        pb_vcs_export($url,undef,$destination);
381} else {
382        die "cms $scheme unknown";
383}
384}
385
386=item B<pb_vcs_up>
387
388This function updates a local directory with the VCS content.
389The first parameter is the schema of the VCS systems (svn, cvs, svn+ssh, ...)
390The second parameter is the list of directory to update.
391
392=cut
393
394sub pb_vcs_up {
395my $scheme = shift;
396my @dir = shift;
397my $vcscmd = pb_vcs_cmd($scheme);
398
399if (($scheme =~ /^svn/) || ($scheme =~ /^cvs/) || ($scheme =~ /^svk/)) {
400        pb_system("$vcscmd up ".join(' ',@dir),"Updating ".join(' ',@dir));
401} elsif (($scheme eq "flat") || ($scheme eq "ftp") || ($scheme eq "http"))   {
402} else {
403        die "cms $scheme unknown";
404}
405}
406
407=item B<pb_vcs_checkin>
408
409This function updates a VCS content from a local directory.
410The first parameter is the schema of the VCS systems (svn, cvs, svn+ssh, ...)
411The second parameter is the directory to update from.
412The third parameter is the comment to pass during the commit
413
414=cut
415
416sub pb_vcs_checkin {
417my $scheme = shift;
418my $dir = shift;
419my $msg = shift;
420my $vcscmd = pb_vcs_cmd($scheme);
421
422if (($scheme =~ /^svn/) || ($scheme =~ /^cvs/) || ($scheme =~ /^svk/)) {
423        pb_system("cd $dir ; $vcscmd ci -m \"$msg\" .","Checking in $dir ");
424} elsif (($scheme eq "flat") || ($scheme eq "ftp") || ($scheme eq "http"))   {
425} else {
426        die "cms $scheme unknown";
427}
428pb_vcs_up($scheme,$dir);
429}
430
431=item B<pb_vcs_add>
432
433This function adds to a VCS content from a local directory.
434The first parameter is the schema of the VCS systems (svn, cvs, svn+ssh, ...)
435The second parameter is a list of directory/file to add.
436
437=cut
438
439sub pb_vcs_add {
440my $scheme = shift;
441my @f = shift;
442my $vcscmd = pb_vcs_cmd($scheme);
443
444if (($scheme =~ /^svn/) || ($scheme =~ /^cvs/) || ($scheme =~ /^svk/)) {
445        pb_system("$vcscmd add ".join(' ',@f),"Adding ".join(' ',@f)." to VCS ");
446} elsif (($scheme eq "flat") || ($scheme eq "ftp") || ($scheme eq "http"))   {
447} else {
448        die "cms $scheme unknown";
449}
450pb_vcs_up($scheme,@f);
451}
452
453=item B<pb_vcs_isdiff>
454
455This function returns a integer indicating the number f differences between the VCS content and the local directory where it's checked out.
456The first parameter is the schema of the VCS systems (svn, cvs, svn+ssh, ...)
457The second parameter is the directory to consider.
458
459=cut
460
461sub pb_vcs_isdiff {
462my $scheme = shift;
463my $dir =shift;
464my $vcscmd = pb_vcs_cmd($scheme);
465my $l = undef;
466
467if (($scheme =~ /^svn/) || ($scheme =~ /^cvs/) || ($scheme =~ /^svk/)) {
468        open(PIPE,"$vcscmd diff $dir |") || die "Unable to get $vcscmd diff from $dir";
469        $l = 0;
470        while (<PIPE>) {
471                # Skipping normal messages in case of CVS
472                next if (/^cvs diff:/);
473                $l++;
474        }
475} elsif (($scheme eq "flat") || ($scheme eq "ftp") || ($scheme eq "http"))   {
476        $l = 0;
477} else {
478        die "cms $scheme unknown";
479}
480pb_log(1,"pb_vcs_isdiff returns $l\n");
481return($l);
482}
483
484sub pb_vcs_mod_htftp {
485
486my $url = shift;
487my $proto = shift;
488
489$url =~ s/^$proto\+((ht|f)tp[s]*):/$1:/;
490pb_log(1,"pb_vcs_mod_htftp returns $url\n");
491return($url);
492}
493
494sub pb_vcs_mod_socks {
495
496my $url = shift;
497
498$url =~ s/^([A-z0-9]+)\+(socks):/$1:/;
499pb_log(1,"pb_vcs_mod_socks returns $url\n");
500return($url);
501}
502
503
504sub pb_vcs_cmd {
505
506my $scheme = shift;
507my $cmd = "";
508
509# If there is a socks proxy to use
510if ($scheme =~ /socks/) {
511        # Get the socks proxy command from the conf file
512        my ($pbsockscmd) = pb_conf_get("pbsockscmd");
513        $cmd = "$pbsockscmd->{$ENV{'PBPROJ'}} ";
514}
515
516if ($scheme =~ /hg/) {
517        return($cmd."hg")
518} elsif ($scheme =~ /git/) {
519        return($cmd."git")
520} elsif ($scheme =~ /svn/) {
521        return($cmd."svn")
522} elsif ($scheme =~ /svk/) {
523        return($cmd."svk")
524} elsif ($scheme =~ /cvs/) {
525        return($cmd."cvs")
526} elsif (($scheme =~ /http/) || ($scheme =~ /ftp/)) {
527        my $command = pb_check_req("wget",1);
528        if (-x $command) {
529                return($cmd."$command -nv -O ");
530        } else {
531                $command = pb_check_req("curl",1);
532                if (-x $command) {
533                        return($cmd."$command -o ");
534                } else {
535                        die "Unable to handle $scheme.\nNo wget/curl available, please install one of those";
536                }
537        }
538} else {
539        return($cmd);
540}
541}
542
543       
544
545=back
546
547=head1 WEB SITES
548
549The 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/>.
550
551=head1 USER MAILING LIST
552
553None exists for the moment.
554
555=head1 AUTHORS
556
557The Project-Builder.org team L<http://trac.project-builder.org/> lead by Bruno Cornec L<mailto:bruno@project-builder.org>.
558
559=head1 COPYRIGHT
560
561Project-Builder.org is distributed under the GPL v2.0 license
562described in the file C<COPYING> included with the distribution.
563
564=cut
565
5661;
Note: See TracBrowser for help on using the repository browser.