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

Revision 405, 12.9 KB checked in by bruno, 5 years ago (diff)

Split again function in modules to allow for usage with pbinit and easier reuse.
  • Property svn:executable set to *
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 POSIX qw(strftime);
19use lib qw (lib);
20use ProjectBuilder::Base;
21use ProjectBuilder::Conf;
22
23# Inherit from the "Exporter" module which handles exporting functions.
24 
25use Exporter;
26 
27# Export, by default, all the functions into the namespace of
28# any code which uses this module.
29 
30our @ISA = qw(Exporter);
31our @EXPORT = qw(pb_cms_init pb_cms_export pb_cms_get_uri pb_cms_copy pb_cms_checkout pb_cms_up pb_cms_checkin pb_cms_isdiff pb_cms_get_pkg pb_cms_compliant pb_cms_log pb_cms_create_authors);
32
33=pod
34
35=head1 NAME
36
37ProjectBuilder::CMS, part of the project-builder.org - module dealing with configuration management system functions suitable for pbinit calls.
38
39=head1 DESCRIPTION
40
41This modules provides configuration management system functions suitable for pbinit calls.
42
43=cut
44
45# Setup environment for CMS system for URL passed
46sub pb_cms_init {
47
48my $pbinit = shift || undef;
49
50my ($pburl) = pb_conf_get("pburl");
51pb_log(2,"DEBUG: Project URL of $ENV{'PBPROJ'}: $pburl->{$ENV{'PBPROJ'}}\n");
52my ($scheme, $account, $host, $port, $path) = pb_get_uri($pburl->{$ENV{'PBPROJ'}});
53
54my ($pbprojdir) = pb_conf_get_if("pbprojdir");
55
56if ((defined $pbprojdir) && (defined $pbprojdir->{$ENV{'PBPROJ'}})) {
57        $ENV{'PBPROJDIR'} = $pbprojdir->{$ENV{'PBPROJ'}};
58} else {
59        $ENV{'PBPROJDIR'} = "$ENV{'PBDEFDIR'}/$ENV{'PBPROJ'}";
60}
61
62# Computing the default dir for PBDIR.
63# what we have is PBPROJDIR so work from that.
64# Tree identical between PBCONFDIR and PBROOTDIR on one side and
65# PBPROJDIR and PBDIR on the other side.
66
67my $tmp = $ENV{'PBROOTDIR'};
68$tmp =~ s|^$ENV{'PBCONFDIR'}||;
69
70#
71# Check project cms compliance
72#
73pb_cms_compliant(undef,'PBDIR',"$ENV{'PBPROJDIR'}/$tmp",$pburl->{$ENV{'PBPROJ'}},$pbinit);
74
75if ($scheme =~ /^svn/) {
76        # svnversion more precise than svn info
77        $tmp = `(cd "$ENV{'PBDIR'}" ; svnversion .)`;
78        chomp($tmp);
79        $ENV{'PBREVISION'}=$tmp;
80        $ENV{'PBCMSLOGFILE'}="svn.log";
81} elsif (($scheme eq "file") || ($scheme eq "ftp") || ($scheme eq "http")) {
82        $ENV{'PBREVISION'}="flat";
83        $ENV{'PBCMSLOGFILE'}="flat.log";
84} elsif ($scheme =~ /^cvs/) {
85        # Way too slow
86        #$ENV{'PBREVISION'}=`(cd "$ENV{'PBROOTDIR'}" ; cvs rannotate  -f . 2>&1 | awk '{print \$1}' | grep -E '^[0-9]' | cut -d. -f2 |sort -nu | tail -1)`;
87        #chomp($ENV{'PBREVISION'});
88        $ENV{'PBREVISION'}="cvs";
89        $ENV{'PBCMSLOGFILE'}="cvs.log";
90        $ENV{'CVS_RSH'} = "ssh" if ($scheme =~ /ssh/);
91} else {
92        die "cms $scheme unknown";
93}
94
95return($scheme,$pburl->{$ENV{'PBPROJ'}});
96}
97
98sub pb_cms_export {
99
100my $uri = shift;
101my $source = shift;
102my $destdir = shift;
103my $tmp;
104my $tmp1;
105
106my @date = pb_get_date();
107# If it's not flat, then we have a real uri as source
108my ($scheme, $account, $host, $port, $path) = pb_get_uri($uri);
109
110if ($scheme =~ /^svn/) {
111        if (-d $source) {
112                $tmp = $destdir;
113        } else {
114                $tmp = "$destdir/".basename($source);
115        }
116        pb_system("svn export $source $tmp","Exporting $source from SVN to $tmp");
117} elsif ($scheme eq "dir") {
118        pb_system("cp -a $path $destdir","Copying $uri from DIR to $destdir");
119} elsif (($scheme eq "http") || ($scheme eq "ftp")) {
120        my $f = basename($path);
121        unlink "$ENV{'PBTMP'}/$f";
122        if (-x "/usr/bin/wget") {
123                pb_system("/usr/bin/wget -nv -O $ENV{'PBTMP'}/$f $uri"," ");
124        } elsif (-x "/usr/bin/curl") {
125                pb_system("/usr/bin/curl $uri -o $ENV{'PBTMP'}/$f","Downloading $uri with curl to $ENV{'PBTMP'}/$f\n");
126        } else {
127                die "Unable to download $uri.\nNo wget/curl available, please install one of those";
128        }
129        pb_cms_export("file://$ENV{'PBTMP'}/$f",$source,$destdir);
130} elsif ($scheme eq "file") {
131        use File::MimeInfo; 
132        my $mm = mimetype($path);
133        pb_log(2,"mimetype: $mm\n");
134        pb_mkdir_p($destdir);
135
136        # Check whether the file is well formed
137        # (containing already a directory with the project-version name)
138        my ($pbwf) = pb_conf_get_if("pbwf");
139        if ((defined $pbwf) && (defined $pbwf->{$ENV{'PBPROJ'}})) {
140                $destdir = dirname($destdir);
141        }
142
143        if ($mm =~ /\/x-bzip-compressed-tar$/) {
144                # tar+bzip2
145                pb_system("cd $destdir ; tar xfj $path","Extracting $path in $destdir");
146        } elsif ($mm =~ /\/x-lzma-compressed-tar$/) {
147                # tar+lzma
148                pb_system("cd $destdir ; tar xfY $path","Extracting $path in $destdir");
149        } elsif ($mm =~ /\/x-compressed-tar$/) {
150                # tar+gzip
151                pb_system("cd $destdir ; tar xfz $path","Extracting $path in $destdir");
152        } elsif ($mm =~ /\/x-tar$/) {
153                # tar
154                pb_system("cd $destdir ; tar xf $path","Extracting $path in $destdir");
155        } elsif ($mm =~ /\/zip$/) {
156                # zip
157                pb_system("cd $destdir ; unzip $path","Extracting $path in $destdir");
158        }
159} elsif ($scheme =~ /^cvs/) {
160        # CVS needs a relative path !
161        my $dir=dirname($destdir);
162        my $base=basename($destdir);
163        # CVS also needs a modules name not a dir
164        #if (-d $source) {
165                $tmp1 = basename($source);
166                #} else {
167                #$tmp1 = dirname($source);
168                #$tmp1 = basename($tmp1);
169                #}
170        my $optcvs = "";
171
172        # If we're working on the CVS itself
173        my $cvstag = basename($ENV{'PBROOTDIR'});
174        my $cvsopt = "";
175        if ($cvstag eq "cvs") {
176                my $pbdate = strftime("%Y-%m-%d %H:%M:%S", @date);
177                $cvsopt = "-D \"$pbdate\"";
178        } else {
179                # we're working on a tag which should be the last part of PBROOTDIR
180                $cvsopt = "-r $cvstag";
181        }
182        pb_system("cd $dir ; cvs -d $account\@$host:$path export $cvsopt -d $base $tmp1","Exporting $tmp1 from $source under CVS to $destdir");
183} else {
184        die "cms $scheme unknown";
185}
186}
187
188# This function is only called with a real CMS system
189sub pb_cms_get_uri {
190
191my $scheme = shift;
192my $dir = shift;
193
194my $res = "";
195my $void = "";
196
197if ($scheme =~ /^svn/) {
198        open(PIPE,"LANGUAGE=C svn info $dir |") || return("");
199        while (<PIPE>) {
200                ($void,$res) = split(/^URL:/) if (/^URL:/);
201        }
202        $res =~ s/^\s*//;
203        close(PIPE);
204        chomp($res);
205} elsif ($scheme =~ /^cvs/) {
206        # This path is always the root path of CVS, but we may be below
207        open(FILE,"$dir/CVS/Root") || die "$dir isn't CVS controlled";
208        $res = <FILE>;
209        chomp($res);
210        close(FILE);
211        # Find where we are in the tree
212        my $rdir = $dir;
213        while ((! -d "$rdir/CVSROOT") && ($rdir ne "/")) {
214                $rdir = dirname($rdir);
215        }
216        die "Unable to find a CVSROOT dir in the parents of $dir" if (! -d "$rdir/CVSROOT");
217        #compute our place under that root dir - should be a relative path
218        $dir =~ s|^$rdir||;
219        my $suffix = "";
220        $suffix = "$dir" if ($dir ne "");
221
222        my $prefix = "";
223        if ($scheme =~ /ssh/) {
224                $prefix = "cvs+ssh://";
225        } else {
226                $prefix = "cvs://";
227        }
228        $res = $prefix.$res.$suffix;
229} else {
230        die "cms $scheme unknown";
231}
232pb_log(2,"Found CMS info: $res\n");
233return($res);
234}
235
236sub pb_cms_copy {
237my $scheme = shift;
238my $oldurl = shift;
239my $newurl = shift;
240
241if ($scheme =~ /^svn/) {
242        pb_system("svn copy -m \"Creation of $newurl from $oldurl\" $oldurl $newurl","Copying $oldurl to $newurl ");
243} elsif ($scheme eq "flat") {
244} elsif ($scheme =~ /^cvs/) {
245} else {
246        die "cms $scheme unknown";
247}
248}
249
250sub pb_cms_checkout {
251my $scheme = shift;
252my $url = shift;
253my $destination = shift;
254
255if ($scheme =~ /^svn/) {
256        pb_system("svn co $url $destination","Checking out $url to $destination ");
257} elsif (($scheme eq "ftp") || ($scheme eq "http")) {
258        return;
259} elsif ($scheme =~ /^cvs/) {
260        pb_system("cvs co $url $destination","Checking out $url to $destination ");
261} else {
262        die "cms $scheme unknown";
263}
264}
265
266sub pb_cms_up {
267my $scheme = shift;
268my $dir = shift;
269
270if ($scheme =~ /^svn/) {
271        pb_system("svn up $dir","Updating $dir");
272} elsif ($scheme eq "flat") {
273} elsif ($scheme =~ /^cvs/) {
274} else {
275        die "cms $scheme unknown";
276}
277}
278
279sub pb_cms_checkin {
280my $scheme = shift;
281my $dir = shift;
282
283my $ver = basename($dir);
284if ($scheme =~ /^svn/) {
285        pb_system("svn ci -m \"updated to $ver\" $dir","Checking in $dir");
286} elsif ($scheme eq "flat") {
287} elsif ($scheme =~ /^cvs/) {
288} else {
289        die "cms $scheme unknown";
290}
291pb_cms_up($scheme,$dir);
292}
293
294sub pb_cms_isdiff {
295my $scheme = shift;
296my $dir =shift;
297
298if ($scheme =~ /^svn/) {
299        open(PIPE,"svn diff $dir |") || die "Unable to get svn diff from $dir";
300        my $l = 0;
301        while (<PIPE>) {
302                $l++;
303        }
304        return($l);
305} elsif ($scheme eq "flat") {
306} elsif ($scheme =~ /^cvs/) {
307        open(PIPE,"cvs diff $dir |") || die "Unable to get svn diff from $dir";
308        my $l = 0;
309        while (<PIPE>) {
310                # Skipping normal messages
311                next if (/^cvs diff:/);
312                $l++;
313        }
314        return($l);
315} else {
316        die "cms $scheme unknown";
317}
318}
319
320#
321# Return the list of packages we are working on in a CMS action
322#
323sub pb_cms_get_pkg {
324
325my @pkgs = ();
326my $defpkgdir = shift || undef;
327my $extpkgdir = shift || undef;
328
329# Get packages list
330if (not defined $ARGV[0]) {
331        @pkgs = keys %$defpkgdir if (defined $defpkgdir);
332} elsif ($ARGV[0] =~ /^all$/) {
333        @pkgs = keys %$defpkgdir if (defined $defpkgdir);
334        push(@pkgs, keys %$extpkgdir) if (defined $extpkgdir);
335} else {
336        @pkgs = @ARGV;
337}
338pb_log(0,"Packages: ".join(',',@pkgs)."\n");
339return(\@pkgs);
340}
341
342#
343# Check pbconf/project cms compliance
344#
345sub pb_cms_compliant {
346
347my $param = shift;
348my $envar = shift;
349my $defdir = shift;
350my $uri = shift;
351my $pbinit = shift;
352my %pdir;
353
354my ($pdir) = pb_conf_get_if($param) if (defined $param);
355if (defined $pdir) {
356        %pdir = %$pdir;
357}
358
359
360if ((defined $pdir) && (%pdir) && (defined $pdir{$ENV{'PBPROJ'}})) {
361        # That's always the environment variable that will be used
362        $ENV{$envar} = $pdir{$ENV{'PBPROJ'}};
363} else {
364        if (defined $param) {
365                pb_log(1,"WARNING: no $param defined, using $defdir\n");
366                pb_log(1,"         Please create a $param reference for project $ENV{'PBPROJ'} in $ENV{'PBETC'}\n");
367                pb_log(1,"         if you want to use another directory\n");
368        }
369        $ENV{$envar} = "$defdir";
370}
371
372# Expand potential env variable in it
373eval { $ENV{$envar} =~ s/(\$ENV.+\})/$1/eeg };
374pb_log(2,"$envar: $ENV{$envar}\n");
375
376my ($scheme, $account, $host, $port, $path) = pb_get_uri($uri);
377
378if ((! -d "$ENV{$envar}") || (defined $pbinit)) {
379        if (defined $pbinit) {
380                pb_mkdir_p("$ENV{$envar}");
381        } else {
382                pb_log(1,"Checking out $uri\n");
383                pb_cms_checkout($scheme,$uri,$ENV{$envar});
384        }
385} elsif (($scheme !~ /^cvs/) || ($scheme !~ /^svn/)) {
386        # Do not compare if it's not a real cms
387        return;
388} else {
389        pb_log(1,"$uri found locally, checking content\n");
390        my $cmsurl = pb_cms_get_uri($scheme,$ENV{$envar});
391        my ($scheme2, $account2, $host2, $port2, $path2) = pb_get_uri($cmsurl);
392        if ($cmsurl ne $uri) {
393                # The local content doesn't correpond to the repository
394                pb_log(0,"ERROR: Inconsistency detected:\n");
395                pb_log(0,"       * $ENV{$envar} refers to $cmsurl but\n");
396                pb_log(0,"       * $ENV{'PBETC'} refers to $uri\n");
397                die "Project $ENV{'PBPROJ'} is not Project-Builder compliant.";
398        } else {
399                pb_log(1,"Content correct - doing nothing - you may want to update your repository however\n");
400                # they match - do nothing - there may be local changes
401        }
402}
403}
404
405sub pb_cms_create_authors {
406
407my $authors=shift;
408my $dest=shift;
409my $scheme=shift;
410
411return if ($authors eq "/dev/null");
412open(SAUTH,$authors) || die "Unable to open $authors";
413# Save a potentially existing AUTHORS file and write instead toi AUTHORS.pb
414my $ext = "";
415if (-f "$dest/AUTHORS") {
416        $ext = ".pb";
417}
418open(DAUTH,"> $dest/AUTHORS$ext") || die "Unable to create $dest/AUTHORS$ext";
419print DAUTH "Authors of the project are:\n";
420print DAUTH "===========================\n";
421while (<SAUTH>) {
422        my ($nick,$gcos) = split(/:/);
423        chomp($gcos);
424        print DAUTH "$gcos";
425        if (defined $scheme) {
426                # Do not give a scheme for flat types
427                my $endstr="";
428                if ("$ENV{'PBREVISION'}" ne "flat") {
429                        $endstr = " under $scheme";
430                }
431                print DAUTH " ($nick$endstr)\n";
432        } else {
433                print DAUTH "\n";
434        }
435}
436close(DAUTH);
437close(SAUTH);
438}
439
440sub pb_cms_log {
441
442my $scheme = shift;
443my $pkgdir = shift;
444my $dest = shift;
445my $chglog = shift;
446my $authors = shift;
447
448pb_cms_create_authors($authors,$dest,$scheme);
449
450if ($scheme =~ /^svn/) {
451        if (! -f "$dest/ChangeLog") {
452                if (-x "/usr/bin/svn2cl") {
453                        # In case we have no network, just create an empty one before to allow correct build
454                        open(CL,"> $dest/ChangeLog") || die "Unable to create $dest/ChangeLog";
455                        close(CL);
456                        pb_system("/usr/bin/svn2cl --group-by-day --authors=$authors -i -o $dest/ChangeLog $pkgdir","Generating ChangeLog from SVN with svn2cl");
457                } else {
458                        # To be written from pbcl
459                        pb_system("svn log -v $pkgdir > $dest/$ENV{'PBCMSLOGFILE'}","Extracting log info from SVN");
460                }
461        }
462} elsif (($scheme eq "file") || ($scheme eq "dir") || ($scheme eq "http") || ($scheme eq "ftp")) {
463        if (! -f "$dest/ChangeLog") {
464                pb_system("echo ChangeLog for $pkgdir > $dest/ChangeLog","Empty ChangeLog file created");
465        }
466} elsif ($scheme =~ /^cvs/) {
467        my $tmp=basename($pkgdir);
468        # CVS needs a relative path !
469        if (! -f "$dest/ChangeLog") {
470                if (-x "/usr/bin/cvs2cl") {
471                        # In case we have no network, just create an empty one before to allow correct build
472                        open(CL,"> $dest/ChangeLog") || die "Unable to create $dest/ChangeLog";
473                        close(CL);
474                        pb_system("/usr/bin/cvs2cl --group-by-day -U $authors -f $dest/ChangeLog $pkgdir","Generating ChangeLog from CVS with cvs2cl");
475                } else {
476                        # To be written from pbcl
477                        pb_system("cvs log $tmp > $dest/$ENV{'PBCMSLOGFILE'}","Extracting log info from CVS");
478                }
479        }
480} else {
481        die "cms $scheme unknown";
482}
483}
484
4851;
Note: See TracBrowser for help on using the repository browser.