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

Last change on this file since 1537 was 1537, checked in by bruno, 7 years ago
  • pb: Set pb_stop_on_error, add option to continue through errors. Add documentation of the newproj, cms2build and build2pkg steps. Only try to apply patches if the apply script exists. Warn if we would prune to the first listed VM rather than ignoring later ones silently. Only try to sign changes files if they exist, and only try to sign things if there is something to sign. (Eric Anderson)
  • CMS.pm: provide stack trace on error. (Eric Anderson)
File size: 14.8 KB
Line 
1#!/usr/bin/perl -w
2#
3# Project Builder CMS module
4# CMS subroutines brought by the the Project-Builder project
5# which can be easily used by pbinit scripts
6#
7# $Id$
8#
9# Copyright B. Cornec 2007
10# Provided under the GPL v2
11
12package ProjectBuilder::CMS;
13
14use strict 'vars';
15use Carp 'confess';
16use Data::Dumper;
17use English;
18use File::Basename;
19use File::Copy;
20use POSIX qw(strftime);
21use lib qw (lib);
22use ProjectBuilder::Version;
23use ProjectBuilder::Base;
24use ProjectBuilder::Conf;
25use ProjectBuilder::VCS;
26
27# Inherit from the "Exporter" module which handles exporting functions.
28 
29use vars qw($VERSION $REVISION @ISA @EXPORT);
30use Exporter;
31 
32# Export, by default, all the functions into the namespace of
33# any code which uses this module.
34 
35our @ISA = qw(Exporter);
36our @EXPORT = qw(pb_cms_init pb_cms_checkin pb_cms_get_pkg pb_cms_get_real_pkg pb_cms_compliant pb_cms_log);
37($VERSION,$REVISION) = pb_version_init();
38
39=pod
40
41=head1 NAME
42
43ProjectBuilder::CMS, part of the project-builder.org
44
45=head1 DESCRIPTION
46
47This modules provides configuration management system functions suitable for pbinit calls.
48
49=head1 USAGE
50
51=over 4
52
53=item B<pb_cms_init>
54
55This function setup the environment for the CMS system related to the URL given by the pburl configuration parameter.
56The potential parameter indicates whether we should inititate the context or not.
57It sets up environement variables (PBPROJDIR, PBDIR, PBREVISION, PBCMSLOGFILE)
58
59=cut
60
61sub pb_cms_init {
62
63my $pbinit = shift || undef;
64my $param = shift || undef;
65
66my ($pburl) = pb_conf_get("pburl");
67pb_log(2,"DEBUG: Project URL of $ENV{'PBPROJ'}: $pburl->{$ENV{'PBPROJ'}}\n");
68my ($scheme, $account, $host, $port, $path) = pb_get_uri($pburl->{$ENV{'PBPROJ'}});
69my $vcscmd = pb_vcs_cmd($scheme);
70
71my ($pbprojdir) = pb_conf_get_if("pbprojdir");
72
73if ((defined $pbprojdir) && (defined $pbprojdir->{$ENV{'PBPROJ'}})) {
74    $ENV{'PBPROJDIR'} = $pbprojdir->{$ENV{'PBPROJ'}};
75} else {
76    $ENV{'PBPROJDIR'} = "$ENV{'PBDEFDIR'}/$ENV{'PBPROJ'}";
77}
78# Expand potential env variable in it to allow string replacement
79eval { $ENV{'PBPROJDIR'} =~ s/(\$ENV.+\})/$1/eeg };
80
81
82# Computing the default dir for PBDIR.
83# what we have is PBPROJDIR so work from that.
84# Tree identical between PBCONFDIR and PBROOTDIR on one side and
85# PBPROJDIR and PBDIR on the other side.
86
87my $tmp = $ENV{'PBROOTDIR'};
88$tmp =~ s|^$ENV{'PBCONFDIR'}/||;
89
90#
91# Check project cms compliance
92#
93my $turl = "$pburl->{$ENV{'PBPROJ'}}/$tmp";
94$turl = $pburl->{$ENV{'PBPROJ'}} if (($scheme =~ /^file/) || ($scheme =~ /^(ht|f)tp/));
95pb_cms_compliant(undef,'PBDIR',"$ENV{'PBPROJDIR'}/$tmp",$turl,$pbinit);
96
97
98if ($scheme =~ /^hg/) {
99    $tmp = `(cd "$ENV{'PBDIR'}" ; $vcscmd identify )`;
100    chomp($tmp);
101    $tmp =~ s/^.* //;
102    $ENV{'PBREVISION'}=$tmp;
103    $ENV{'PBCMSLOGFILE'}="hg.log";
104} elsif ($scheme =~ /^git/) {
105    $tmp = `(cd "$ENV{'PBDIR'}" ; $vcscmd log | head -1 | cut -f2)`;
106    chomp($tmp);
107    $tmp =~ s/^.* //;
108    $ENV{'PBREVISION'}=$tmp;
109    $ENV{'PBCMSLOGFILE'}="git.log";
110} elsif (($scheme =~ /^file/) || ($scheme eq "ftp") || ($scheme eq "http")) {
111    $ENV{'PBREVISION'}="flat";
112    $ENV{'PBCMSLOGFILE'}="flat.log";
113} elsif ($scheme =~ /^svn/) {
114    # svnversion more precise than svn info if sbx
115    if ((defined $param) && ($param eq "CMS")) {
116        $tmp = `(LANGUAGE=C $vcscmd info $pburl->{$ENV{'PBPROJ'}} | grep -E '^Revision:' | cut -d: -f2)`;
117        $tmp =~ s/\s+//;
118    } else {
119        $tmp = `(cd "$ENV{'PBDIR'}" ; $vcscmd"version" .)`;
120    }
121    chomp($tmp);
122    $ENV{'PBREVISION'}=$tmp;
123    $ENV{'PBCMSLOGFILE'}="svn.log";
124} elsif ($scheme =~ /^svk/) {
125    $tmp = `(cd "$ENV{'PBDIR'}" ; LANGUAGE=C $vcscmd info . | grep -E '^Revision:' | cut -d: -f2)`;
126    $tmp =~ s/\s+//;
127    chomp($tmp);
128    $ENV{'PBREVISION'}=$tmp;
129    $ENV{'PBCMSLOGFILE'}="svk.log";
130} elsif ($scheme =~ /^cvs/) {
131    # Way too slow
132    #$ENV{'PBREVISION'}=`(cd "$ENV{'PBROOTDIR'}" ; cvs rannotate  -f . 2>&1 | awk '{print \$1}' | grep -E '^[0-9]' | cut -d. -f2 |sort -nu | tail -1)`;
133    #chomp($ENV{'PBREVISION'});
134    $ENV{'PBREVISION'}="cvs";
135    $ENV{'PBCMSLOGFILE'}="cvs.log";
136    $ENV{'CVS_RSH'} = "ssh" if ($scheme =~ /ssh/);
137} else {
138    die "cms $scheme unknown";
139}
140
141pb_log(1,"pb_cms_init returns $scheme,$pburl->{$ENV{'PBPROJ'}}\n");
142return($scheme,$pburl->{$ENV{'PBPROJ'}});
143}
144
145=item B<pb_cms_checkin>
146
147This function updates a CMS content from a local directory.
148The first parameter is the schema of the CMS systems (svn, cvs, svn+ssh, ...)
149The second parameter is the directory to update from.
150The third parameter indicates if we are in a new version creation (undef) or in a new project creation (1)
151
152=cut
153
154sub pb_cms_checkin {
155my $scheme = shift;
156my $dir = shift;
157my $pbinit = shift || undef;
158
159my $ver = basename($dir);
160my $msg = "updated to $ver";
161$msg = "Project $ENV{'PBPROJ'} creation" if (defined $pbinit);
162
163pb_vcs_checkin($scheme,$dir,$msg);
164}
165
166=item B<pb_cms_get_pkg>
167
168This function returns the list of packages we are working on in a CMS action.
169The first parameter is the default list of packages from the configuration file.
170The second parameter is the optional list of packages from the configuration file.
171
172=cut
173
174sub pb_cms_get_pkg {
175
176my @pkgs = ();
177my $defpkgdir = shift || undef;
178my $extpkgdir = shift || undef;
179
180# Get packages list
181if (not defined $ARGV[0]) {
182    @pkgs = keys %$defpkgdir if (defined $defpkgdir);
183} elsif ($ARGV[0] =~ /^all$/) {
184    @pkgs = keys %$defpkgdir if (defined $defpkgdir);
185    push(@pkgs, keys %$extpkgdir) if (defined $extpkgdir);
186} else {
187    @pkgs = @ARGV;
188}
189pb_log(0,"Packages: ".join(',',@pkgs)."\n");
190return(\@pkgs);
191}
192
193=item B<pb_cms_get_real_pkg>
194
195This function returns the real name of a virtual package we are working on in a CMS action.
196It supports the following types: perl.
197The first parameter is the virtual package name
198
199=cut
200
201sub pb_cms_get_real_pkg {
202
203my $pbpkg = shift || undef;
204my $dtype = shift;
205my $pbpkgreal = $pbpkg;
206
207my @nametype = pb_conf_get_if("namingtype");
208my $type = $nametype[0]->{$pbpkg};
209if (defined $type) {
210    if ($type eq "perl") {
211        if ($dtype eq "rpm") {
212            $pbpkgreal = "perl-".$pbpkg;
213        } elsif ($dtype eq "deb") {
214            # Only lower case allowed in Debian
215            # Cf: http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Package
216            $pbpkgreal = "lib".lc($pbpkg)."-perl";
217        } elsif ($dtype eq "ebuild") {
218            $pbpkgreal = $pbpkg;
219        } elsif ($dtype eq "hpux") {
220            $pbpkgreal = $pbpkg;
221        } elsif ($dtype eq "pkg") {
222            $pbpkgreal = "PB$pbpkg";
223        } else {
224            die "pb_cms_get_real_pkg not implemented for $dtype yet";
225        }
226    } else {
227        die "nametype $type not implemented yet";
228    }
229}
230
231pb_log(1,"pb_cms_get_real_pkg returns $pbpkgreal\n");
232return($pbpkgreal);
233}
234
235=item B<pb_cms_compliant>
236
237This function checks the compliance of the project and the pbconf directory.
238The first parameter is the key name of the value that needs to be read in the configuration file.
239The second parameter is the environment variable this key will populate.
240The third parameter is the location of the pbconf dir.
241The fourth parameter is the URI of the CMS content related to the pbconf dir.
242The fifth parameter indicates whether we should inititate the context or not.
243
244=cut
245
246sub pb_cms_compliant {
247
248my $param = shift;
249my $envar = shift;
250my $defdir = shift;
251my $uri = shift;
252my $pbinit = shift;
253my %pdir;
254
255pb_log(1,"pb_cms_compliant: envar: $envar - defdir: $defdir - uri: $uri\n");
256my ($pdir) = pb_conf_get_if($param) if (defined $param);
257if (defined $pdir) {
258    %pdir = %$pdir;
259}
260
261
262if ((defined $pdir) && (%pdir) && (defined $pdir{$ENV{'PBPROJ'}})) {
263    # That's always the environment variable that will be used
264    $ENV{$envar} = $pdir{$ENV{'PBPROJ'}};
265} else {
266    if (defined $param) {
267        pb_log(1,"WARNING: no $param defined, using $defdir\n");
268        pb_log(1,"         Please create a $param reference for project $ENV{'PBPROJ'} in $ENV{'PBETC'}\n");
269        pb_log(1,"         if you want to use another directory\n");
270    }
271    $ENV{$envar} = "$defdir";
272}
273
274# Expand potential env variable in it
275eval { $ENV{$envar} =~ s/(\$ENV.+\})/$1/eeg };
276pb_log(2,"$envar: $ENV{$envar}\n");
277
278my ($scheme, $account, $host, $port, $path) = pb_get_uri($uri);
279
280if (($scheme !~ /^cvs/) && ($scheme !~ /^svn/) && ($scheme !~ /^svk/) && ($scheme !~ /^hg/) && ($scheme !~ /^git/)) {
281    # Do not compare if it's not a real cms
282    pb_log(1,"pb_cms_compliant useless\n");
283    return;
284} elsif (defined $pbinit) {
285    pb_mkdir_p("$ENV{$envar}");
286} elsif (! -d "$ENV{$envar}") {
287    # Either we have a version in the uri, and it should be the same
288    # as the one in the envar. Or we should add the version to the uri
289    if (basename($uri) ne basename($ENV{$envar})) {
290        $uri .= "/".basename($ENV{$envar})
291    }
292    pb_log(1,"Checking out $uri\n");
293    # Create structure and remove end dir before exporting
294    pb_mkdir_p("$ENV{$envar}");
295    pb_rm_rf($ENV{$envar});
296    pb_vcs_checkout($scheme,$uri,$ENV{$envar});
297} else {
298    pb_log(1,"$uri found locally, checking content\n");
299    my $cmsurl = pb_vcs_get_uri($scheme,$ENV{$envar});
300    my ($scheme2, $account2, $host2, $port2, $path2) = pb_get_uri($cmsurl);
301    # For svk, scheme doesn't appear in svk info so remove it here in uri coming from conf file
302    # which needs it to trigger correct behaviour
303    $uri =~ s/^svk://;
304    if (($scheme2 =~ /^git/) || ($scheme2 =~ /^hg/)) {
305        # These VCS manage branches internally not with different tree structures
306        # Assuming it's correct for now.
307    } elsif ($cmsurl ne $uri) {
308        # The local content doesn't correpond to the repository
309        pb_log(0,"ERROR: Inconsistency detected:\n");
310        pb_log(0,"       * $ENV{$envar} ($envar) refers to $cmsurl but\n");
311        pb_log(0,"       * $ENV{'PBETC'} refers to $uri\n");
312        die "Project $ENV{'PBPROJ'} is not Project-Builder compliant.";
313    } else {
314        pb_log(1,"Content correct - doing nothing - you may want to update your repository however\n");
315        # they match - do nothing - there may be local changes
316    }
317}
318pb_log(1,"pb_cms_compliant end\n");
319}
320
321=item B<pb_cms_create_authors>
322
323This function creates a AUTHORS files for the project. It call it AUTHORS.pb if an AUTHORS file already exists.
324The first parameter is the source file for authors information.
325The second parameter is the directory where to create the final AUTHORS file.
326The third parameter is the schema of the CMS systems (svn, cvs, svn+ssh, ...)
327
328=cut
329
330sub pb_cms_create_authors {
331
332my $authors=shift;
333my $dest=shift;
334my $scheme=shift;
335
336return if ($authors eq "/dev/null");
337open(SAUTH,$authors) || die "Unable to open $authors";
338# Save a potentially existing AUTHORS file and write instead to AUTHORS.pb
339my $ext = "";
340if (-f "$dest/AUTHORS") {
341    $ext = ".pb";
342}
343open(DAUTH,"> $dest/AUTHORS$ext") || die "Unable to create $dest/AUTHORS$ext";
344print DAUTH "Authors of the project are:\n";
345print DAUTH "===========================\n";
346while (<SAUTH>) {
347    my ($nick,$gcos) = split(/:/);
348    chomp($gcos);
349    print DAUTH "$gcos";
350    if (defined $scheme) {
351        # Do not give a scheme for flat types
352        my $endstr="";
353        if ("$ENV{'PBREVISION'}" ne "flat") {
354            $endstr = " under $scheme";
355        }
356        print DAUTH " ($nick$endstr)\n";
357    } else {
358        print DAUTH "\n";
359    }
360}
361close(DAUTH);
362close(SAUTH);
363}
364
365=item B<pb_cms_log>
366
367This function creates a ChangeLog file for the project.
368The first parameter is the schema of the CMS systems (svn, cvs, svn+ssh, ...)
369The second parameter is the directory where the CMS content was checked out.
370The third parameter is the directory where to create the final ChangeLog file.
371The fourth parameter is unused.
372The fifth parameter is the source file for authors information.
373
374It may use a tool like svn2cl or cvs2cl to generate it if present, or the log file from the CMS if not.
375
376=cut
377
378
379sub pb_cms_log {
380
381my $scheme = shift;
382my $pkgdir = shift;
383my $dest = shift;
384my $chglog = shift;
385my $authors = shift;
386my $testver = shift || undef;
387
388pb_cms_create_authors($authors,$dest,$scheme);
389my $vcscmd = pb_vcs_cmd($scheme);
390
391if ((defined $testver) && (defined $testver->{$ENV{'PBPROJ'}}) && ($testver->{$ENV{'PBPROJ'}} =~ /true/i)) {
392    if (! -f "$dest/ChangeLog") {
393        open(CL,"> $dest/ChangeLog") || confess "Unable to create $dest/ChangeLog";
394        # We need a minimal version for debian type of build
395        print CL "\n";
396        print CL "\n";
397        print CL "\n";
398        print CL "\n";
399        print CL "1990-01-01  none\n";
400        print CL "\n";
401        print CL "        * test version\n";
402        print CL "\n";
403        close(CL);
404        pb_log(0,"Generating fake ChangeLog for test version\n");
405        open(CL,"> $dest/$ENV{'PBCMSLOGFILE'}") || die "Unable to create $dest/$ENV{'PBCMSLOGFILE'}";
406        close(CL);
407    }
408}
409
410if (! -f "$dest/ChangeLog") {
411    if ($scheme =~ /^svn/) {
412        # In case we have no network, just create an empty one before to allow correct build
413        open(CL,"> $dest/ChangeLog") || die "Unable to create $dest/ChangeLog";
414        close(CL);
415        my $command = pb_check_req("svn2cl",1);
416        if ((defined $command) && (-x $command)) {
417            pb_system("$command --group-by-day --authors=$authors -i -o $dest/ChangeLog $pkgdir","Generating ChangeLog from SVN with svn2cl");
418        } else {
419            # To be written from pbcl
420            pb_system("$vcscmd log -v $pkgdir > $dest/$ENV{'PBCMSLOGFILE'}","Extracting log info from SVN");
421        }
422    } elsif ($scheme =~ /^svk/) {
423        pb_system("$vcscmd log -v $pkgdir > $dest/$ENV{'PBCMSLOGFILE'}","Extracting log info from SVK");
424    } elsif ($scheme =~ /^hg/) {
425        # In case we have no network, just create an empty one before to allow correct build
426        open(CL,"> $dest/ChangeLog") || die "Unable to create $dest/ChangeLog";
427        close(CL);
428        pb_system("$vcscmd log -v $pkgdir > $dest/$ENV{'PBCMSLOGFILE'}","Extracting log info from Mercurial");
429    } elsif ($scheme =~ /^git/) {
430        # In case we have no network, just create an empty one before to allow correct build
431        open(CL,"> $dest/ChangeLog") || die "Unable to create $dest/ChangeLog";
432        close(CL);
433        pb_system("$vcscmd log -v $pkgdir > $dest/$ENV{'PBCMSLOGFILE'}","Extracting log info from GIT");
434    } elsif (($scheme =~ /^file/) || ($scheme eq "dir") || ($scheme eq "http") || ($scheme eq "ftp")) {
435        pb_system("echo ChangeLog for $pkgdir > $dest/ChangeLog","Empty ChangeLog file created");
436    } elsif ($scheme =~ /^cvs/) {
437        my $tmp=basename($pkgdir);
438        # CVS needs a relative path !
439        # In case we have no network, just create an empty one before to allow correct build
440        open(CL,"> $dest/ChangeLog") || die "Unable to create $dest/ChangeLog";
441        close(CL);
442        my $command = pb_check_req("cvs2cl",1);
443        if (-x $command) {
444            pb_system("$command --group-by-day -U $authors -f $dest/ChangeLog $pkgdir","Generating ChangeLog from CVS with cvs2cl");
445        } else {
446            # To be written from pbcl
447            pb_system("$vcscmd log $tmp > $dest/$ENV{'PBCMSLOGFILE'}","Extracting log info from CVS");
448        }
449    } else {
450        die "cms $scheme unknown";
451    }
452}
453if (! -f "$dest/ChangeLog") {
454    copy("$dest/$ENV{'PBCMSLOGFILE'}","$dest/ChangeLog");
455}
456}
457
458=back
459
460=head1 WEB SITES
461
462The 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/>.
463
464=head1 USER MAILING LIST
465
466None exists for the moment.
467
468=head1 AUTHORS
469
470The Project-Builder.org team L<http://trac.project-builder.org/> lead by Bruno Cornec L<mailto:bruno@project-builder.org>.
471
472=head1 COPYRIGHT
473
474Project-Builder.org is distributed under the GPL v2.0 license
475described in the file C<COPYING> included with the distribution.
476
477=cut
478
4791;
Note: See TracBrowser for help on using the repository browser.