source: devel/pb/lib/ProjectBuilder/CMS.pm @ 1421

Last change on this file since 1421 was 1421, checked in by bruno, 7 years ago
  • Improve handling of lack of svn2cl command
File size: 28.8 KB
Line 
1#!/usr/bin/perl -w
2#
3# Project Builder CMS module
4# CMS subroutines brought by the the Project-Builder project
5# which can be easily used by pbinit scripts
6#
7# $Id$
8#
9# Copyright B. Cornec 2007
10# Provided under the GPL v2
11
12package ProjectBuilder::CMS;
13
14use strict 'vars';
15use Data::Dumper;
16use English;
17use File::Basename;
18use File::Copy;
19use POSIX qw(strftime);
20use lib qw (lib);
21use ProjectBuilder::Version;
22use ProjectBuilder::Base;
23use ProjectBuilder::Conf;
24
25# Inherit from the "Exporter" module which handles exporting functions.
26 
27use vars qw($VERSION $REVISION @ISA @EXPORT);
28use Exporter;
29 
30# Export, by default, all the functions into the namespace of
31# any code which uses this module.
32 
33our @ISA = qw(Exporter);
34our @EXPORT = qw(pb_cms_init pb_cms_export pb_cms_get_uri pb_cms_copy pb_cms_checkout pb_cms_up pb_cms_checkin pb_cms_isdiff pb_cms_get_pkg pb_cms_get_real_pkg pb_cms_compliant pb_cms_log pb_cms_add);
35($VERSION,$REVISION) = pb_version_init();
36
37=pod
38
39=head1 NAME
40
41ProjectBuilder::CMS, part of the project-builder.org
42
43=head1 DESCRIPTION
44
45This modules provides configuration management system functions suitable for pbinit calls.
46
47=head1 USAGE
48
49=over 4
50
51=item B<pb_cms_init>
52
53This function setup the environment for the CMS system related to the URL given by the pburl configuration parameter.
54The potential parameter indicates whether we should inititate the context or not.
55It sets up environement variables (PBPROJDIR, PBDIR, PBREVISION, PBCMSLOGFILE)
56
57=cut
58
59sub pb_cms_init {
60
61my $pbinit = shift || undef;
62my $param = shift || undef;
63
64my ($pburl) = pb_conf_get("pburl");
65pb_log(2,"DEBUG: Project URL of $ENV{'PBPROJ'}: $pburl->{$ENV{'PBPROJ'}}\n");
66my ($scheme, $account, $host, $port, $path) = pb_get_uri($pburl->{$ENV{'PBPROJ'}});
67my $vcscmd = pb_cms_cmd($scheme);
68
69my ($pbprojdir) = pb_conf_get_if("pbprojdir");
70
71if ((defined $pbprojdir) && (defined $pbprojdir->{$ENV{'PBPROJ'}})) {
72    $ENV{'PBPROJDIR'} = $pbprojdir->{$ENV{'PBPROJ'}};
73} else {
74    $ENV{'PBPROJDIR'} = "$ENV{'PBDEFDIR'}/$ENV{'PBPROJ'}";
75}
76# Expand potential env variable in it to allow string replacement
77eval { $ENV{'PBPROJDIR'} =~ s/(\$ENV.+\})/$1/eeg };
78
79
80# Computing the default dir for PBDIR.
81# what we have is PBPROJDIR so work from that.
82# Tree identical between PBCONFDIR and PBROOTDIR on one side and
83# PBPROJDIR and PBDIR on the other side.
84
85my $tmp = $ENV{'PBROOTDIR'};
86$tmp =~ s|^$ENV{'PBCONFDIR'}/||;
87
88#
89# Check project cms compliance
90#
91my $turl = "$pburl->{$ENV{'PBPROJ'}}/$tmp";
92$turl = $pburl->{$ENV{'PBPROJ'}} if (($scheme =~ /^file/) || ($scheme =~ /^(ht|f)tp/));
93pb_cms_compliant(undef,'PBDIR',"$ENV{'PBPROJDIR'}/$tmp",$turl,$pbinit);
94
95
96if ($scheme =~ /^hg/) {
97    $tmp = `(cd "$ENV{'PBDIR'}" ; $vcscmd identify )`;
98    chomp($tmp);
99    $tmp =~ s/^.* //;
100    $ENV{'PBREVISION'}=$tmp;
101    $ENV{'PBCMSLOGFILE'}="hg.log";
102} elsif ($scheme =~ /^git/) {
103    $tmp = `(cd "$ENV{'PBDIR'}" ; $vcscmd log | head -1 | cut -f2)`;
104    chomp($tmp);
105    $tmp =~ s/^.* //;
106    $ENV{'PBREVISION'}=$tmp;
107    $ENV{'PBCMSLOGFILE'}="git.log";
108} elsif (($scheme =~ /^file/) || ($scheme eq "ftp") || ($scheme eq "http")) {
109    $ENV{'PBREVISION'}="flat";
110    $ENV{'PBCMSLOGFILE'}="flat.log";
111} elsif ($scheme =~ /^svn/) {
112    # svnversion more precise than svn info if sbx
113    if ((defined $param) && ($param eq "CMS")) {
114        $tmp = `(LANGUAGE=C $vcscmd info $pburl->{$ENV{'PBPROJ'}} | grep -E '^Revision:' | cut -d: -f2)`;
115        $tmp =~ s/\s+//;
116    } else {
117        $tmp = `(cd "$ENV{'PBDIR'}" ; $vcscmd"version" .)`;
118    }
119    chomp($tmp);
120    $ENV{'PBREVISION'}=$tmp;
121    $ENV{'PBCMSLOGFILE'}="svn.log";
122} elsif ($scheme =~ /^svk/) {
123    $tmp = `(cd "$ENV{'PBDIR'}" ; LANGUAGE=C $vcscmd info . | grep -E '^Revision:' | cut -d: -f2)`;
124    $tmp =~ s/\s+//;
125    chomp($tmp);
126    $ENV{'PBREVISION'}=$tmp;
127    $ENV{'PBCMSLOGFILE'}="svk.log";
128} elsif ($scheme =~ /^cvs/) {
129    # Way too slow
130    #$ENV{'PBREVISION'}=`(cd "$ENV{'PBROOTDIR'}" ; cvs rannotate  -f . 2>&1 | awk '{print \$1}' | grep -E '^[0-9]' | cut -d. -f2 |sort -nu | tail -1)`;
131    #chomp($ENV{'PBREVISION'});
132    $ENV{'PBREVISION'}="cvs";
133    $ENV{'PBCMSLOGFILE'}="cvs.log";
134    $ENV{'CVS_RSH'} = "ssh" if ($scheme =~ /ssh/);
135} else {
136    die "cms $scheme unknown";
137}
138
139pb_log(1,"pb_cms_init returns $scheme,$pburl->{$ENV{'PBPROJ'}}\n");
140return($scheme,$pburl->{$ENV{'PBPROJ'}});
141}
142
143=item B<pb_cms_export>
144
145This function exports a CMS content to a directory.
146The first parameter is the URL of the CMS content.
147The second parameter is the directory in which it is locally exposed (result of a checkout). If undef, then use the original CMS content.
148The third parameter is the directory where we want to deliver it (result of export).
149It returns the original tar file if we need to preserve it and undef if we use the produced one.
150
151=cut
152
153sub pb_cms_export {
154
155my $uri = shift;
156my $source = shift;
157my $destdir = shift;
158my $tmp;
159my $tmp1;
160
161pb_log(1,"pb_cms_export uri: $uri - destdir: $destdir\n");
162pb_log(1,"pb_cms_export source: $source\n") if (defined $source);
163my @date = pb_get_date();
164# If it's not flat, then we have a real uri as source
165my ($scheme, $account, $host, $port, $path) = pb_get_uri($uri);
166my $vcscmd = pb_cms_cmd($scheme);
167$uri = pb_cms_mod_socks($uri);
168
169if ($scheme =~ /^svn/) {
170    if (defined $source) {
171        if (-d $source) {
172            $tmp = $destdir;
173        } else {
174            $tmp = "$destdir/".basename($source);
175        }
176        $source = pb_cms_mod_htftp($source,"svn");
177        pb_system("$vcscmd export $source $tmp","Exporting $source from $scheme to $tmp ");
178    } else {
179        $uri = pb_cms_mod_htftp($uri,"svn");
180        pb_system("$vcscmd export $uri $destdir","Exporting $uri from $scheme to $destdir ");
181    }
182} elsif ($scheme eq "svk") {
183    my $src = $source;
184    if (defined $source) {
185        if (-d $source) {
186            $tmp = $destdir;
187        } else {
188            $tmp = "$destdir/".basename($source);
189            $src = dirname($source);
190        }
191        $source = pb_cms_mod_htftp($source,"svk");
192        # This doesn't exist !
193        # pb_system("$vcscmd export $path $tmp","Exporting $path from $scheme to $tmp ");
194        pb_log(4,"$uri,$source,$destdir,$scheme, $account, $host, $port, $path,$tmp");
195        if (-d $source) {
196            pb_system("mkdir -p $tmp ; cd $tmp; tar -cf - -C $source . | tar xf -","Exporting $source from $scheme to $tmp ");
197        } else {
198            # If source is file do not use -C with source
199            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 ");
200        }
201    } else {
202        # Look at svk admin hotcopy
203        die "Unable to export from svk without a source defined";
204    }
205} elsif ($scheme eq "dir") {
206    pb_system("cp -r $path $destdir","Copying $uri from DIR to $destdir ");
207} elsif (($scheme eq "http") || ($scheme eq "ftp")) {
208    my $f = basename($path);
209    unlink "$ENV{'PBTMP'}/$f";
210    pb_system("$vcscmd $ENV{'PBTMP'}/$f $uri","Downloading $uri with $vcscmd to $ENV{'PBTMP'}/$f\n");
211    # We want to preserve the original tar file
212    pb_cms_export("file://$ENV{'PBTMP'}/$f",$source,$destdir);
213    return("$ENV{'PBTMP'}/$f");
214} elsif ($scheme =~ /^file/) {
215    eval
216    {
217        require File::MimeInfo;
218        File::MimeInfo->import();
219    };
220    if ($@) {
221        # File::MimeInfo not found
222        die("ERROR: Install File::MimeInfo to handle scheme $scheme\n");
223    }
224
225    my $mm = mimetype($path);
226    pb_log(2,"mimetype: $mm\n");
227
228    # Check whether the file is well formed
229    # (containing already a directory with the project-version name)
230    #
231    # If it's not the case, we try to adapt, but distro needing
232    # to verify the checksum will have issues (Fedora)
233    # Then upstream should be notified that they need to change their rules
234    # This doesn't apply to patches or additional sources of course.
235    my ($pbwf) = pb_conf_get_if("pbwf");
236    if ((defined $pbwf) && (defined $pbwf->{$ENV{'PBPROJ'}}) && ($path !~ /\/pbpatch\//) && ($path !~ /\/pbsrc\//)) {
237        $destdir = dirname($destdir);
238        pb_log(2,"This is a well-formed file so destdir is now $destdir\n");
239    }
240    pb_mkdir_p($destdir);
241
242    if ($mm =~ /\/x-bzip-compressed-tar$/) {
243        # tar+bzip2
244        pb_system("cd $destdir ; tar xfj $path","Extracting $path in $destdir ");
245    } elsif ($mm =~ /\/x-lzma-compressed-tar$/) {
246        # tar+lzma
247        pb_system("cd $destdir ; tar xfY $path","Extracting $path in $destdir ");
248    } elsif ($mm =~ /\/x-compressed-tar$/) {
249        # tar+gzip
250        pb_system("cd $destdir ; tar xfz $path","Extracting $path in $destdir ");
251    } elsif ($mm =~ /\/x-tar$/) {
252        # tar
253        pb_system("cd $destdir ; tar xf $path","Extracting $path in $destdir ");
254    } elsif ($mm =~ /\/zip$/) {
255        # zip
256        pb_system("cd $destdir ; unzip $path","Extracting $path in $destdir ");
257    } else {
258        # simple file: copy it (patch e.g.)
259        copy($path,$destdir);
260    }
261} elsif ($scheme =~ /^hg/) {
262    if (defined $source) {
263        if (-d $source) {
264            $tmp = $destdir;
265        } else {
266            $tmp = "$destdir/".basename($source);
267        }
268        $source = pb_cms_mod_htftp($source,"hg");
269        pb_system("cd $source ; $vcscmd archive $tmp","Exporting $source from Mercurial to $tmp ");
270    } else {
271        $uri = pb_cms_mod_htftp($uri,"hg");
272        pb_system("$vcscmd clone $uri $destdir","Exporting $uri from Mercurial to $destdir ");
273    }
274} elsif ($scheme =~ /^git/) {
275    if (defined $source) {
276        if (-d $source) {
277            $tmp = $destdir;
278        } else {
279            $tmp = "$destdir/".basename($source);
280        }
281        $source = pb_cms_mod_htftp($source,"git");
282        pb_system("cd $source ; $vcscmd archive --format=tar HEAD | (mkdir $tmp && cd $tmp && tar xf -)","Exporting $source/HEAD from GIT to $tmp ");
283    } else {
284        $uri = pb_cms_mod_htftp($uri,"git");
285        pb_system("$vcscmd clone $uri $destdir","Exporting $uri from GIT to $destdir ");
286    }
287} elsif ($scheme =~ /^cvs/) {
288    # CVS needs a relative path !
289    my $dir=dirname($destdir);
290    my $base=basename($destdir);
291    if (defined $source) {
292        # CVS also needs a modules name not a dir
293        $tmp1 = basename($source);
294    } else {
295        # Probably not right, should be checked, but that way I'll notice it :-)
296        pb_log(0,"You're in an untested part of project-builder.org, please report any result upstream\n");
297        $tmp1 = $uri;
298    }
299    # If we're working on the CVS itself
300    my $cvstag = basename($ENV{'PBROOTDIR'});
301    my $cvsopt = "";
302    if ($cvstag eq "cvs") {
303        my $pbdate = strftime("%Y-%m-%d %H:%M:%S", @date);
304        $cvsopt = "-D \"$pbdate\"";
305    } else {
306        # we're working on a tag which should be the last part of PBROOTDIR
307        $cvsopt = "-r $cvstag";
308    }
309    pb_system("cd $dir ; $vcscmd -d $account\@$host:$path export $cvsopt -d $base $tmp1","Exporting $tmp1 from $source under CVS to $destdir ");
310} else {
311    die "cms $scheme unknown";
312}
313return(undef);
314}
315
316=item B<pb_cms_get_uri>
317
318This function is only called with a real CMS system and gives the URL stored in the checked out directory.
319The first parameter is the schema of the CMS systems (svn, cvs, svn+ssh, ...)
320The second parameter is the directory in which it is locally exposed (result of a checkout).
321
322=cut
323
324sub pb_cms_get_uri {
325
326my $scheme = shift;
327my $dir = shift;
328
329my $res = "";
330my $void = "";
331my $vcscmd = pb_cms_cmd($scheme);
332
333if ($scheme =~ /^svn/) {
334    open(PIPE,"LANGUAGE=C $vcscmd info $dir |") || return("");
335    while (<PIPE>) {
336        ($void,$res) = split(/^URL:/) if (/^URL:/);
337    }
338    $res =~ s/^\s*//;
339    close(PIPE);
340    chomp($res);
341} elsif ($scheme =~ /^svk/) {
342    open(PIPE,"LANGUAGE=C $vcscmd info $dir |") || return("");
343    my $void2 = "";
344    while (<PIPE>) {
345        ($void,$void2,$res) = split(/ /) if (/^Depot/);
346    }
347    $res =~ s/^\s*//;
348    close(PIPE);
349    chomp($res);
350} elsif ($scheme =~ /^hg/) {
351    open(HGRC,".hg/hgrc/") || return("");
352    while (<HGRC>) {
353        ($void,$res) = split(/^default.*=/) if (/^default.*=/);
354    }
355    close(HGRC);
356    chomp($res);
357} elsif ($scheme =~ /^git/) {
358    open(GITRC,".git/gitrc/") || return("");
359    while (<GITRC>) {
360        ($void,$res) = split(/^default.*=/) if (/^default.*=/);
361    }
362    close(GITRC);
363    chomp($res);
364} elsif ($scheme =~ /^cvs/) {
365    # This path is always the root path of CVS, but we may be below
366    open(FILE,"$dir/CVS/Root") || die "$dir isn't CVS controlled";
367    $res = <FILE>;
368    chomp($res);
369    close(FILE);
370    # Find where we are in the tree
371    my $rdir = $dir;
372    while ((! -d "$rdir/CVSROOT") && ($rdir ne "/")) {
373        $rdir = dirname($rdir);
374    }
375    die "Unable to find a CVSROOT dir in the parents of $dir" if (! -d "$rdir/CVSROOT");
376    #compute our place under that root dir - should be a relative path
377    $dir =~ s|^$rdir||;
378    my $suffix = "";
379    $suffix = "$dir" if ($dir ne "");
380
381    my $prefix = "";
382    if ($scheme =~ /ssh/) {
383        $prefix = "cvs+ssh://";
384    } else {
385        $prefix = "cvs://";
386    }
387    $res = $prefix.$res.$suffix;
388} else {
389    die "cms $scheme unknown";
390}
391pb_log(1,"pb_cms_get_uri returns $res\n");
392return($res);
393}
394
395=item B<pb_cms_copy>
396
397This function copies a CMS content to another.
398The first parameter is the schema of the CMS systems (svn, cvs, svn+ssh, ...)
399The second parameter is the URL of the original CMS content.
400The third parameter is the URL of the destination CMS content.
401
402Only coded for SVN now as used for pbconf itself not the project
403
404=cut
405
406sub pb_cms_copy {
407my $scheme = shift;
408my $oldurl = shift;
409my $newurl = shift;
410my $vcscmd = pb_cms_cmd($scheme);
411$oldurl = pb_cms_mod_socks($oldurl);
412$newurl = pb_cms_mod_socks($newurl);
413
414if ($scheme =~ /^svn/) {
415    $oldurl = pb_cms_mod_htftp($oldurl,"svn");
416    $newurl = pb_cms_mod_htftp($newurl,"svn");
417    pb_system("$vcscmd copy -m \"Creation of $newurl from $oldurl\" $oldurl $newurl","Copying $oldurl to $newurl ");
418} elsif (($scheme eq "flat") || ($scheme eq "ftp") || ($scheme eq "http"))   {
419} else {
420    die "cms $scheme unknown for project management";
421}
422}
423
424=item B<pb_cms_checkout>
425
426This function checks a CMS content out to a directory.
427The first parameter is the schema of the CMS systems (svn, cvs, svn+ssh, ...)
428The second parameter is the URL of the CMS content.
429The third parameter is the directory where we want to deliver it (result of export).
430
431=cut
432
433sub pb_cms_checkout {
434my $scheme = shift;
435my $url = shift;
436my $destination = shift;
437my $vcscmd = pb_cms_cmd($scheme);
438$url = pb_cms_mod_socks($url);
439
440if ($scheme =~ /^svn/) {
441    $url = pb_cms_mod_htftp($url,"svn");
442    pb_system("$vcscmd co $url $destination","Checking out $url to $destination ");
443} elsif ($scheme =~ /^svk/) {
444    $url = pb_cms_mod_htftp($url,"svk");
445    pb_system("$vcscmd co $url $destination","Checking out $url to $destination ");
446} elsif ($scheme =~ /^hg/) {
447    $url = pb_cms_mod_htftp($url,"hg");
448    pb_system("$vcscmd clone $url $destination","Checking out $url to $destination ");
449} elsif ($scheme =~ /^git/) {
450    $url = pb_cms_mod_htftp($url,"git");
451    pb_system("$vcscmd clone $url $destination","Checking out $url to $destination ");
452} elsif (($scheme eq "ftp") || ($scheme eq "http")) {
453    return;
454} elsif ($scheme =~ /^cvs/) {
455    my ($scheme, $account, $host, $port, $path) = pb_get_uri($url);
456
457    # If we're working on the CVS itself
458    my $cvstag = basename($ENV{'PBROOTDIR'});
459    my $cvsopt = "";
460    if ($cvstag eq "cvs") {
461        my @date = pb_get_date();
462        my $pbdate = strftime("%Y-%m-%d %H:%M:%S", @date);
463        $cvsopt = "-D \"$pbdate\"";
464    } else {
465        # we're working on a tag which should be the last part of PBROOTDIR
466        $cvsopt = "-r $cvstag";
467    }
468    pb_mkdir_p("$destination");
469    pb_system("cd $destination ; $vcscmd -d $account\@$host:$path co $cvsopt .","Checking out $url to $destination ");
470} elsif ($scheme =~ /^file/) {
471    pb_cms_export($url,undef,$destination);
472} else {
473    die "cms $scheme unknown";
474}
475}
476
477=item B<pb_cms_up>
478
479This function updates a local directory with the CMS content.
480The first parameter is the schema of the CMS systems (svn, cvs, svn+ssh, ...)
481The second parameter is the directory to update.
482
483=cut
484
485sub pb_cms_up {
486my $scheme = shift;
487my $dir = shift;
488my $vcscmd = pb_cms_cmd($scheme);
489
490if (($scheme =~ /^svn/) || ($scheme =~ /^cvs/) || ($scheme =~ /^svk/)) {
491    pb_system("$vcscmd up $dir","Updating $dir ");
492} elsif (($scheme eq "flat") || ($scheme eq "ftp") || ($scheme eq "http"))   {
493} else {
494    die "cms $scheme unknown";
495}
496}
497
498=item B<pb_cms_checkin>
499
500This function updates a CMS content from a local directory.
501The first parameter is the schema of the CMS systems (svn, cvs, svn+ssh, ...)
502The second parameter is the directory to update from.
503The third parameter indicates if we are in a new version creation (undef) or in a new project creation (1)
504
505=cut
506
507sub pb_cms_checkin {
508my $scheme = shift;
509my $dir = shift;
510my $pbinit = shift || undef;
511my $vcscmd = pb_cms_cmd($scheme);
512
513my $ver = basename($dir);
514my $msg = "updated to $ver";
515$msg = "Project $ENV{PBPROJ} creation" if (defined $pbinit);
516
517if (($scheme =~ /^svn/) || ($scheme =~ /^cvs/) || ($scheme =~ /^svk/)) {
518    pb_system("cd $dir ; $vcscmd ci -m \"$msg\" .","Checking in $dir ");
519} elsif (($scheme eq "flat") || ($scheme eq "ftp") || ($scheme eq "http"))   {
520} else {
521    die "cms $scheme unknown";
522}
523pb_cms_up($scheme,$dir);
524}
525
526=item B<pb_cms_add>
527
528This function adds to a CMS content from a local directory.
529The first parameter is the schema of the CMS systems (svn, cvs, svn+ssh, ...)
530The second parameter is the directory/file to add.
531
532=cut
533
534sub pb_cms_add {
535my $scheme = shift;
536my $f = shift;
537my $vcscmd = pb_cms_cmd($scheme);
538
539if (($scheme =~ /^svn/) || ($scheme =~ /^cvs/) || ($scheme =~ /^svk/)) {
540    pb_system("$vcscmd add $f","Adding $f to VCS ");
541} elsif (($scheme eq "flat") || ($scheme eq "ftp") || ($scheme eq "http"))   {
542} else {
543    die "cms $scheme unknown";
544}
545pb_cms_up($scheme,$f);
546}
547
548=item B<pb_cms_isdiff>
549
550This function returns a integer indicating the number f differences between the CMS content and the local directory where it's checked out.
551The first parameter is the schema of the CMS systems (svn, cvs, svn+ssh, ...)
552The second parameter is the directory to consider.
553
554=cut
555
556sub pb_cms_isdiff {
557my $scheme = shift;
558my $dir =shift;
559my $vcscmd = pb_cms_cmd($scheme);
560my $l = undef;
561
562if (($scheme =~ /^svn/) || ($scheme =~ /^cvs/) || ($scheme =~ /^svk/)) {
563    open(PIPE,"$vcscmd diff $dir |") || die "Unable to get $vcscmd diff from $dir";
564    $l = 0;
565    while (<PIPE>) {
566        # Skipping normal messages in case of CVS
567        next if (/^cvs diff:/);
568        $l++;
569    }
570} elsif (($scheme eq "flat") || ($scheme eq "ftp") || ($scheme eq "http"))   {
571    $l = 0;
572} else {
573    die "cms $scheme unknown";
574}
575pb_log(1,"pb_cms_isdiff returns $l\n");
576return($l);
577}
578
579=item B<pb_cms_get_pkg>
580
581This function returns the list of packages we are working on in a CMS action.
582The first parameter is the default list of packages from the configuration file.
583The second parameter is the optional list of packages from the configuration file.
584
585=cut
586
587sub pb_cms_get_pkg {
588
589my @pkgs = ();
590my $defpkgdir = shift || undef;
591my $extpkgdir = shift || undef;
592
593# Get packages list
594if (not defined $ARGV[0]) {
595    @pkgs = keys %$defpkgdir if (defined $defpkgdir);
596} elsif ($ARGV[0] =~ /^all$/) {
597    @pkgs = keys %$defpkgdir if (defined $defpkgdir);
598    push(@pkgs, keys %$extpkgdir) if (defined $extpkgdir);
599} else {
600    @pkgs = @ARGV;
601}
602pb_log(0,"Packages: ".join(',',@pkgs)."\n");
603return(\@pkgs);
604}
605
606=item B<pb_cms_get_real_pkg>
607
608This function returns the real name of a virtual package we are working on in a CMS action.
609It supports the following types: perl.
610The first parameter is the virtual package name
611
612=cut
613
614sub pb_cms_get_real_pkg {
615
616my $pbpkg = shift || undef;
617my $dtype = shift;
618my $pbpkgreal = $pbpkg;
619
620my @nametype = pb_conf_get_if("namingtype");
621my $type = $nametype[0]->{$pbpkg};
622if (defined $type) {
623    if ($type eq "perl") {
624        if ($dtype eq "rpm") {
625            $pbpkgreal = "perl-".$pbpkg;
626        } elsif ($dtype eq "deb") {
627            # Only lower case allowed in Debian
628            # Cf: http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Package
629            $pbpkgreal = "lib".lc($pbpkg)."-perl";
630        } elsif ($dtype eq "ebuild") {
631            $pbpkgreal = $pbpkg;
632        } elsif ($dtype eq "hpux") {
633            $pbpkgreal = $pbpkg;
634        } elsif ($dtype eq "pkg") {
635            $pbpkgreal = "PB$pbpkg";
636        } else {
637            die "pb_cms_get_real_pkg not implemented for $dtype yet";
638        }
639    } else {
640        die "nametype $type not implemented yet";
641    }
642}
643
644pb_log(1,"pb_cms_get_real_pkg returns $pbpkgreal\n");
645return($pbpkgreal);
646}
647
648=item B<pb_cms_compliant>
649
650This function checks the compliance of the project and the pbconf directory.
651The first parameter is the key name of the value that needs to be read in the configuration file.
652The second parameter is the environment variable this key will populate.
653The third parameter is the location of the pbconf dir.
654The fourth parameter is the URI of the CMS content related to the pbconf dir.
655The fifth parameter indicates whether we should inititate the context or not.
656
657=cut
658
659sub pb_cms_compliant {
660
661my $param = shift;
662my $envar = shift;
663my $defdir = shift;
664my $uri = shift;
665my $pbinit = shift;
666my %pdir;
667
668pb_log(1,"pb_cms_compliant: envar: $envar - defdir: $defdir - uri: $uri\n");
669my ($pdir) = pb_conf_get_if($param) if (defined $param);
670if (defined $pdir) {
671    %pdir = %$pdir;
672}
673
674
675if ((defined $pdir) && (%pdir) && (defined $pdir{$ENV{'PBPROJ'}})) {
676    # That's always the environment variable that will be used
677    $ENV{$envar} = $pdir{$ENV{'PBPROJ'}};
678} else {
679    if (defined $param) {
680        pb_log(1,"WARNING: no $param defined, using $defdir\n");
681        pb_log(1,"         Please create a $param reference for project $ENV{'PBPROJ'} in $ENV{'PBETC'}\n");
682        pb_log(1,"         if you want to use another directory\n");
683    }
684    $ENV{$envar} = "$defdir";
685}
686
687# Expand potential env variable in it
688eval { $ENV{$envar} =~ s/(\$ENV.+\})/$1/eeg };
689pb_log(2,"$envar: $ENV{$envar}\n");
690
691my ($scheme, $account, $host, $port, $path) = pb_get_uri($uri);
692
693if (($scheme !~ /^cvs/) && ($scheme !~ /^svn/) && ($scheme !~ /^svk/) && ($scheme !~ /^hg/) && ($scheme !~ /^git/)) {
694    # Do not compare if it's not a real cms
695    pb_log(1,"pb_cms_compliant useless\n");
696    return;
697} elsif (defined $pbinit) {
698    pb_mkdir_p("$ENV{$envar}");
699} elsif (! -d "$ENV{$envar}") {
700    # Either we have a version in the uri, and it should be the same
701    # as the one in the envar. Or we should add the version to the uri
702    if (basename($uri) ne basename($ENV{$envar})) {
703        $uri .= "/".basename($ENV{$envar})
704    }
705    pb_log(1,"Checking out $uri\n");
706    # Create structure and remove end dir before exporting
707    pb_mkdir_p("$ENV{$envar}");
708    pb_rm_rf($ENV{$envar});
709    pb_cms_checkout($scheme,$uri,$ENV{$envar});
710} else {
711    pb_log(1,"$uri found locally, checking content\n");
712    my $cmsurl = pb_cms_get_uri($scheme,$ENV{$envar});
713    my ($scheme2, $account2, $host2, $port2, $path2) = pb_get_uri($cmsurl);
714    # For svk, scheme doesn't appear in svk info so remove it here in uri coming from conf file
715    # which needs it to trigger correct behaviour
716    $uri =~ s/^svk://;
717    if (($scheme2 =~ /^git/) || ($scheme2 =~ /^hg/)) {
718        # These VCS manages branches internally not with different tree structures
719        # Assuming it's correct for now.
720    } elsif ($cmsurl ne $uri) {
721        # The local content doesn't correpond to the repository
722        pb_log(0,"ERROR: Inconsistency detected:\n");
723        pb_log(0,"       * $ENV{$envar} ($envar) refers to $cmsurl but\n");
724        pb_log(0,"       * $ENV{'PBETC'} refers to $uri\n");
725        die "Project $ENV{'PBPROJ'} is not Project-Builder compliant.";
726    } else {
727        pb_log(1,"Content correct - doing nothing - you may want to update your repository however\n");
728        # they match - do nothing - there may be local changes
729    }
730}
731pb_log(1,"pb_cms_compliant end\n");
732}
733
734=item B<pb_cms_create_authors>
735
736This function creates a AUTHORS files for the project. It call it AUTHORS.pb if an AUTHORS file already exists.
737The first parameter is the source file for authors information.
738The second parameter is the directory where to create the final AUTHORS file.
739The third parameter is the schema of the CMS systems (svn, cvs, svn+ssh, ...)
740
741=cut
742
743sub pb_cms_create_authors {
744
745my $authors=shift;
746my $dest=shift;
747my $scheme=shift;
748
749return if ($authors eq "/dev/null");
750open(SAUTH,$authors) || die "Unable to open $authors";
751# Save a potentially existing AUTHORS file and write instead to AUTHORS.pb
752my $ext = "";
753if (-f "$dest/AUTHORS") {
754    $ext = ".pb";
755}
756open(DAUTH,"> $dest/AUTHORS$ext") || die "Unable to create $dest/AUTHORS$ext";
757print DAUTH "Authors of the project are:\n";
758print DAUTH "===========================\n";
759while (<SAUTH>) {
760    my ($nick,$gcos) = split(/:/);
761    chomp($gcos);
762    print DAUTH "$gcos";
763    if (defined $scheme) {
764        # Do not give a scheme for flat types
765        my $endstr="";
766        if ("$ENV{'PBREVISION'}" ne "flat") {
767            $endstr = " under $scheme";
768        }
769        print DAUTH " ($nick$endstr)\n";
770    } else {
771        print DAUTH "\n";
772    }
773}
774close(DAUTH);
775close(SAUTH);
776}
777
778=item B<pb_cms_log>
779
780This function creates a ChangeLog file for the project.
781The first parameter is the schema of the CMS systems (svn, cvs, svn+ssh, ...)
782The second parameter is the directory where the CMS content was checked out.
783The third parameter is the directory where to create the final ChangeLog file.
784The fourth parameter is unused.
785The fifth parameter is the source file for authors information.
786
787It may use a tool like svn2cl or cvs2cl to generate it if present, or the log file from the CMS if not.
788
789=cut
790
791
792sub pb_cms_log {
793
794my $scheme = shift;
795my $pkgdir = shift;
796my $dest = shift;
797my $chglog = shift;
798my $authors = shift;
799my $testver = shift || undef;
800
801pb_cms_create_authors($authors,$dest,$scheme);
802my $vcscmd = pb_cms_cmd($scheme);
803
804if ((defined $testver) && (defined $testver->{$ENV{'PBPROJ'}}) && ($testver->{$ENV{'PBPROJ'}} =~ /true/i)) {
805    if (! -f "$dest/ChangeLog") {
806        open(CL,"> $dest/ChangeLog") || die "Unable to create $dest/ChangeLog";
807        # We need a minimal version for debian type of build
808        print CL "\n";
809        print CL "\n";
810        print CL "\n";
811        print CL "\n";
812        print CL "1990-01-01  none\n";
813        print CL "\n";
814        print CL "        * test version\n";
815        print CL "\n";
816        close(CL);
817        pb_log(0,"Generating fake ChangeLog for test version\n");
818        open(CL,"> $dest/$ENV{'PBCMSLOGFILE'}") || die "Unable to create $dest/$ENV{'PBCMSLOGFILE'}";
819        close(CL);
820    }
821}
822
823if (! -f "$dest/ChangeLog") {
824    if ($scheme =~ /^svn/) {
825        # In case we have no network, just create an empty one before to allow correct build
826        open(CL,"> $dest/ChangeLog") || die "Unable to create $dest/ChangeLog";
827        close(CL);
828        my $command = pb_check_req("svn2cl",1);
829        if ((defined $command) && (-x $command)) {
830            pb_system("$command --group-by-day --authors=$authors -i -o $dest/ChangeLog $pkgdir","Generating ChangeLog from SVN with svn2cl");
831        } else {
832            # To be written from pbcl
833            pb_system("$vcscmd log -v $pkgdir > $dest/$ENV{'PBCMSLOGFILE'}","Extracting log info from SVN");
834        }
835    } elsif ($scheme =~ /^svk/) {
836        pb_system("$vcscmd log -v $pkgdir > $dest/$ENV{'PBCMSLOGFILE'}","Extracting log info from SVK");
837    } elsif ($scheme =~ /^hg/) {
838        # In case we have no network, just create an empty one before to allow correct build
839        open(CL,"> $dest/ChangeLog") || die "Unable to create $dest/ChangeLog";
840        close(CL);
841        pb_system("$vcscmd log -v $pkgdir > $dest/$ENV{'PBCMSLOGFILE'}","Extracting log info from Mercurial");
842    } elsif ($scheme =~ /^git/) {
843        # In case we have no network, just create an empty one before to allow correct build
844        open(CL,"> $dest/ChangeLog") || die "Unable to create $dest/ChangeLog";
845        close(CL);
846        pb_system("$vcscmd log -v $pkgdir > $dest/$ENV{'PBCMSLOGFILE'}","Extracting log info from GIT");
847    } elsif (($scheme =~ /^file/) || ($scheme eq "dir") || ($scheme eq "http") || ($scheme eq "ftp")) {
848        pb_system("echo ChangeLog for $pkgdir > $dest/ChangeLog","Empty ChangeLog file created");
849    } elsif ($scheme =~ /^cvs/) {
850        my $tmp=basename($pkgdir);
851        # CVS needs a relative path !
852        # In case we have no network, just create an empty one before to allow correct build
853        open(CL,"> $dest/ChangeLog") || die "Unable to create $dest/ChangeLog";
854        close(CL);
855        my $command = pb_check_req("cvs2cl",1);
856        if (-x $command) {
857            pb_system("$command --group-by-day -U $authors -f $dest/ChangeLog $pkgdir","Generating ChangeLog from CVS with cvs2cl");
858        } else {
859            # To be written from pbcl
860            pb_system("$vcscmd log $tmp > $dest/$ENV{'PBCMSLOGFILE'}","Extracting log info from CVS");
861        }
862    } else {
863        die "cms $scheme unknown";
864    }
865}
866if (! -f "$dest/ChangeLog") {
867    copy("$dest/$ENV{'PBCMSLOGFILE'}","$dest/ChangeLog");
868}
869}
870
871sub pb_cms_mod_htftp {
872
873my $url = shift;
874my $proto = shift;
875
876$url =~ s/^$proto\+((ht|f)tp[s]*):/$1:/;
877pb_log(1,"pb_cms_mod_htftp returns $url\n");
878return($url);
879}
880
881sub pb_cms_mod_socks {
882
883my $url = shift;
884
885$url =~ s/^([A-z0-9]+)\+(socks):/$1:/;
886pb_log(1,"pb_cms_mod_socks returns $url\n");
887return($url);
888}
889
890
891sub pb_cms_cmd {
892
893my $scheme = shift;
894my $cmd = "";
895
896# If there is a socks proxy to use
897if ($scheme =~ /socks/) {
898    # Get the socks proxy command from the conf file
899    my ($pbsockscmd) = pb_conf_get("pbsockscmd");
900    $cmd = "$pbsockscmd->{$ENV{'PBPROJ'}} ";
901}
902
903if ($scheme =~ /hg/) {
904    return($cmd."hg")
905} elsif ($scheme =~ /git/) {
906    return($cmd."git")
907} elsif ($scheme =~ /svn/) {
908    return($cmd."svn")
909} elsif ($scheme =~ /svk/) {
910    return($cmd."svk")
911} elsif ($scheme =~ /cvs/) {
912    return($cmd."cvs")
913} elsif (($scheme =~ /http/) || ($scheme =~ /ftp/)) {
914    my $command = pb_check_req("wget",1);
915    if (-x $command) {
916        return($cmd."$command -nv -O ");
917    } else {
918        $command = pb_check_req("curl",1);
919        if (-x $command) {
920            return($cmd."$command -o ");
921        } else {
922            die "Unable to handle $scheme.\nNo wget/curl available, please install one of those";
923        }
924    }
925} else {
926    return($cmd);
927}
928}
929
930   
931
932=back
933
934=head1 WEB SITES
935
936The 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/>.
937
938=head1 USER MAILING LIST
939
940None exists for the moment.
941
942=head1 AUTHORS
943
944The Project-Builder.org team L<http://trac.project-builder.org/> lead by Bruno Cornec L<mailto:bruno@project-builder.org>.
945
946=head1 COPYRIGHT
947
948Project-Builder.org is distributed under the GPL v2.0 license
949described in the file C<COPYING> included with the distribution.
950
951=cut
952
9531;
Note: See TracBrowser for help on using the repository browser.