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

Last change on this file since 600 was 600, checked in by Bruno Cornec, 16 years ago

Adds pb_cms_mod_svn_http function to support fossology https svn checkout with svn+https syntax in URLs

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