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

Last change on this file since 1651 was 1651, checked in by bruno, 7 years ago
  • Avoid to emit msgs when sed -i doesn't work (as on RedHat? 6.2)
  • Factorize the proxy usages in pb_apply_conf_proxy and make it public (was partly done only)
  • debug level is now passed to the vescrip improving debug capabilities in that script
  • /dev/null shouldn't be touched on RedHat? 6.2 as recreating it doesn't seem to work
  • Allow usage of mayfailverbose in pb_system when both features are needed to help debuging
  • Imrpove again RedHat? 6.2 support up to setupve now (however needs a manual install of perl 5.6.2 to work as the minimum version for pb)
File size: 14.8 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 $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
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") if ((-f "$ENV{'PBTMP'}/system.$$.log") and (defined $verbose) 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") 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") 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 print 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.
294
295This is a cat equivalent function.
296
297=cut
298
299sub pb_display_file {
300
301my $file=shift;
302my $desc=shift || undef;
303
304return if (not -f $file);
305my $cnt = pb_get_content($file);
306print "$cnt\n";
307print $desc "$cnt\n" if (defined $desc);
308}
309
310=item B<pb_get_content>
311
312This function returns the content of the file passed in parameter.
313
314=cut
315
316sub pb_get_content {
317
318my $file=shift;
319
320my $bkp = $/;
321undef $/;
322open(R,$file) || die "Unable to open $file: $!";
323my $content=<R>;
324close(R);
325chomp($content);
326$/ = $bkp;
327return($content);
328}
329
330
331=item B<pb_set_content>
332
333This function put the content of a variable passed as second parameter into the file passed as first parameter.
334
335=cut
336
337sub pb_set_content {
338
339my $file=shift;
340my $content=shift;
341
342my $bkp = $/;
343undef $/;
344open(R,"> $file") || die "Unable to write to $file: $!";
345print R "$content";
346close(R);
347$/ = $bkp;
348}
349
350=item B<pb_syntax_init>
351
352This function initializes the global variable used by the pb_syntax function.
353
354The parameter is the message string which will be printed when calling pb_syntax
355
356=cut
357
358sub pb_syntax_init {
359
360$pbsynmsg = shift || "Error";
361}
362
363=item B<pb_syntax>
364
365This function prints the syntax expected by the application, based on pod2usage, and exits.
366The first parameter is the return value of the exit.
367The second parameter is the verbosity as expected by pod2usage.
368
369Cf: man Pod::Usage
370
371=cut
372
373sub pb_syntax {
374
375my $exit_status = shift;
376my $verbose_level = shift;
377
378my $filehandle = \*STDERR;
379
380# Don't do it upper as before as when the value is 0
381# it is considered false and then exit was set to -1
382$exit_status = -1 if (not defined $exit_status);
383$verbose_level = 0 if (not defined $verbose_level);
384
385$filehandle = \*STDOUT if ($exit_status == 0);
386
387eval {
388    require Pod::Usage;
389    Pod::Usage->import();
390};
391if ($@) {
392    # No Pod::Usage found not printing usage. Ole perl only
393} else {
394    pod2usage(  -message => $pbsynmsg,
395            -exitval => $exit_status,
396            -verbose => $verbose_level,
397            -output  => $filehandle );
398}
399}
400
401=item B<pb_temp_init>
402
403This 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.
404
405=cut
406
407sub pb_temp_init {
408
409if (not defined $ENV{'TMPDIR'}) {
410    $ENV{'TMPDIR'}="/tmp";
411}
412
413# Makes this function compatible with perl 5.005x
414eval {
415    require File::Temp;
416    File::Temp->import("tempdir");
417};
418if ($@) {
419    # File::Temp not found, harcoding stuff
420    # Inspired by http://cpansearch.perl.org/src/TGUMMELS/File-MkTemp-1.0.6/File/MkTemp.pm
421    # Copyright 1999|2000 Travis Gummels.  All rights reserved. 
422    # This may be used and modified however you want.
423    my $template = "pb.XXXXXXXXXX";
424    my @template = split //, $template;
425    my @letters = split(//,"1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ");
426    for (my $i = $#template; $i >= 0 && ($template[$i] eq 'X'); $i--){
427        $template[$i] = $letters[int(rand 52)];
428    }
429    undef $template;
430    $template = pack "a" x @template, @template;
431    pb_mkdir_p("$ENV{'TMPDIR'}/$template");
432} else {
433    $ENV{'PBTMP'} = tempdir( "pb.XXXXXXXXXX", DIR => $ENV{'TMPDIR'}, CLEANUP => 1 );
434}
435}
436
437=item B<pb_get_osrelease>
438
439This function returns the release of our operating system
440
441=cut
442
443sub pb_get_osrelease {
444
445# On linux can also use /proc/sys/kernel/osrelease
446my $rel = `uname -r`;
447chomp($rel);
448return($rel);
449}
450
451
452=item B<pb_get_arch>
453
454This function returns the architecture of our local environment and
455standardize on i386 for those platforms. It also solves issues where a i386 VE on x86_64 returns x86_64 wrongly
456
457=cut
458
459sub pb_get_arch {
460
461my $arch = `uname -m`;
462chomp($arch);
463$arch =~ s/i[3456]86/i386/;
464# For Solaris
465$arch =~ s/i86pc/i386/;
466
467return($arch);
468}
469
470=item B<pb_check_requirements>
471
472This function checks that the commands needed for the subsystem are indeed present.
473The required commands are passed as a comma separated string as first parameter.
474The optional commands are passed as a comma separated string as second parameter.
475
476=cut
477
478sub pb_check_requirements {
479
480my $req = shift || undef;
481my $opt = shift || undef;
482my $appname = shift || undef;
483
484my ($req2,$opt2) = (undef,undef);
485$req2 = $req->{$appname} if (defined $req and defined $appname);
486$opt2 = $opt->{$appname} if (defined $opt and defined $appname);
487
488# cmds is a string of comma separated commands
489if (defined $req2) {
490    foreach my $file (split(/,/,$req2)) {
491        pb_check_req($file,0);
492    }
493}
494
495# opts is a string of comma separated commands
496if (defined $opt2) {
497    foreach my $file (split(/,/,$opt2)) {
498        pb_check_req($file,1);
499    }
500}
501}
502
503=item B<pb_check_req>
504
505This function checks existence of a command and return its full pathname or undef if not found.
506The command name is passed as first parameter.
507The second parameter should be 0 if the command is mandatory, 1 if optional.
508
509=cut
510
511sub pb_check_req {
512
513my $file = shift;
514my $opt = shift;
515my $found = undef;
516
517$opt = 1 if (not defined $opt);
518
519pb_log(2,"Checking availability of $file...");
520# Check for all dirs in the PATH
521foreach my $p (split(/:/,$ENV{'PATH'})) {
522    if (-x "$p/$file") {
523        $found =  "$p/$file";
524        last;
525    }
526}
527
528if (not $found) {
529    pb_log(2,"KO\n");
530    if ($opt eq 1) {
531        pb_log(2,"Unable to find optional command $file\n");
532    } else {
533        die pb_log(0,"Unable to find required command $file\n");
534    }
535} else {
536    pb_log(2,"OK\n");
537}
538return($found);
539}
540
541=item B<pb_path_expand>
542
543Expand out a path by environment variables as ($ENV{XXX}) and ~
544
545=cut
546
547sub pb_path_expand {
548
549my $path = shift;
550
551eval { $path =~ s/(\$ENV.+\})/$1/eeg; };
552$path =~ s/^\~/$ENV{HOME}/;
553
554return($path);
555}
556
557=back
558
559=head1 WEB SITES
560
561The 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/>.
562
563=head1 USER MAILING LIST
564
565None exists for the moment.
566
567=head1 AUTHORS
568
569The Project-Builder.org team L<http://trac.project-builder.org/> lead by Bruno Cornec L<mailto:bruno@project-builder.org>.
570
571=head1 COPYRIGHT
572
573Project-Builder.org is distributed under the GPL v2.0 license
574described in the file C<COPYING> included with the distribution.
575
576=cut
577
5781;
Note: See TracBrowser for help on using the repository browser.