source: devel/pb-modules/lib/ProjectBuilder/Base.pm @ 1505

Last change on this file since 1505 was 1505, checked in by bruno, 7 years ago
  • Base.pm: use Carp and Cwd so we can give better error messages. Use new Global::pb_stop_on_error variable to decide whether we should abort on an error. (Eric Anderson from 9c3c696597c49b385df409311b1385d7a394db5a)
  • Distribution.pm: Remove useless redundant check of deps not maching whitespace, improve message since it is likely to call sudo. Skip dependencies that are all whitespace since that leads to errors when running dpkg -L <whitespace> (Eric Anderson from 9c3c696597c49b385df409311b1385d7a394db5a)
File size: 12.7 KB
RevLine 
[2]1#!/usr/bin/perl -w
2#
[395]3# Base subroutines brought by the the Project-Builder project
4# which can be easily used by whatever perl project
[2]5#
[395]6# Copyright B. Cornec 2007-2008
7# Provided under the GPL v2
8#
[2]9# $Id$
10#
11
[318]12package ProjectBuilder::Base;
13
[18]14use strict;
[5]15use lib qw (lib);
[1505]16use Carp 'cluck';
17use Cwd;
[9]18use File::Path;
[318]19use File::Temp qw(tempdir);
[8]20use Data::Dumper;
[318]21use Time::localtime qw(localtime);
[397]22use Pod::Usage;
[328]23use English;
[681]24use POSIX qw(locale_h);
[1148]25use ProjectBuilder::Version;
[2]26
[318]27# Inherit from the "Exporter" module which handles exporting functions.
28 
[1156]29use vars qw($VERSION $REVISION @ISA @EXPORT);
[318]30use Exporter;
31 
32# Export, by default, all the functions into the namespace of
33# any code which uses this module.
34 
[495]35our $pbdebug = 0;       # Global debug level
36our $pbLOG = \*STDOUT;  # File descriptor of the log file
37our $pbsynmsg = "Error";    # Global error message
38our $pbdisplaytype = "text";
39                        # default display mode for messages
40our $pblocale = "C";
[318]41
42our @ISA = qw(Exporter);
[1400]43our @EXPORT = qw(pb_mkdir_p pb_system pb_rm_rf pb_get_date pb_log pb_log_init pb_get_uri pb_get_content pb_set_content pb_display_file pb_syntax_init pb_syntax pb_temp_init pb_get_arch pb_get_osrelease pb_check_requirements pb_check_req $pbdebug $pbLOG $pbdisplaytype $pblocale);
[1156]44($VERSION,$REVISION) = pb_version_init();
[318]45
[395]46=pod
[2]47
[395]48=head1 NAME
[2]49
[395]50ProjectBuilder::Base, part of the project-builder.org - module dealing with generic functions suitable for perl project development
[355]51
[395]52=head1 DESCRIPTION
[69]53
[1400]54This module provides generic functions suitable for perl project development
[69]55
[395]56=head1 SYNOPSIS
[69]57
[395]58  use ProjectBuilder::Base;
[313]59
[395]60  #
61  # Create a directory and its parents
62  #
63  pb_mkdir_p("/tmp/foo/bar");
[313]64
[395]65  #
66  # Remove recursively a directory and its children
67  #
68  pb_rm_rf("/tmp/foo");
[313]69
[395]70  #
71  # Encapsulate the system call for better output and return value test
72  #
73  pb_system("ls -l", "Printing directory content");
[314]74
[395]75  #
76  # Analysis a URI and return its components in a table
77  #
[1076]78  my ($scheme, $account, $host, $port, $path) = pb_get_uri("svn+ssh://ac@my.server.org:port/path/to/dir");
[313]79
[395]80  #
81  # Gives the current date in a table
82  #
83  @date = pb_get_date();
[2]84
[395]85  #
86  # Manages logs of the program
87  #
88  pb_log_init(2,\*STDOUT);
89  pb_log(1,"Message to print\n");
[313]90
[395]91  #
92  # Manages content of a file
93  #
[1063]94  pb_display_file("/etc/passwd",\*STDERR);
[395]95  my $cnt = pb_get_content("/etc/passwd");
[313]96
[395]97=head1 USAGE
[320]98
[395]99=over 4
[323]100
[395]101=item B<pb_mkdir_p>
[314]102
[395]103Internal mkdir -p function. Forces mode to 755. Supports multiple parameters.
[358]104
[396]105Based on File::Path mkpath.
106
[395]107=cut
[273]108
[74]109sub pb_mkdir_p {
[29]110my @dir = @_;
111my $ret = mkpath(@dir, 0, 0755);
[1486]112return($ret);
[9]113}
114
[396]115=item B<pb_rm_rf>
[395]116
117Internal rm -rf function. Supports multiple parameters.
118
[396]119Based on File::Path rmtree.
120
[395]121=cut
122
[74]123sub pb_rm_rf {
[29]124my @dir = @_;
125my $ret = rmtree(@dir, 0, 0);
126return($ret);
[9]127}
128
[395]129=item B<pb_system>
130
[1486]131Encapsulate the "system" call for better output and return value test.
132Needs a $ENV{'PBTMP'} variable which is created by calling the pb_mktemp_init function.
133Needs pb_log support, so pb_log_init should have been called before.
[395]134
[1486]135The first parameter is the shell command to call. This command should NOT use redirections.
[395]136The second parameter is the message to print on screen. If none is given, then the command is printed.
[1486]137The third parameter print the result of the command after correct execution if value is verbose. If value is noredir, it avoids redirecting outputs (e.g. for vi). If value is quiet, doesn't print anything at all.
138This function returns as a result the return value of the system command.
[396]139
[395]140If no error reported, it prints OK on the screen, just after the message. Else it prints the errors generated.
141
142=cut
143
[74]144sub pb_system {
[29]145
146my $cmd=shift;
[30]147my $cmt=shift || $cmd;
[471]148my $verbose=shift || undef;
[473]149my $redir = "";
[29]150
[503]151pb_log(0,"$cmt... ") if ((! defined $verbose) || ($verbose ne "quiet"));
[395]152pb_log(1,"Executing $cmd\n");
[1137]153unlink("$ENV{'PBTMP'}/system.$$.log") if (-f "$ENV{'PBTMP'}/system.$$.log");
154$redir = "2>> $ENV{'PBTMP'}/system.$$.log 1>> $ENV{'PBTMP'}/system.$$.log" if ((! defined $verbose) || ($verbose ne "noredir"));
[473]155system("$cmd $redir");
[347]156my $res = $?;
[500]157# Exit now if the command may fail
158if ((defined $verbose) and ($verbose eq "mayfail")) {
159    pb_log(0,"N/A\n") if ($res != 0);
160    pb_log(0,"OK\n") if ($res == 0);
161    return($res) 
162    }
[1505]163
164my $cwd = getcwd;
165my $error = undef;
166$error = "failed to execute ($cmd) in $cwd: $!\n" if ($res == -1);
167$error = "child ($cmd) died with signal ".($res & 127).", ".($res & 128) ? 'with' : 'without'." coredump\n" if ($res & 127);
168$error = "child ($cmd) cwd=$cwd exited with value ".($res >> 8)."\n" if ($res != 0);
169
170if (defined $error) {
171    pb_log(0, $error) if ((! defined $verbose) || ($verbose ne "quiet")) || $Global::pb_stop_on_error;
172    pb_display_file("$ENV{'PBTMP'}/system.$$.log") if ((-f "$ENV{'PBTMP'}/system.$$.log") and ((! defined $verbose) || ($verbose ne "quiet") || $Global::pb_stop_on_error));
173    if ($Global::pb_stop_on_error) {
174        cluck "error running command ($cmd) with cwd=$cwd";
175        exit(1);
176    }
177} else {
[503]178    pb_log(0,"OK\n") if ((! defined $verbose) || ($verbose ne "quiet"));
[1505]179    pb_display_file("$ENV{'PBTMP'}/system.$$.log") if ((-f "$ENV{'PBTMP'}/system.$$.log") and (defined $verbose) and ($verbose ne "quiet"));
[29]180}
[1505]181
[347]182return($res);
[30]183}
[74]184
[395]185=item B<pb_get_uri>
186
187This function returns a list of 6 parameters indicating the protocol, account, password, server, port, and path contained in the URI passed in parameter.
188
189A URI has the format protocol://[ac@]host[:port][path[?query][#fragment]].
[396]190
[395]191Cf man URI.
192
193=cut
194
[314]195sub pb_get_uri {
[313]196
[314]197my $uri = shift || undef;
[313]198
[1504]199pb_log(2,"DEBUG: uri:" . (defined $uri ? $uri : '') . "\n");
[314]200my ($scheme, $authority, $path, $query, $fragment) =
[318]201         $uri =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?| if (defined $uri);
202my ($account,$host,$port) = $authority =~ m|(?:([^\@]+)\@)?([^:]+)(:(?:[0-9]+))?| if (defined $authority);
203
204$scheme = "" if (not defined $scheme);
205$authority = "" if (not defined $authority);
206$path = "" if (not defined $path);
207$account = "" if (not defined $account);
208$host = "" if (not defined $host);
[1076]209if (not defined $port) {
210    $port = "" 
211} else {
212    # Remove extra : at start
213    $port =~ s/^://;
214}
[318]215
[315]216pb_log(2,"DEBUG: scheme:$scheme ac:$account host:$host port:$port path:$path\n");
[314]217return($scheme, $account, $host, $port, $path);
[313]218}
219
[395]220=item B<pb_get_date>
[313]221
[395]222This function returns a list of 9 parameters indicating the seconds, minutes, hours, day, month, year, day in the week, day in the year, and daylight saving time flag of the current time.
[74]223
[395]224Cf: man ctime and description of the struct tm.
[74]225
[395]226=cut
[339]227
[315]228sub pb_get_date {
229   
230return(localtime->sec(), localtime->min(), localtime->hour(), localtime->mday(), localtime->mon(), localtime->year(), localtime->wday(), localtime->yday(), localtime->isdst());
231}
232
[395]233=item B<pb_log_init>
[315]234
[395]235This function initializes the global variables used by the pb_log function.
[106]236
[395]237The first parameter is the debug level which will be considered during the run of the program?
238The second parameter is a pointer on a file descriptor used to print the log info.
[315]239
[396]240As an example, if you set the debug level to 2 in that function, every call to pb_log which contains a value less or equal than 2 will be printed. Calls with a value greater than 2 won't be printed.
241
242The call to B<pb_log_init> is typically done after getting a parameter on the CLI indicating the level of verbosity expected.
243
[395]244=cut
[319]245
[315]246sub pb_log_init {
[77]247
[495]248$pbdebug = shift || 0;
249$pbLOG = shift || \*STDOUT;
250pb_log(1,"Debug value: $pbdebug\n");
[315]251
252} 
253
[396]254=item B<pb_log>
255
256This function logs the messages passed as the second parameter if the value passed as first parameter is lesser or equal than the value passed to the B<pb_log_init> function.
257
258Here is a usage example:
259
260  pb_log_init(2,\*STDERR);
261  pb_log(1,"Hello World 1\n");
262  pb_log(2,"Hello World 2\n");
263  pb_log(3,"Hello World 3\n");
264
265  will print:
266 
267  Hello World 1
268  Hello World 2
269
270=cut 
271
[315]272sub pb_log {
273
274my $dlevel = shift;
275my $msg = shift;
276
[495]277print $pbLOG "$msg" if ($dlevel <= $pbdebug);
[1060]278print "$msg" if (($dlevel == 0) && ($pbLOG != \*STDOUT));
[315]279}
280
[495]281
[396]282=item B<pb_display_file>
283
284This function print the content of the file passed in parameter.
[1063]285If a second parameter is given, this is the descriptor of the logfile to write to in addtion to STDOUT.
[396]286
287This is a cat equivalent function.
288
289=cut
290
[395]291sub pb_display_file {
[316]292
[395]293my $file=shift;
[1063]294my $desc=shift || undef;
[316]295
[395]296return if (not -f $file);
[1063]297my $cnt = pb_get_content($file);
298print "$cnt\n";
299print $desc "$cnt\n" if (defined $desc);
[316]300}
301
[396]302=item B<pb_get_content>
303
304This function returns the content of the file passed in parameter.
305
306=cut
307
[395]308sub pb_get_content {
[353]309
[395]310my $file=shift;
[353]311
[395]312my $bkp = $/;
313undef $/;
314open(R,$file) || die "Unable to open $file: $!";
315my $content=<R>;
316close(R);
317chomp($content);
318$/ = $bkp;
319return($content);
[353]320}
321
[556]322
323=item B<pb_set_content>
324
[1137]325This function put the content of a variable passed as second parameter into the file passed as first parameter.
[556]326
327=cut
328
329sub pb_set_content {
330
331my $file=shift;
332my $content=shift;
333
334my $bkp = $/;
335undef $/;
336open(R,"> $file") || die "Unable to write to $file: $!";
337print R "$content";
338close(R);
339$/ = $bkp;
340}
341
[397]342=item B<pb_syntax_init>
343
344This function initializes the global variable used by the pb_syntax function.
345
346The parameter is the message string which will be printed when calling pb_syntax
347
348=cut
349
350sub pb_syntax_init {
351
[495]352$pbsynmsg = shift || "Error";
[397]353}
354
355=item B<pb_syntax>
356
357This function prints the syntax expected by the application, based on pod2usage, and exits.
358The first parameter is the return value of the exit.
359The second parameter is the verbosity as expected by pod2usage.
360
361Cf: man Pod::Usage
362
363=cut
364
365sub pb_syntax {
366
367my $exit_status = shift || -1;
368my $verbose_level = shift || 0;
369
370my $filehandle = \*STDERR;
371
372$filehandle = \*STDOUT if ($exit_status == 0);
373
[495]374pod2usage( { -message => $pbsynmsg,
[397]375             -exitval => $exit_status  ,
376             -verbose => $verbose_level,
377             -output  => $filehandle } );
378}
379
380=item B<pb_temp_init>
381
382This function initializes the environemnt variable PBTMP to a random value. This directory can be safely used during the whole program, it will be removed at the end automatically.
383
384=cut
385
386sub pb_temp_init {
387
388if (not defined $ENV{'TMPDIR'}) {
389    $ENV{'TMPDIR'}="/tmp";
390}
391$ENV{'PBTMP'} = tempdir( "pb.XXXXXXXXXX", DIR => $ENV{'TMPDIR'}, CLEANUP => 1 );
392}
393
[1400]394=item B<pb_get_osrelease>
395
396This function returns the release of our operating system
397
398=cut
399
400sub pb_get_osrelease {
401
402# On linux can also use /proc/sys/kernel/osrelease
[1408]403my $rel = `uname -r`;
[1402]404chomp($rel);
405return($rel);
[1400]406}
407
408
[749]409=item B<pb_get_arch>
410
411This function returns the architecture of our local environment and
412standardize on i386 for those platforms. It also solves issues where a i386 VE on x86_64 returns x86_64 wrongly
413
414=cut
415
416sub pb_get_arch {
417
418my $arch = `uname -m`;
419chomp($arch);
420$arch =~ s/i.86/i386/;
[873]421# For Solaris
422$arch =~ s/i86pc/i386/;
[749]423
424return($arch);
425}
426
[974]427=item B<pb_check_requirements>
428
429This function checks that the commands needed for the subsystem are indeed present.
[1077]430The required commands are passed as a coma separated string as first parameter.
431The optional commands are passed as a coma separated string as second parameter.
[974]432
433=cut
434
435sub pb_check_requirements {
436
[1128]437my $req = shift || undef;
438my $opt = shift || undef;
439my $appname = shift || undef;
[974]440
[1128]441my ($req2,$opt2) = (undef,undef);
442$req2 = $req->{$appname} if (defined $req and defined $appname);
443$opt2 = $opt->{$appname} if (defined $opt and defined $appname);
444
[974]445# cmds is a string of coma separated commands
[1128]446if (defined $req2) {
447    foreach my $file (split(/,/,$req2)) {
448        pb_check_req($file,0);
449    }
[974]450}
451
452# opts is a string of coma separated commands
[1128]453if (defined $opt2) {
454    foreach my $file (split(/,/,$opt2)) {
455        pb_check_req($file,1);
456    }
[974]457}
458}
459
[1127]460=item B<pb_check_req>
461
[1433]462This function checks existence of a command and return its full pathname or undef if not found.
[1127]463The command name is passed as first parameter.
464The second parameter should be 0 if the command is mandatory, 1 if optional.
465
466=cut
467
[974]468sub pb_check_req {
469
470my $file = shift;
471my $opt = shift || 1;
[1127]472my $found = undef;
[974]473
474pb_log(2,"Checking availability of $file...");
475# Check for all dirs in the PATH
476foreach my $p (split(/:/,$ENV{'PATH'})) {
[1127]477    if (-x "$p/$file") {
478        $found =  "$p/$file";
479        last;
480    }
[974]481}
[1127]482
483if (not $found) {
[974]484    pb_log(2,"KO\n");
485    if ($opt eq 1) {
486        pb_log(2,"Unable to find optional command $file\n");
487    } else {
488        die pb_log(0,"Unable to find required command $file\n");
489    }
490} else {
491    pb_log(2,"OK\n");
492}
[1402]493return($found);
[974]494}
495
[397]496=back
497
498=head1 WEB SITES
499
500The 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/>.
501
502=head1 USER MAILING LIST
503
504None exists for the moment.
505
506=head1 AUTHORS
507
508The Project-Builder.org team L<http://trac.project-builder.org/> lead by Bruno Cornec L<mailto:bruno@project-builder.org>.
509
510=head1 COPYRIGHT
511
512Project-Builder.org is distributed under the GPL v2.0 license
513described in the file C<COPYING> included with the distribution.
514
515=cut
516
[2]5171;
Note: See TracBrowser for help on using the repository browser.