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

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