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

Last change on this file since 1518 was 1518, checked in by bruno, 7 years ago
  • Base.pm: Don't display the error message if failure is ok. Simplify cluck + exit to confess. (Eric Anderson)
  • Env.pm: We are in a "", so escape the \'s. (Eric Anderson)
File size: 13.3 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-2008
7# Provided under the GPL v2
8#
9# $Id$
10#
11
12package ProjectBuilder::Base;
13
14use strict;
15use lib qw (lib);
16use Carp qw/confess cluck/;
17use Cwd;
18use File::Path;
19use File::Temp qw(tempdir);
20use Data::Dumper;
21use Time::localtime qw(localtime);
22use Pod::Usage;
23use English;
24use POSIX qw(locale_h);
25use ProjectBuilder::Version;
26
27# Inherit from the "Exporter" module which handles exporting functions.
28 
29use vars qw($VERSION $REVISION @ISA @EXPORT);
30use Exporter;
31 
32# Export, by default, all the functions into the namespace of
33# any code which uses this module.
34 
35our $pbdebug = 0;       # Global debug level
36our $pbLOG = \*STDOUT;  # File descriptor of the log file
37our $pbsynmsg = "Error";    # Global error message
38our $pbdisplaytype = "text";
39                        # default display mode for messages
40our $pblocale = "C";
41
42our @ISA = qw(Exporter);
43our @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);
44($VERSION,$REVISION) = pb_version_init();
45
46=pod
47
48=head1 NAME
49
50ProjectBuilder::Base, part of the project-builder.org - module dealing with generic functions suitable for perl project development
51
52=head1 DESCRIPTION
53
54This module provides generic functions suitable for perl project development
55
56=head1 SYNOPSIS
57
58  use ProjectBuilder::Base;
59
60  #
61  # Create a directory and its parents
62  #
63  pb_mkdir_p("/tmp/foo/bar");
64
65  #
66  # Remove recursively a directory and its children
67  #
68  pb_rm_rf("/tmp/foo");
69
70  #
71  # Encapsulate the system call for better output and return value test
72  #
73  pb_system("ls -l", "Printing directory content");
74
75  #
76  # Analysis a URI and return its components in a table
77  #
78  my ($scheme, $account, $host, $port, $path) = pb_get_uri("svn+ssh://ac@my.server.org:port/path/to/dir");
79
80  #
81  # Gives the current date in a table
82  #
83  @date = pb_get_date();
84
85  #
86  # Manages logs of the program
87  #
88  pb_log_init(2,\*STDOUT);
89  pb_log(1,"Message to print\n");
90
91  #
92  # Manages content of a file
93  #
94  pb_display_file("/etc/passwd",\*STDERR);
95  my $cnt = pb_get_content("/etc/passwd");
96
97=head1 USAGE
98
99=over 4
100
101=item B<pb_mkdir_p>
102
103Internal mkdir -p function. Forces mode to 755. Supports multiple parameters.
104
105Based on File::Path mkpath.
106
107=cut
108
109sub pb_mkdir_p {
110my @dir = @_;
111my $ret = eval { mkpath(@dir, 0, 0755) };
112confess "pb_mkdir_p @dir failed in ".getcwd().": $@" if ($@);
113return($ret);
114}
115
116=item B<pb_rm_rf>
117
118Internal rm -rf function. Supports multiple parameters.
119
120Based on File::Path rmtree.
121
122=cut
123
124sub pb_rm_rf {
125my @dir = @_;
126my $ret = rmtree(@dir, 0, 0);
127return($ret);
128}
129
130=item B<pb_system>
131
132Encapsulate the "system" call for better output and return value test.
133Needs a $ENV{'PBTMP'} variable which is created by calling the pb_mktemp_init function.
134Needs pb_log support, so pb_log_init should have been called before.
135
136The first parameter is the shell command to call. This command should NOT use redirections.
137The second parameter is the message to print on screen. If none is given, then the command is printed.
138The third parameter print 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.
139The fourth parameter determines whether 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 $failure_ok = shift || 0;
152my $redir = "";
153
154pb_log(0,"$cmt... ") if ((! defined $verbose) || ($verbose ne "quiet"));
155pb_log(1,"Executing $cmd\n");
156unlink("$ENV{'PBTMP'}/system.$$.log") if (-f "$ENV{'PBTMP'}/system.$$.log");
157$redir = "2>> $ENV{'PBTMP'}/system.$$.log 1>> $ENV{'PBTMP'}/system.$$.log" if ((! defined $verbose) || ($verbose ne "noredir"));
158
159# If sudo used, then be more verbose
160pb_log(0,"Executing $cmd\n") if (($pbdebug < 1) && ($cmd =~ /^\s*\S*sudo/o));
161
162system("$cmd $redir");
163my $res = $?;
164# Exit now if the command may fail
165if ((defined $verbose) and ($verbose eq "mayfail")) {
166    pb_log(0,"N/A\n") if ($res != 0);
167    pb_log(0,"OK\n") if ($res == 0);
168    return($res) 
169    }
170
171my $cwd = getcwd;
172my $error = undef;
173$error = "failed to execute ($cmd) in $cwd: $!\n" if ($res == -1);
174$error = "child ($cmd) died with signal ".($res & 127).", ".($res & 128) ? 'with' : 'without'." coredump\n" if ($res & 127);
175$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 && ! $failure_ok));
179    pb_display_file("$ENV{'PBTMP'}/system.$$.log") if ((-f "$ENV{'PBTMP'}/system.$$.log") and ((! defined $verbose) || ($verbose ne "quiet") || $Global::pb_stop_on_error));
180    if (($Global::pb_stop_on_error) && (! $failure_ok)) {
181        confess "error running command ($cmd) with cwd=$cwd, pid=$$";
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;
281my $msg = shift;
282
283print $pbLOG "$msg" if ($dlevel <= $pbdebug);
284print "$msg" if (($dlevel == 0) && ($pbLOG != \*STDOUT));
285}
286
287
288=item B<pb_display_file>
289
290This function print the content of the file passed in parameter.
291If a second parameter is given, this is the descriptor of the logfile to write to in addtion to STDOUT.
292
293This is a cat equivalent function.
294
295=cut
296
297sub pb_display_file {
298
299my $file=shift;
300my $desc=shift || undef;
301
302return if (not -f $file);
303my $cnt = pb_get_content($file);
304print "$cnt\n";
305print $desc "$cnt\n" if (defined $desc);
306}
307
308=item B<pb_get_content>
309
310This function returns the content of the file passed in parameter.
311
312=cut
313
314sub pb_get_content {
315
316my $file=shift;
317
318my $bkp = $/;
319undef $/;
320open(R,$file) || die "Unable to open $file: $!";
321my $content=<R>;
322close(R);
323chomp($content);
324$/ = $bkp;
325return($content);
326}
327
328
329=item B<pb_set_content>
330
331This function put the content of a variable passed as second parameter into the file passed as first parameter.
332
333=cut
334
335sub pb_set_content {
336
337my $file=shift;
338my $content=shift;
339
340my $bkp = $/;
341undef $/;
342open(R,"> $file") || die "Unable to write to $file: $!";
343print R "$content";
344close(R);
345$/ = $bkp;
346}
347
348=item B<pb_syntax_init>
349
350This function initializes the global variable used by the pb_syntax function.
351
352The parameter is the message string which will be printed when calling pb_syntax
353
354=cut
355
356sub pb_syntax_init {
357
358$pbsynmsg = shift || "Error";
359}
360
361=item B<pb_syntax>
362
363This function prints the syntax expected by the application, based on pod2usage, and exits.
364The first parameter is the return value of the exit.
365The second parameter is the verbosity as expected by pod2usage.
366
367Cf: man Pod::Usage
368
369=cut
370
371sub pb_syntax {
372
373my $exit_status = shift || -1;
374my $verbose_level = shift || 0;
375
376my $filehandle = \*STDERR;
377
378$filehandle = \*STDOUT if ($exit_status == 0);
379
380pod2usage( { -message => $pbsynmsg,
381             -exitval => $exit_status  ,
382             -verbose => $verbose_level,
383             -output  => $filehandle } );
384}
385
386=item B<pb_temp_init>
387
388This 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.
389
390=cut
391
392sub pb_temp_init {
393
394if (not defined $ENV{'TMPDIR'}) {
395    $ENV{'TMPDIR'}="/tmp";
396}
397$ENV{'PBTMP'} = tempdir( "pb.XXXXXXXXXX", DIR => $ENV{'TMPDIR'}, CLEANUP => 1 );
398}
399
400=item B<pb_get_osrelease>
401
402This function returns the release of our operating system
403
404=cut
405
406sub pb_get_osrelease {
407
408# On linux can also use /proc/sys/kernel/osrelease
409my $rel = `uname -r`;
410chomp($rel);
411return($rel);
412}
413
414
415=item B<pb_get_arch>
416
417This function returns the architecture of our local environment and
418standardize on i386 for those platforms. It also solves issues where a i386 VE on x86_64 returns x86_64 wrongly
419
420=cut
421
422sub pb_get_arch {
423
424my $arch = `uname -m`;
425chomp($arch);
426$arch =~ s/i.86/i386/;
427# For Solaris
428$arch =~ s/i86pc/i386/;
429
430return($arch);
431}
432
433=item B<pb_check_requirements>
434
435This function checks that the commands needed for the subsystem are indeed present.
436The required commands are passed as a coma separated string as first parameter.
437The optional commands are passed as a coma separated string as second parameter.
438
439=cut
440
441sub pb_check_requirements {
442
443my $req = shift || undef;
444my $opt = shift || undef;
445my $appname = shift || undef;
446
447my ($req2,$opt2) = (undef,undef);
448$req2 = $req->{$appname} if (defined $req and defined $appname);
449$opt2 = $opt->{$appname} if (defined $opt and defined $appname);
450
451# cmds is a string of coma separated commands
452if (defined $req2) {
453    foreach my $file (split(/,/,$req2)) {
454        pb_check_req($file,0);
455    }
456}
457
458# opts is a string of coma separated commands
459if (defined $opt2) {
460    foreach my $file (split(/,/,$opt2)) {
461        pb_check_req($file,1);
462    }
463}
464}
465
466=item B<pb_check_req>
467
468This function checks existence of a command and return its full pathname or undef if not found.
469The command name is passed as first parameter.
470The second parameter should be 0 if the command is mandatory, 1 if optional.
471
472=cut
473
474sub pb_check_req {
475
476my $file = shift;
477my $opt = shift || 1;
478my $found = undef;
479
480pb_log(2,"Checking availability of $file...");
481# Check for all dirs in the PATH
482foreach my $p (split(/:/,$ENV{'PATH'})) {
483    if (-x "$p/$file") {
484        $found =  "$p/$file";
485        last;
486    }
487}
488
489if (not $found) {
490    pb_log(2,"KO\n");
491    if ($opt eq 1) {
492        pb_log(2,"Unable to find optional command $file\n");
493    } else {
494        die pb_log(0,"Unable to find required command $file\n");
495    }
496} else {
497    pb_log(2,"OK\n");
498}
499return($found);
500}
501
502=item B<pb_path_expand>
503
504Expand out a path by environment variables as ($ENV{XXX}) and ~
505
506=cut
507
508sub pb_path_expand {
509
510my $path = shift;
511
512eval { $path =~ s/(\$ENV.+\})/$1/eeg; };
513$path =~ s/^\~/$ENV{HOME}/;
514
515return($path);
516}
517
518=back
519
520=head1 WEB SITES
521
522The 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/>.
523
524=head1 USER MAILING LIST
525
526None exists for the moment.
527
528=head1 AUTHORS
529
530The Project-Builder.org team L<http://trac.project-builder.org/> lead by Bruno Cornec L<mailto:bruno@project-builder.org>.
531
532=head1 COPYRIGHT
533
534Project-Builder.org is distributed under the GPL v2.0 license
535described in the file C<COPYING> included with the distribution.
536
537=cut
538
5391;
Note: See TracBrowser for help on using the repository browser.