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

Last change on this file since 1536 was 1536, checked in by bruno, 7 years ago
  • Improve git support for pb_vcs_get_uri (Eric Anderson) as for the previous patches
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(GIT,"git --git-dir=$dir/.git remote -v |") || return("");
269    while (<GITRC>) {
270        next unless (/^origin\s+(\S+) \(push\)$/);
271        return $1;
272    }
273    close(GITRC);
274    warn "Unable to find origin remote for $dir";
275    return "";
276} elsif ($scheme =~ /^cvs/) {
277    # This path is always the root path of CVS, but we may be below
278    open(FILE,"$dir/CVS/Root") || die "$dir isn't CVS controlled";
279    $res = <FILE>;
280    chomp($res);
281    close(FILE);
282    # Find where we are in the tree
283    my $rdir = $dir;
284    while ((! -d "$rdir/CVSROOT") && ($rdir ne "/")) {
285        $rdir = dirname($rdir);
286    }
287    die "Unable to find a CVSROOT dir in the parents of $dir" if (! -d "$rdir/CVSROOT");
288    #compute our place under that root dir - should be a relative path
289    $dir =~ s|^$rdir||;
290    my $suffix = "";
291    $suffix = "$dir" if ($dir ne "");
292
293    my $prefix = "";
294    if ($scheme =~ /ssh/) {
295        $prefix = "cvs+ssh://";
296    } else {
297        $prefix = "cvs://";
298    }
299    $res = $prefix.$res.$suffix;
300} else {
301    die "cms $scheme unknown";
302}
303pb_log(1,"pb_vcs_get_uri returns $res\n");
304return($res);
305}
306
307=item B<pb_vcs_copy>
308
309This function copies a VCS content to another.
310The first parameter is the schema of the VCS systems (svn, cvs, svn+ssh, ...)
311The second parameter is the URL of the original VCS content.
312The third parameter is the URL of the destination VCS content.
313
314Only coded for SVN now as used for pbconf itself not the project
315
316=cut
317
318sub pb_vcs_copy {
319my $scheme = shift;
320my $oldurl = shift;
321my $newurl = shift;
322my $vcscmd = pb_vcs_cmd($scheme);
323$oldurl = pb_vcs_mod_socks($oldurl);
324$newurl = pb_vcs_mod_socks($newurl);
325
326if ($scheme =~ /^svn/) {
327    $oldurl = pb_vcs_mod_htftp($oldurl,"svn");
328    $newurl = pb_vcs_mod_htftp($newurl,"svn");
329    pb_system("$vcscmd copy -m \"Creation of $newurl from $oldurl\" $oldurl $newurl","Copying $oldurl to $newurl ");
330} elsif (($scheme eq "flat") || ($scheme eq "ftp") || ($scheme eq "http"))   {
331} else {
332    die "cms $scheme unknown for project management";
333}
334}
335
336=item B<pb_vcs_checkout>
337
338This function checks a VCS content out to a directory.
339The first parameter is the schema of the VCS systems (svn, cvs, svn+ssh, ...)
340The second parameter is the URL of the VCS content.
341The third parameter is the directory where we want to deliver it (result of export).
342
343=cut
344
345sub pb_vcs_checkout {
346my $scheme = shift;
347my $url = shift;
348my $destination = shift;
349my $vcscmd = pb_vcs_cmd($scheme);
350$url = pb_vcs_mod_socks($url);
351
352if ($scheme =~ /^svn/) {
353    $url = pb_vcs_mod_htftp($url,"svn");
354    pb_system("$vcscmd co $url $destination","Checking out $url to $destination ");
355} elsif ($scheme =~ /^svk/) {
356    $url = pb_vcs_mod_htftp($url,"svk");
357    pb_system("$vcscmd co $url $destination","Checking out $url to $destination ");
358} elsif ($scheme =~ /^hg/) {
359    $url = pb_vcs_mod_htftp($url,"hg");
360    pb_system("$vcscmd clone $url $destination","Checking out $url to $destination ");
361} elsif ($scheme =~ /^git/) {
362    $url = pb_vcs_mod_htftp($url,"git");
363    pb_system("$vcscmd clone $url $destination","Checking out $url to $destination ");
364} elsif (($scheme eq "ftp") || ($scheme eq "http")) {
365    return;
366} elsif ($scheme =~ /^cvs/) {
367    my ($scheme, $account, $host, $port, $path) = pb_get_uri($url);
368
369    # If we're working on the CVS itself
370    my $cvstag = basename($ENV{'PBROOTDIR'});
371    my $cvsopt = "";
372    if ($cvstag eq "cvs") {
373        my @date = pb_get_date();
374        my $pbdate = strftime("%Y-%m-%d %H:%M:%S", @date);
375        $cvsopt = "-D \"$pbdate\"";
376    } else {
377        # we're working on a tag which should be the last part of PBROOTDIR
378        $cvsopt = "-r $cvstag";
379    }
380    pb_mkdir_p("$destination");
381    pb_system("cd $destination ; $vcscmd -d $account\@$host:$path co $cvsopt .","Checking out $url to $destination ");
382} elsif ($scheme =~ /^file/) {
383    pb_vcs_export($url,undef,$destination);
384} else {
385    die "cms $scheme unknown";
386}
387}
388
389=item B<pb_vcs_up>
390
391This function updates a local directory with the VCS content.
392The first parameter is the schema of the VCS systems (svn, cvs, svn+ssh, ...)
393The second parameter is the list of directory to update.
394
395=cut
396
397sub pb_vcs_up {
398my $scheme = shift;
399my @dir = @_;
400my $vcscmd = pb_vcs_cmd($scheme);
401
402if (($scheme =~ /^((svn)|(cvs)|(svk))/o) {
403    pb_system("$vcscmd up ".join(' ',@dir),"Updating ".join(' ',@dir));
404} elsif ($scheme =~ /^((hg)|(git))/o) {
405    pb_system("(cd $dir && $vcscmd pull)", "Updating $dir ");
406} elsif (($scheme eq "flat") || ($scheme eq "ftp") || ($scheme eq "http"))   {
407} else {
408    die "cms $scheme unknown";
409}
410}
411
412=item B<pb_vcs_checkin>
413
414This function updates a VCS content from a local directory.
415The first parameter is the schema of the VCS systems (svn, cvs, svn+ssh, ...)
416The second parameter is the directory to update from.
417The third parameter is the comment to pass during the commit
418
419=cut
420
421sub pb_vcs_checkin {
422my $scheme = shift;
423my $dir = shift;
424my $msg = shift;
425my $vcscmd = pb_vcs_cmd($scheme);
426
427if (($scheme =~ /^((svn)|(cvs)|(svk))/o) {
428    pb_system("cd $dir && $vcscmd ci -m \"$msg\" .","Checking in $dir ");
429} elsif ($scheme =~ /^git/) {
430    pb_system("cd $dir && $vcscmd commit -a -m \"$msg\"", "Checking in $dir ");
431} elsif (($scheme eq "flat") || ($scheme eq "ftp") || ($scheme eq "http"))   {
432} else {
433    die "cms $scheme unknown";
434}
435pb_vcs_up($scheme,$dir);
436}
437
438=item B<pb_vcs_add>
439
440This function adds to a VCS content from a local directory.
441The first parameter is the schema of the VCS systems (svn, cvs, svn+ssh, ...)
442The second parameter is a list of directory/file to add.
443
444=cut
445
446sub pb_vcs_add {
447my $scheme = shift;
448my @f = @_;
449my $vcscmd = pb_vcs_cmd($scheme);
450
451if ($scheme =~ /^((hg)|(git)|(svn)|(svk)|(cvs))/o) {
452    pb_system("$vcscmd add ".join(' ',@f),"Adding ".join(' ',@f)." to VCS ");
453} elsif (($scheme eq "flat") || ($scheme eq "ftp") || ($scheme eq "http"))   {
454} else {
455    die "cms $scheme unknown";
456}
457pb_vcs_up($scheme,@f);
458}
459
460=item B<pb_vcs_isdiff>
461
462This function returns a integer indicating the number f differences between the VCS content and the local directory where it's checked out.
463The first parameter is the schema of the VCS systems (svn, cvs, svn+ssh, ...)
464The second parameter is the directory to consider.
465
466=cut
467
468sub pb_vcs_isdiff {
469my $scheme = shift;
470my $dir =shift;
471my $vcscmd = pb_vcs_cmd($scheme);
472my $l = undef;
473
474if (($scheme =~ /^((svn)|(cvs)|(svk))/o) {
475    open(PIPE,"$vcscmd diff $dir |") || die "Unable to get $vcscmd diff from $dir";
476    $l = 0;
477    while (<PIPE>) {
478        # Skipping normal messages in case of CVS
479        next if (/^cvs diff:/);
480        $l++;
481    }
482} elsif (($scheme eq "flat") || ($scheme eq "ftp") || ($scheme eq "http"))   {
483    $l = 0;
484} else {
485    die "cms $scheme unknown";
486}
487pb_log(1,"pb_vcs_isdiff returns $l\n");
488return($l);
489}
490
491sub pb_vcs_mod_htftp {
492
493my $url = shift;
494my $proto = shift;
495
496$url =~ s/^$proto\+((ht|f)tp[s]*):/$1:/;
497pb_log(1,"pb_vcs_mod_htftp returns $url\n");
498return($url);
499}
500
501sub pb_vcs_mod_socks {
502
503my $url = shift;
504
505$url =~ s/^([A-z0-9]+)\+(socks):/$1:/;
506pb_log(1,"pb_vcs_mod_socks returns $url\n");
507return($url);
508}
509
510
511sub pb_vcs_cmd {
512
513my $scheme = shift;
514my $cmd = "";
515
516# If there is a socks proxy to use
517if ($scheme =~ /socks/) {
518    # Get the socks proxy command from the conf file
519    my ($pbsockscmd) = pb_conf_get("pbsockscmd");
520    $cmd = "$pbsockscmd->{$ENV{'PBPROJ'}} ";
521}
522
523if ($scheme =~ /hg/) {
524    return($cmd."hg")
525} elsif ($scheme =~ /git/) {
526    return($cmd."git")
527} elsif ($scheme =~ /svn/) {
528    return($cmd."svn")
529} elsif ($scheme =~ /svk/) {
530    return($cmd."svk")
531} elsif ($scheme =~ /cvs/) {
532    return($cmd."cvs")
533} elsif (($scheme =~ /http/) || ($scheme =~ /ftp/)) {
534    my $command = pb_check_req("wget",1);
535    if (-x $command) {
536        return($cmd."$command -nv -O ");
537    } else {
538        $command = pb_check_req("curl",1);
539        if (-x $command) {
540            return($cmd."$command -o ");
541        } else {
542            die "Unable to handle $scheme.\nNo wget/curl available, please install one of those";
543        }
544    }
545} else {
546    return($cmd);
547}
548}
549
550   
551
552=back
553
554=head1 WEB SITES
555
556The 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/>.
557
558=head1 USER MAILING LIST
559
560None exists for the moment.
561
562=head1 AUTHORS
563
564The Project-Builder.org team L<http://trac.project-builder.org/> lead by Bruno Cornec L<mailto:bruno@project-builder.org>.
565
566=head1 COPYRIGHT
567
568Project-Builder.org is distributed under the GPL v2.0 license
569described in the file C<COPYING> included with the distribution.
570
571=cut
572
5731;
Note: See TracBrowser for help on using the repository browser.