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

Last change on this file was 2347, checked in by bruno, 8 months ago

Exit in pb_system if PBTMP is not defined in env

File size: 16.0 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 croak/;
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");
153
154croak('Please call pb_temp_init in your code before using pb_system') if (not defined "$ENV{'PBTMP'}");
155unlink("$ENV{'PBTMP'}/system.$$.log") if (-f "$ENV{'PBTMP'}/system.$$.log");
156$redir = "2>> $ENV{'PBTMP'}/system.$$.log 1>> $ENV{'PBTMP'}/system.$$.log" if ((! defined $verbose) || ($verbose ne "noredir"));
157
158# If sudo used, then be more verbose
159pb_log(0,"Executing $cmd\n") if (($pbdebug < 1) && ($cmd =~ /^\s*\S*sudo/o) && (defined $Global::pb_show_sudo) && ($Global::pb_show_sudo =~ /true/oi));
160
161system("$cmd $redir");
162my $res = $?;
163# Exit now if the command may fail
164if ((defined $verbose) and ($verbose =~ /mayfail/)) {
165    pb_log(0,"NOT OK but non blocking\n") if ($res != 0);
166    pb_log(0,"OK\n") if ($res == 0);
167    pb_display_file("$ENV{'PBTMP'}/system.$$.log",undef,$verbose) if ((-f "$ENV{'PBTMP'}/system.$$.log") and ($verbose =~ /verbose/));
168    return($res) 
169}
170
171my $cwd = getcwd;
172my $error = undef;
173$error = "ERROR: failed to execute ($cmd) in $cwd: $!\n" if ($res == -1);
174$error = "ERROR: child ($cmd) died with signal ".($res & 127).", ".($res & 128) ? 'with' : 'without'." coredump\n" if ($res & 127);
175$error = "ERROR: child ($cmd) cwd=$cwd exited with value ".($res >> 8)."\n" if ($res != 0);
176
177if (defined $error) {
178    pb_log(0, $error) if (((! defined $verbose) || ($verbose ne "quiet")) || ($Global::pb_stop_on_error));
179    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));
180    if ($Global::pb_stop_on_error) {
181        confess("ERROR running command ($cmd) with cwd=$cwd, pid=$$");
182    } else {
183        pb_log(0,"ERROR running command ($cmd) with cwd=$cwd, pid=$$\n");
184    }
185} else {
186    pb_log(0,"OK\n") if ((! defined $verbose) || ($verbose ne "quiet"));
187    pb_display_file("$ENV{'PBTMP'}/system.$$.log",undef,$verbose) if ((-f "$ENV{'PBTMP'}/system.$$.log") and (defined $verbose) and ($verbose ne "quiet"));
188}
189
190return($res);
191}
192
193=item B<pb_get_uri>
194
195This function returns a list of 6 parameters indicating the protocol, account, password, server, port, and path contained in the URI passed in parameter.
196
197A URI has the format protocol://[ac@]host[:port][path[?query][#fragment]].
198
199Cf man URI.
200
201=cut
202
203sub pb_get_uri {
204
205my $uri = shift;
206
207pb_log(2,"DEBUG: uri:" . (defined $uri ? $uri : '') . "\n");
208my ($scheme, $authority, $path, $query, $fragment) =
209         $uri =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?| if (defined $uri);
210my ($account,$host,$port) = $authority =~ m|(?:([^\@]+)\@)?([^:]+)(:(?:[0-9]+))?| if (defined $authority);
211
212$scheme = "" if (not defined $scheme);
213$authority = "" if (not defined $authority);
214$path = "" if (not defined $path);
215$account = "" if (not defined $account);
216$host = "" if (not defined $host);
217if (not defined $port) {
218    $port = "" 
219} else {
220    # Remove extra : at start
221    $port =~ s/^://;
222}
223
224pb_log(2,"DEBUG: scheme:$scheme ac:$account host:$host port:$port path:$path\n");
225return($scheme, $account, $host, $port, $path);
226}
227
228=item B<pb_get_date>
229
230This 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.
231
232Cf: man ctime and description of the struct tm.
233
234=cut
235
236sub pb_get_date {
237   
238return(localtime->sec(), localtime->min(), localtime->hour(), localtime->mday(), localtime->mon(), localtime->year(), localtime->wday(), localtime->yday(), localtime->isdst());
239}
240
241=item B<pb_log_init>
242
243This function initializes the global variables used by the pb_log function.
244
245The first parameter is the debug level which will be considered during the run of the program?
246The second parameter is a pointer on a file descriptor used to print the log info.
247
248As 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.
249
250The call to B<pb_log_init> is typically done after getting a parameter on the CLI indicating the level of verbosity expected.
251
252=cut
253
254sub pb_log_init {
255
256$pbdebug = shift;
257$pbLOG = shift;
258
259$pbdebug = 0 if (not defined $pbdebug);
260$pbLOG = \*STDOUT if (not defined $pbLOG);
261pb_log(1,"Debug value: $pbdebug\n");
262
263} 
264
265=item B<pb_log>
266
267This 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.
268
269Here is a usage example:
270
271  pb_log_init(2,\*STDERR);
272  pb_log(1,"Hello World 1\n");
273  pb_log(2,"Hello World 2\n");
274  pb_log(3,"Hello World 3\n");
275
276  will print:
277 
278  Hello World 1
279  Hello World 2
280
281=cut 
282
283sub pb_log {
284
285my $dlevel = shift;
286my $msg = shift;
287
288$dlevel = 0 if (not defined $dlevel);
289$msg = "" if (not defined $msg);
290$pbLOG = \*STDOUT if (not defined $pbLOG);
291
292print $pbLOG "$msg" if ($dlevel <= $pbdebug);
293print "$msg" if (($dlevel == 0) && ($pbLOG != \*STDOUT));
294}
295
296
297=item B<pb_display_file>
298
299This function prints the content of the file passed in parameter.
300If a second parameter is given, this is the descriptor of the logfile to write to in addtion to STDOUT.
301If 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.
302
303This is a cat equivalent function.
304
305=cut
306
307sub pb_display_file {
308
309my $file=shift;
310my $desc=shift;
311my $prefix=shift;
312
313return if (not -f $file);
314my $cnt = pb_get_content($file);
315# If we have a prefix, then add it at each line
316if ((defined $prefix) and ($prefix =~ "_")) {
317    $prefix =~ s/verbose_//;
318    $cnt =~ s/(.*)\n/$prefix$1\n/g;
319} else {
320    $prefix = "";
321}
322print "$prefix$cnt";
323print $desc "$prefix$cnt" if (defined $desc);
324}
325
326=item B<pb_get_content>
327
328This function returns the content of the file passed in parameter.
329
330=cut
331sub pb_get_content {
332
333my $file=shift;
334
335open(R,$file) || die "Unable to open $file: $!";
336local $/;
337my $content=<R>;
338close(R);
339return($content);
340}
341
342
343=item B<pb_set_content>
344
345This function put the content of a variable passed as second parameter into the file passed as first parameter.
346
347=cut
348
349sub pb_set_content {
350
351my $file=shift;
352my $content=shift;
353
354my $bkp = $/;
355undef $/;
356open(R,"> $file") || die "Unable to write to $file: $!";
357print R "$content";
358close(R);
359$/ = $bkp;
360}
361
362=item B<pb_exit>
363
364Fundtion to call before exiting pb so cleanup is done
365
366=cut
367
368sub pb_exit {
369
370my $ret = shift;
371$ret = 0 if (not defined $ret);
372pb_log(0,"Please remove manually $ENV{'PBTMP'} after debug analysis\n") if ($pbdebug > 1);
373exit($ret);
374}
375
376=item B<pb_syntax_init>
377
378This function initializes the global variable used by the pb_syntax function.
379
380The parameter is the message string which will be printed when calling pb_syntax
381
382=cut
383
384sub pb_syntax_init {
385
386$pbsynmsg = shift || "Error";
387}
388
389=item B<pb_syntax>
390
391This function prints the syntax expected by the application, based on pod2usage, and exits.
392The first parameter is the return value of the exit.
393The second parameter is the verbosity as expected by pod2usage.
394
395Cf: man Pod::Usage
396
397=cut
398
399sub pb_syntax {
400
401my $exit_status = shift;
402my $verbose_level = shift;
403
404my $filehandle = \*STDERR;
405
406# Don't do it upper as before as when the value is 0
407# it is considered false and then exit was set to -1
408$exit_status = -1 if (not defined $exit_status);
409$verbose_level = 0 if (not defined $verbose_level);
410
411$filehandle = \*STDOUT if ($exit_status == 0);
412
413eval {
414    require Pod::Usage;
415    Pod::Usage->import();
416};
417if ($@) {
418    # No Pod::Usage found not printing usage. Old perl only
419    pb_exit();
420} else {
421    pod2usage(  -message => $pbsynmsg,
422            -exitval => $exit_status,
423            -verbose => $verbose_level,
424            -output  => $filehandle );
425}
426}
427
428=item B<pb_temp_init>
429
430This 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.
431
432=cut
433
434sub pb_temp_init {
435
436my $pbkeep = shift; 
437
438# Do not keep temp files by default
439$pbkeep = 0 if (not defined $pbkeep);
440
441if (not defined $ENV{'TMPDIR'}) {
442    $ENV{'TMPDIR'}="/tmp";
443}
444
445# Makes this function compatible with perl 5.005x
446eval {
447    require File::Temp;
448    File::Temp->import("tempdir");
449};
450if ($@) {
451    # File::Temp not found, harcoding stuff
452    # Inspired by http://cpansearch.perl.org/src/TGUMMELS/File-MkTemp-1.0.6/File/MkTemp.pm
453    # Copyright 1999|2000 Travis Gummels.  All rights reserved. 
454    # This may be used and modified however you want.
455    my $template = "pb.XXXXXXXXXX";
456    my @template = split //, $template;
457    my @letters = split(//,"1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ");
458    for (my $i = $#template; $i >= 0 && ($template[$i] eq 'X'); $i--){
459        $template[$i] = $letters[int(rand 52)];
460    }
461    undef $template;
462    $template = pack "a" x @template, @template;
463    $ENV{'PBTMP'} = "$ENV{'TMPDIR'}/$template";
464    pb_mkdir_p($ENV{'PBTMP'});
465} else {
466    if (($pbdebug > 1) || ($pbkeep == 1)) {
467        $ENV{'PBTMP'} = tempdir( "pb.XXXXXXXXXX", DIR => $ENV{'TMPDIR'});
468        pb_log(2,"DEBUG: Creating a non-volatile temporary directory ($ENV{'PBTMP'})\n");
469    } else {
470        $ENV{'PBTMP'} = tempdir( "pb.XXXXXXXXXX", DIR => $ENV{'TMPDIR'}, CLEANUP => 1 );
471    }
472}
473}
474
475=item B<pb_get_osrelease>
476
477This function returns the release of our operating system
478
479=cut
480
481sub pb_get_osrelease {
482
483# On linux can also use /proc/sys/kernel/osrelease
484my $rel = `uname -r`;
485chomp($rel);
486return($rel);
487}
488
489
490=item B<pb_get_arch>
491
492This function returns the architecture of our local environment and
493standardize on i386 for those platforms.
494
495=cut
496
497sub pb_get_arch {
498
499my $arch = `uname -m`;
500chomp($arch);
501$arch =~ s/i[3456]86/i386/;
502# For Solaris
503$arch =~ s/i86pc/i386/;
504
505return($arch);
506}
507
508=item B<pb_check_requirements>
509
510This function checks that the commands needed for the subsystem are indeed present.
511The required commands are passed as a comma separated string as first parameter.
512The optional commands are passed as a comma separated string as second parameter.
513
514=cut
515
516sub pb_check_requirements {
517
518my $req = shift;
519my $opt = shift;
520my $appname = shift;
521
522my ($req2,$opt2) = (undef,undef);
523$req2 = $req->{$appname} if (defined $req and defined $appname);
524$opt2 = $opt->{$appname} if (defined $opt and defined $appname);
525
526# cmds is a string of comma separated commands
527if (defined $req2) {
528    foreach my $file (split(/,/,$req2)) {
529        pb_check_req($file,0);
530    }
531}
532
533# opts is a string of comma separated commands
534if (defined $opt2) {
535    foreach my $file (split(/,/,$opt2)) {
536        pb_check_req($file,1);
537    }
538}
539}
540
541=item B<pb_check_req>
542
543This function checks existence of a command and return its full pathname or undef if not found.
544The command name is passed as first parameter.
545The second parameter should be 0 if the command is mandatory, 1 if optional.
546It returns the full path name of the command if found, undef otherwise and dies if that was a mandatory command
547
548=cut
549
550sub pb_check_req {
551
552my $file = shift;
553my $opt = shift;
554my $found = undef;
555
556$opt = 1 if (not defined $opt);
557
558pb_log(2,"Checking availability of $file...");
559# Check for all dirs in the PATH
560foreach my $p (split(/:/,$ENV{'PATH'})) {
561    if (-x "$p/$file") {
562        $found =  "$p/$file";
563        last;
564    }
565}
566
567if (not $found) {
568    pb_log(2,"KO\n");
569    if ($opt eq 1) {
570        pb_log(2,"Unable to find optional command $file\n");
571    } else {
572        die pb_log(0,"Unable to find required command $file\n");
573    }
574} else {
575    pb_log(2,"OK\n");
576}
577return($found);
578}
579
580=item B<pb_path_expand>
581
582Expand out a path by environment variables as ($ENV{'ENVVAR'}) and ~
583
584=cut
585
586sub pb_path_expand {
587
588my $path = shift;
589
590eval { $path =~ s/(\$ENV.+\})/$1/eeg; };
591$path =~ s/^\~/$ENV{'HOME'}/;
592
593return($path);
594}
595
596=back
597
598=head1 WEB SITES
599
600The 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/>.
601
602=head1 USER MAILING LIST
603
604None exists for the moment.
605
606=head1 AUTHORS
607
608The Project-Builder.org team L<http://trac.project-builder.org/> lead by Bruno Cornec L<mailto:bruno@project-builder.org>.
609
610=head1 COPYRIGHT
611
612Project-Builder.org is distributed under the GPL v2.0 license
613described in the file C<COPYING> included with the distribution.
614
615=cut
616
6171;
Note: See TracBrowser for help on using the repository browser.