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

Last change on this file since 1469 was 1469, checked in by bruno, 7 years ago
  • Split CMS functions in 2 parts, one lowlevel reusable outside of pb in VCS.pm, the remaining stay in CMS.pm, part of pb.
File size: 16.0 KB
RevLine 
[1469]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 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 $dir","Updating $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 the 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 $f","Adding $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.