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

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