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

Revision 873, 26.9 KB checked in by bruno, 4 years ago (diff)

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