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

Last change on this file since 1173 was 1173, checked in by Bruno Cornec, 9 years ago

-Add somr structure creation in case we start from nothing and fix display for deb pkg generation

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