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

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