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

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