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

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

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