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

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

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