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

Last change on this file since 2287 was 2287, checked in by bruno, 2 years ago

Fix usage of labels in env var (normalize with 'LABEL'

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