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

Last change on this file since 1852 was 1852, checked in by bruno, 6 years ago
  • Fix duplicate display error and intermediate RE error as well
File size: 15.5 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-2012
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 @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) = 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 || undef;
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 || undef;
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 || 0;
255$pbLOG = shift || \*STDOUT;
256pb_log(1,"Debug value: $pbdebug\n");
257
258} 
259
260=item B<pb_log>
261
262This 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.
263
264Here is a usage example:
265
266  pb_log_init(2,\*STDERR);
267  pb_log(1,"Hello World 1\n");
268  pb_log(2,"Hello World 2\n");
269  pb_log(3,"Hello World 3\n");
270
271  will print:
272 
273  Hello World 1
274  Hello World 2
275
276=cut 
277
278sub pb_log {
279
280my $dlevel = shift || 0;
281my $msg = shift || "";
282
283$pbLOG = \*STDOUT if (not defined $pbLOG);
284
285print $pbLOG "$msg" if ($dlevel <= $pbdebug);
286print "$msg" if (($dlevel == 0) && ($pbLOG != \*STDOUT));
287}
288
289
290=item B<pb_display_file>
291
292This function prints the content of the file passed in parameter.
293If a second parameter is given, this is the descriptor of the logfile to write to in addtion to STDOUT.
294If 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.
295
296This is a cat equivalent function.
297
298=cut
299
300sub pb_display_file {
301
302my $file=shift;
303my $desc=shift;
304my $prefix=shift;
305
306return if (not -f $file);
307my $cnt = pb_get_content($file);
308# If we have a prefix, then add it at each line
309if ((defined $prefix) and ($prefix =~ "_")) {
310    $prefix =~ s/verbose_//;
311    $cnt =~ s/(.*)\n/$prefix$1\n/g;
312} else {
313    $prefix = "";
314}
315print "$prefix$cnt";
316print $desc "$prefix$cnt" if (defined $desc);
317}
318
319=item B<pb_get_content>
320
321This function returns the content of the file passed in parameter.
322
323=cut
324sub pb_get_content {
325
326my $file=shift;
327
328open(R,$file) || die "Unable to open $file: $!";
329local $/;
330my $content=<R>;
331close(R);
332return($content);
333}
334
335
336=item B<pb_set_content>
337
338This function put the content of a variable passed as second parameter into the file passed as first parameter.
339
340=cut
341
342sub pb_set_content {
343
344my $file=shift;
345my $content=shift;
346
347my $bkp = $/;
348undef $/;
349open(R,"> $file") || die "Unable to write to $file: $!";
350print R "$content";
351close(R);
352$/ = $bkp;
353}
354
355=item B<pb_exit>
356
357Fundtion to call before exiting pb so cleanup is done
358
359=cut
360
361sub pb_exit {
362
363my $ret = shift || 0;
364pb_log(0,"Please remove manually $ENV{'PBTMP'} after debug analysis\n") if ($pbdebug > 1);
365exit($ret);
366}
367
368=item B<pb_syntax_init>
369
370This function initializes the global variable used by the pb_syntax function.
371
372The parameter is the message string which will be printed when calling pb_syntax
373
374=cut
375
376sub pb_syntax_init {
377
378$pbsynmsg = shift || "Error";
379}
380
381=item B<pb_syntax>
382
383This function prints the syntax expected by the application, based on pod2usage, and exits.
384The first parameter is the return value of the exit.
385The second parameter is the verbosity as expected by pod2usage.
386
387Cf: man Pod::Usage
388
389=cut
390
391sub pb_syntax {
392
393my $exit_status = shift;
394my $verbose_level = shift;
395
396my $filehandle = \*STDERR;
397
398# Don't do it upper as before as when the value is 0
399# it is considered false and then exit was set to -1
400$exit_status = -1 if (not defined $exit_status);
401$verbose_level = 0 if (not defined $verbose_level);
402
403$filehandle = \*STDOUT if ($exit_status == 0);
404
405eval {
406    require Pod::Usage;
407    Pod::Usage->import();
408};
409if ($@) {
410    # No Pod::Usage found not printing usage. Old perl only
411    pb_exit();
412} else {
413    pod2usage(  -message => $pbsynmsg,
414            -exitval => $exit_status,
415            -verbose => $verbose_level,
416            -output  => $filehandle );
417}
418}
419
420=item B<pb_temp_init>
421
422This 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.
423
424=cut
425
426sub pb_temp_init {
427
428if (not defined $ENV{'TMPDIR'}) {
429    $ENV{'TMPDIR'}="/tmp";
430}
431
432# Makes this function compatible with perl 5.005x
433eval {
434    require File::Temp;
435    File::Temp->import("tempdir");
436};
437if ($@) {
438    # File::Temp not found, harcoding stuff
439    # Inspired by http://cpansearch.perl.org/src/TGUMMELS/File-MkTemp-1.0.6/File/MkTemp.pm
440    # Copyright 1999|2000 Travis Gummels.  All rights reserved. 
441    # This may be used and modified however you want.
442    my $template = "pb.XXXXXXXXXX";
443    my @template = split //, $template;
444    my @letters = split(//,"1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ");
445    for (my $i = $#template; $i >= 0 && ($template[$i] eq 'X'); $i--){
446        $template[$i] = $letters[int(rand 52)];
447    }
448    undef $template;
449    $template = pack "a" x @template, @template;
450    pb_mkdir_p("$ENV{'TMPDIR'}/$template");
451} else {
452    if ($pbdebug > 1) {
453        $ENV{'PBTMP'} = tempdir( "pb.XXXXXXXXXX", DIR => $ENV{'TMPDIR'});
454        pb_log(2,"DEBUG: Creating a non-volatile temporary directory ($ENV{'PBTMP'})\n");
455    } else {
456        $ENV{'PBTMP'} = tempdir( "pb.XXXXXXXXXX", DIR => $ENV{'TMPDIR'}, CLEANUP => 1 );
457    }
458}
459}
460
461=item B<pb_get_osrelease>
462
463This function returns the release of our operating system
464
465=cut
466
467sub pb_get_osrelease {
468
469# On linux can also use /proc/sys/kernel/osrelease
470my $rel = `uname -r`;
471chomp($rel);
472return($rel);
473}
474
475
476=item B<pb_get_arch>
477
478This function returns the architecture of our local environment and
479standardize on i386 for those platforms.
480
481=cut
482
483sub pb_get_arch {
484
485my $arch = `uname -m`;
486chomp($arch);
487$arch =~ s/i[3456]86/i386/;
488# For Solaris
489$arch =~ s/i86pc/i386/;
490
491return($arch);
492}
493
494=item B<pb_check_requirements>
495
496This function checks that the commands needed for the subsystem are indeed present.
497The required commands are passed as a comma separated string as first parameter.
498The optional commands are passed as a comma separated string as second parameter.
499
500=cut
501
502sub pb_check_requirements {
503
504my $req = shift || undef;
505my $opt = shift || undef;
506my $appname = shift || undef;
507
508my ($req2,$opt2) = (undef,undef);
509$req2 = $req->{$appname} if (defined $req and defined $appname);
510$opt2 = $opt->{$appname} if (defined $opt and defined $appname);
511
512# cmds is a string of comma separated commands
513if (defined $req2) {
514    foreach my $file (split(/,/,$req2)) {
515        pb_check_req($file,0);
516    }
517}
518
519# opts is a string of comma separated commands
520if (defined $opt2) {
521    foreach my $file (split(/,/,$opt2)) {
522        pb_check_req($file,1);
523    }
524}
525}
526
527=item B<pb_check_req>
528
529This function checks existence of a command and return its full pathname or undef if not found.
530The command name is passed as first parameter.
531The second parameter should be 0 if the command is mandatory, 1 if optional.
532
533=cut
534
535sub pb_check_req {
536
537my $file = shift;
538my $opt = shift;
539my $found = undef;
540
541$opt = 1 if (not defined $opt);
542
543pb_log(2,"Checking availability of $file...");
544# Check for all dirs in the PATH
545foreach my $p (split(/:/,$ENV{'PATH'})) {
546    if (-x "$p/$file") {
547        $found =  "$p/$file";
548        last;
549    }
550}
551
552if (not $found) {
553    pb_log(2,"KO\n");
554    if ($opt eq 1) {
555        pb_log(2,"Unable to find optional command $file\n");
556    } else {
557        die pb_log(0,"Unable to find required command $file\n");
558    }
559} else {
560    pb_log(2,"OK\n");
561}
562return($found);
563}
564
565=item B<pb_path_expand>
566
567Expand out a path by environment variables as ($ENV{XXX}) and ~
568
569=cut
570
571sub pb_path_expand {
572
573my $path = shift;
574
575eval { $path =~ s/(\$ENV.+\})/$1/eeg; };
576$path =~ s/^\~/$ENV{HOME}/;
577
578return($path);
579}
580
581=back
582
583=head1 WEB SITES
584
585The 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/>.
586
587=head1 USER MAILING LIST
588
589None exists for the moment.
590
591=head1 AUTHORS
592
593The Project-Builder.org team L<http://trac.project-builder.org/> lead by Bruno Cornec L<mailto:bruno@project-builder.org>.
594
595=head1 COPYRIGHT
596
597Project-Builder.org is distributed under the GPL v2.0 license
598described in the file C<COPYING> included with the distribution.
599
600=cut
601
6021;
Note: See TracBrowser for help on using the repository browser.