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

Last change on this file since 940 was 940, checked in by bruno, 10 years ago

Preliminary version of a Web site

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