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

Last change on this file since 2284 was 2284, checked in by Bruno Cornec, 7 years ago

Now uses pbprojurl instead of pburl to be consistent with pbconfurl
File size: 11.5 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-2016
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_get_pkg pb_cms_get_real_pkg 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 pbprojurl 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;
65my $param = shift;
66
67my ($pbprojurl) = pb_conf_get("pbprojurl");
68pb_log(2,"DEBUG: Project URL of $ENV{'PBPROJ'}: $pbprojurl->{$ENV{'PBPROJ'}}\n");
69my ($scheme, $account, $host, $port, $path) = pb_get_uri($pbprojurl->{$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# If no subdir, then replace again
91$tmp =~ s|^$ENV{'PBCONFDIR'}||;
92
93#
94# Check project cms compliance
95#
96my $turl = "$pbprojurl->{$ENV{'PBPROJ'}}/$tmp";
97$turl = $pbprojurl->{$ENV{'PBPROJ'}} if ($scheme =~ /^(flat)|(ftp)|(http)|(https)|(file)|(git)\b/o);
98# git svn is like svn
99$turl = "$pbprojurl->{$ENV{'PBPROJ'}}/$tmp" if ($scheme =~ /^git\+svn/o);
100pb_vcs_compliant(undef,'PBDIR',"$ENV{'PBPROJDIR'}/$tmp",$turl,$pbinit);
101
102
103if ($scheme =~ /^hg/) {
104 $tmp = `(cd "$ENV{'PBDIR'}" ; $vcscmd identify )`;
105 chomp($tmp);
106 $tmp =~ s/^.* //;
107 $ENV{'PBREVISION'}=$tmp;
108 $ENV{'PBCMSLOGFILE'}="hg.log";
109} elsif ($scheme =~ /^git/) {
110 if ($scheme =~ /svn/) {
111 $tmp = `(cd "$ENV{'PBDIR'}" ; LANGUAGE=C $vcscmd info | grep -E '^Revision:' | cut -d: -f2)`;
112 $tmp =~ s/\s+//;
113 } else {
114 $tmp = `(cd "$ENV{'PBDIR'}" ; $vcscmd log | head -1 | cut -f2)`;
115 $tmp =~ s/^.* //;
116 # Reduce length of commit id to 8 digit
117 $tmp = substr($tmp,1,8);
118 }
119 chomp($tmp);
120 $ENV{'PBREVISION'}=$tmp;
121 $ENV{'PBCMSLOGFILE'}="git.log";
122} elsif ($scheme =~ /^(flat)|(ftp)|(http)|(https)|(file)\b/o) {
123 $ENV{'PBREVISION'}="flat";
124 $ENV{'PBCMSLOGFILE'}="flat.log";
125} elsif ($scheme =~ /^svn/) {
126 # svnversion more precise than svn info if sbx
127 if ((defined $param) && ($param eq "CMS")) {
128 $tmp = `(LANGUAGE=C $vcscmd info $pbprojurl->{$ENV{'PBPROJ'}} | grep -E '^Revision:' | cut -d: -f2)`;
129 $tmp =~ s/\s+//;
130 } else {
131 $tmp = `(cd "$ENV{'PBDIR'}" ; $vcscmd"version" .)`;
132 }
133 chomp($tmp);
134 $ENV{'PBREVISION'}=$tmp;
135 $ENV{'PBCMSLOGFILE'}="svn.log";
136} elsif ($scheme =~ /^svk/) {
137 $tmp = `(cd "$ENV{'PBDIR'}" ; LANGUAGE=C $vcscmd info . | grep -E '^Revision:' | cut -d: -f2)`;
138 $tmp =~ s/\s+//;
139 chomp($tmp);
140 $ENV{'PBREVISION'}=$tmp;
141 $ENV{'PBCMSLOGFILE'}="svk.log";
142} elsif ($scheme =~ /^cvs/) {
143 # Way too slow
144 #$ENV{'PBREVISION'}=`(cd "$ENV{'PBROOTDIR'}" ; cvs rannotate -f . 2>&1 | awk '{print \$1}' | grep -E '^[0-9]' | cut -d. -f2 |sort -nu | tail -1)`;
145 #chomp($ENV{'PBREVISION'});
146 $ENV{'PBREVISION'}="cvs";
147 $ENV{'PBCMSLOGFILE'}="cvs.log";
148 $ENV{'CVS_RSH'} = "ssh" if ($scheme =~ /ssh/);
149} else {
150 die "cms $scheme unknown";
151}
152
153pb_log(1,"pb_cms_init returns $scheme,$pburl->{$ENV{'PBPROJ'}}\n");
154return($scheme,$pburl->{$ENV{'PBPROJ'}});
155}
156
157=item B<pb_cms_get_pkg>
158
159This function returns the list of packages we are working on in a CMS action.
160The first parameter is the default list of packages from the configuration file.
161The second parameter is the optional list of packages from the configuration file.
162
163=cut
164
165sub pb_cms_get_pkg {
166
167my @pkgs = ();
168my $defpkgdir = shift;
169my $extpkgdir = shift;
170
171# Get packages list
172if (not defined $ARGV[0]) {
173 @pkgs = keys %$defpkgdir if (defined $defpkgdir);
174} elsif ($ARGV[0] =~ /^all$/) {
175 @pkgs = keys %$defpkgdir if (defined $defpkgdir);
176 push(@pkgs, keys %$extpkgdir) if (defined $extpkgdir);
177} else {
178 @pkgs = @ARGV;
179}
180pb_log(0,"Packages: ".join(',',@pkgs)."\n");
181return(\@pkgs);
182}
183
184=item B<pb_cms_get_real_pkg>
185
186This function returns the real name of a virtual package we are working on in a CMS action.
187It supports the following types: perl.
188The first parameter is the virtual package name
189
190=cut
191
192sub pb_cms_get_real_pkg {
193
194my $pbpkg = shift;
195my $dtype = shift;
196my $pbpkgreal = $pbpkg;
197
198my @nametype = pb_conf_get_if("namingtype");
199my $type = $nametype[0]->{$pbpkg};
200if (defined $type) {
201 if ($type eq "perl") {
202 if ($dtype eq "rpm") {
203 $pbpkgreal = "perl-".$pbpkg;
204 } elsif ($dtype eq "deb") {
205 # Only lower case allowed in Debian
206 # Cf: http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Package
207 $pbpkgreal = "lib".lc($pbpkg)."-perl";
208 } elsif ($dtype eq "ebuild") {
209 $pbpkgreal = $pbpkg;
210 } elsif ($dtype eq "hpux") {
211 $pbpkgreal = $pbpkg;
212 } elsif ($dtype eq "pkg") {
213 $pbpkgreal = "PB$pbpkg";
214 } else {
215 die "pb_cms_get_real_pkg not implemented for $dtype yet";
216 }
217 } else {
218 die "nametype $type not implemented yet";
219 }
220}
221
222pb_log(2,"pb_cms_get_real_pkg returns $pbpkgreal\n");
223return($pbpkgreal);
224}
225
226=item B<pb_cms_create_authors>
227
228This function creates a AUTHORS files for the project. It call it AUTHORS.pb if an AUTHORS file already exists.
229The first parameter is the source file for authors information.
230The second parameter is the directory where to create the final AUTHORS file.
231The third parameter is the schema of the CMS systems (svn, cvs, svn+ssh, ...)
232
233=cut
234
235sub pb_cms_create_authors {
236
237my $authors=shift;
238my $dest=shift;
239my $scheme=shift;
240
241return if ($authors eq "/dev/null");
242open(SAUTH,$authors) || die "Unable to open $authors";
243# Save a potentially existing AUTHORS file and write instead to AUTHORS.pb
244my $ext = "";
245if (-f "$dest/AUTHORS") {
246 $ext = ".pb";
247}
248open(DAUTH,"> $dest/AUTHORS$ext") || die "Unable to create $dest/AUTHORS$ext";
249print DAUTH "Authors of the project are:\n";
250print DAUTH "===========================\n";
251while (<SAUTH>) {
252 my ($nick,$gcos) = split(/:/);
253 chomp($gcos);
254 print DAUTH "$gcos";
255 if (defined $scheme) {
256 # Do not give a scheme for flat types
257 my $endstr="";
258 if ("$ENV{'PBREVISION'}" ne "flat") {
259 $endstr = " under $scheme";
260 }
261 print DAUTH " ($nick$endstr)\n";
262 } else {
263 print DAUTH "\n";
264 }
265}
266close(DAUTH);
267close(SAUTH);
268}
269
270=item B<pb_cms_log>
271
272This function creates a ChangeLog file for the project.
273The first parameter is the schema of the CMS systems (svn, cvs, svn+ssh, ...)
274The second parameter is the directory where the CMS content was checked out.
275The third parameter is the directory where to create the final ChangeLog file.
276The fourth parameter is unused.
277The fifth parameter is the source file for authors information.
278
279It may use a tool like svn2cl or cvs2cl to generate it if present, or the log file from the CMS if not.
280
281=cut
282
283
284sub pb_cms_log {
285
286my $scheme = shift;
287my $pkgdir = shift;
288my $dest = shift;
289my $chglog = shift;
290my $authors = shift;
291my $testver = shift;
292
293pb_cms_create_authors($authors,$dest,$scheme);
294my $vcscmd = pb_vcs_cmd($scheme);
295
296if ((defined $testver) && (defined $testver->{$ENV{'PBPROJ'}}) && ($testver->{$ENV{'PBPROJ'}} =~ /true/i)) {
297 if (! -f "$dest/ChangeLog") {
298 open(CL,"> $dest/ChangeLog") || confess "Unable to create $dest/ChangeLog";
299 # We need a minimal version for debian type of build
300 print CL "\n";
301 print CL "\n";
302 print CL "\n";
303 print CL "\n";
304 print CL "1990-01-01 none\n";
305 print CL "\n";
306 print CL " * test version\n";
307 print CL "\n";
308 close(CL);
309 pb_log(0,"Generating fake ChangeLog for test version\n");
310 open(CL,"> $dest/$ENV{'PBCMSLOGFILE'}") || die "Unable to create $dest/$ENV{'PBCMSLOGFILE'}";
311 close(CL);
312 }
313}
314
315if (! -f "$dest/ChangeLog") {
316 if ($scheme =~ /^svn/) {
317 # In case we have no network, just create an empty one before to allow correct build
318 open(CL,"> $dest/ChangeLog") || die "Unable to create $dest/ChangeLog";
319 close(CL);
320 my $command = pb_check_req("svn2cl",1);
321 if ((defined $command) && (-x $command)) {
322 pb_system("$command --group-by-day --authors=$authors -i -o $dest/ChangeLog $pkgdir","Generating ChangeLog from SVN with svn2cl");
323 } else {
324 # To be written from pbcl
325 pb_system("$vcscmd log -v $pkgdir > $dest/$ENV{'PBCMSLOGFILE'}","Extracting log info from SVN");
326 }
327 } elsif ($scheme =~ /^svk/) {
328 pb_system("$vcscmd log -v $pkgdir > $dest/$ENV{'PBCMSLOGFILE'}","Extracting log info from SVK");
329 } elsif ($scheme =~ /^hg/) {
330 # In case we have no network, just create an empty one before to allow correct build
331 open(CL,"> $dest/ChangeLog") || die "Unable to create $dest/ChangeLog";
332 close(CL);
333 pb_system("$vcscmd log -v $pkgdir > $dest/$ENV{'PBCMSLOGFILE'}","Extracting log info from Mercurial");
334 } elsif ($scheme =~ /^git/) {
335 # In case we have no network, just create an empty one before to allow correct build
336 open(CL,"> $dest/ChangeLog") || die "Unable to create $dest/ChangeLog";
337 close(CL);
338 pb_system("$vcscmd log -v $pkgdir > $dest/$ENV{'PBCMSLOGFILE'}","Extracting log info from GIT");
339 } elsif ($scheme =~ /^(flat)|(ftp)|(http)|(https)|(file)|(dir)\b/o) {
340 pb_system("echo ChangeLog for $pkgdir > $dest/ChangeLog","Empty ChangeLog file created");
341 } elsif ($scheme =~ /^cvs/) {
342 my $tmp=basename($pkgdir);
343 # CVS needs a relative path !
344 # In case we have no network, just create an empty one before to allow correct build
345 open(CL,"> $dest/ChangeLog") || die "Unable to create $dest/ChangeLog";
346 close(CL);
347 my $command = pb_check_req("cvs2cl",1);
348 if (-x $command) {
349 pb_system("$command --group-by-day -U $authors -f $dest/ChangeLog $pkgdir","Generating ChangeLog from CVS with cvs2cl");
350 } else {
351 # To be written from pbcl
352 pb_system("$vcscmd log $tmp > $dest/$ENV{'PBCMSLOGFILE'}","Extracting log info from CVS");
353 }
354 } else {
355 die "cms $scheme unknown";
356 }
357}
358if (! -f "$dest/ChangeLog") {
359 copy("$dest/$ENV{'PBCMSLOGFILE'}","$dest/ChangeLog");
360}
361}
362
363=back
364
365=head1 WEB SITES
366
367The 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/>.
368
369=head1 USER MAILING LIST
370
371None exists for the moment.
372
373=head1 AUTHORS
374
375The Project-Builder.org team L<http://trac.project-builder.org/> lead by Bruno Cornec L<mailto:bruno@project-builder.org>.
376
377=head1 COPYRIGHT
378
379Project-Builder.org is distributed under the GPL v2.0 license
380described in the file C<COPYING> included with the distribution.
381
382=cut
383
3841;
Note: See TracBrowser for help on using the repository browser.