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

Last change on this file since 1495 was 1495, checked in by bruno, 7 years ago

r4735@localhost: bruno | 2012-05-07 03:46:39 +0200

  • Conf.pm largely rewritten to cache all conf files into a local $h hash in which conf files are added in reverse order.

The new pb_conf_hash stores a configuration file into a hash structure passed in parameter.
pb_conf_add now triggers the computation of the hash structure with pb_conf_cache and adds it to the main $h hash.
pb_conf_read_if now just uses the content in the $h hash to return its table.
pb_conf_get_in_hash_if function added to do the same as pb_conf_read_if on the cached $h hash instead of a configuration file.
pb_conf_get_if now uses pb_conf_get_in_hash_if and the $h hash without re-reading conf files
pb_conf_add_last_in_hash adds the content of a hash behind the content of the $h main hash (was done in pb_conf_get before)
pb_env_init now calls pb_conf_init to have PBPROJ defined when needed.
pb seems to work with this new version (builds itself)

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