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

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