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

Last change on this file since 1107 was 1107, checked in by Bruno Cornec, 10 years ago

r4032@localhost: bruno | 2010-11-08 15:51:53 +0100

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