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

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