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

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