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

Last change on this file since 1560 was 1560, checked in by bruno, 7 years ago

-pb project: Add Copyrights specified by HP Open Source Review Board (Eric Anderson)

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