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

Last change on this file since 1433 was 1433, checked in by bruno, 7 years ago

r4570@cabanilles: bruno | 2012-03-15 14:21:23 +0100

  • Improve return value documentation of pb_check_req
File size: 12.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-2008
7# Provided under the GPL v2
8#
9# $Id$
10#
11
12package ProjectBuilder::Base;
13
14use strict;
15use lib qw (lib);
16use File::Path;
17use File::Temp qw(tempdir);
18use Data::Dumper;
19use Time::localtime qw(localtime);
20use Pod::Usage;
21use English;
22use POSIX qw(locale_h);
23use ProjectBuilder::Version;
24
25# Inherit from the "Exporter" module which handles exporting functions.
26 
27use vars qw($VERSION $REVISION @ISA @EXPORT);
28use Exporter;
29 
30# Export, by default, all the functions into the namespace of
31# any code which uses this module.
32 
33our $pbdebug = 0;       # Global debug level
34our $pbLOG = \*STDOUT;  # File descriptor of the log file
35our $pbsynmsg = "Error";    # Global error message
36our $pbdisplaytype = "text";
37                        # default display mode for messages
38our $pblocale = "C";
39
40our @ISA = qw(Exporter);
41our @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 $pbdebug $pbLOG $pbdisplaytype $pblocale);
42($VERSION,$REVISION) = pb_version_init();
43
44=pod
45
46=head1 NAME
47
48ProjectBuilder::Base, part of the project-builder.org - module dealing with generic functions suitable for perl project development
49
50=head1 DESCRIPTION
51
52This module provides generic functions suitable for perl project development
53
54=head1 SYNOPSIS
55
56  use ProjectBuilder::Base;
57
58  #
59  # Create a directory and its parents
60  #
61  pb_mkdir_p("/tmp/foo/bar");
62
63  #
64  # Remove recursively a directory and its children
65  #
66  pb_rm_rf("/tmp/foo");
67
68  #
69  # Encapsulate the system call for better output and return value test
70  #
71  pb_system("ls -l", "Printing directory content");
72
73  #
74  # Analysis a URI and return its components in a table
75  #
76  my ($scheme, $account, $host, $port, $path) = pb_get_uri("svn+ssh://ac@my.server.org:port/path/to/dir");
77
78  #
79  # Gives the current date in a table
80  #
81  @date = pb_get_date();
82
83  #
84  # Manages logs of the program
85  #
86  pb_log_init(2,\*STDOUT);
87  pb_log(1,"Message to print\n");
88
89  #
90  # Manages content of a file
91  #
92  pb_display_file("/etc/passwd",\*STDERR);
93  my $cnt = pb_get_content("/etc/passwd");
94
95=head1 USAGE
96
97=over 4
98
99=item B<pb_mkdir_p>
100
101Internal mkdir -p function. Forces mode to 755. Supports multiple parameters.
102
103Based on File::Path mkpath.
104
105=cut
106
107sub pb_mkdir_p {
108my @dir = @_;
109my $ret = mkpath(@dir, 0, 0755);
110return(0);
111}
112
113=item B<pb_rm_rf>
114
115Internal rm -rf function. Supports multiple parameters.
116
117Based on File::Path rmtree.
118
119=cut
120
121sub pb_rm_rf {
122my @dir = @_;
123my $ret = rmtree(@dir, 0, 0);
124return($ret);
125}
126
127=item B<pb_system>
128
129Encapsulate the "system" call for better output and return value test
130Needs a $ENV{'PBTMP'} variable which is created by calling the pb_mktemp_init function
131Needs pb_log support, so pb_log_init should have benn called before.
132
133The first parameter is the shell command to call. this commend should NOT use redirections.
134The second parameter is the message to print on screen. If none is given, then the command is printed.
135The 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).
136This function returns the result the return value of the system command.
137
138If no error reported, it prints OK on the screen, just after the message. Else it prints the errors generated.
139
140=cut
141
142sub pb_system {
143
144my $cmd=shift;
145my $cmt=shift || $cmd;
146my $verbose=shift || undef;
147my $redir = "";
148
149pb_log(0,"$cmt... ") if ((! defined $verbose) || ($verbose ne "quiet"));
150pb_log(1,"Executing $cmd\n");
151unlink("$ENV{'PBTMP'}/system.$$.log") if (-f "$ENV{'PBTMP'}/system.$$.log");
152$redir = "2>> $ENV{'PBTMP'}/system.$$.log 1>> $ENV{'PBTMP'}/system.$$.log" if ((! defined $verbose) || ($verbose ne "noredir"));
153system("$cmd $redir");
154my $res = $?;
155# Exit now if the command may fail
156if ((defined $verbose) and ($verbose eq "mayfail")) {
157    pb_log(0,"N/A\n") if ($res != 0);
158    pb_log(0,"OK\n") if ($res == 0);
159    return($res) 
160    }
161if ($res == -1) {
162    pb_log(0,"failed to execute ($cmd): $!\n") if ((! defined $verbose) || ($verbose ne "quiet"));
163    pb_display_file("$ENV{'PBTMP'}/system.$$.log") if ((-f "$ENV{'PBTMP'}/system.$$.log") and ((! defined $verbose) || ($verbose ne "quiet")));
164} elsif ($res & 127) {
165    pb_log(0, "child ($cmd) died with signal ".($? & 127).", ".($? & 128) ? 'with' : 'without'." coredump\n") if ((! defined $verbose) || ($verbose ne "quiet"));
166    pb_display_file("$ENV{'PBTMP'}/system.$$.log") if ((-f "$ENV{'PBTMP'}/system.$$.log") and ((! defined $verbose) || ($verbose ne "quiet")));
167} elsif ($res == 0) {
168    pb_log(0,"OK\n") if ((! defined $verbose) || ($verbose ne "quiet"));
169    pb_display_file("$ENV{'PBTMP'}/system.$$.log") if ((defined $verbose) and (-f "$ENV{'PBTMP'}/system.$$.log") and ($verbose ne "quiet"));
170} else {
171    pb_log(0, "child ($cmd) exited with value ".($? >> 8)."\n") if ((! defined $verbose) || ($verbose ne "quiet"));
172    pb_display_file("$ENV{'PBTMP'}/system.$$.log") if ((-f "$ENV{'PBTMP'}/system.$$.log") and ((! defined $verbose) || ($verbose ne "quiet")));
173}
174return($res);
175}
176
177=item B<pb_get_uri>
178
179This function returns a list of 6 parameters indicating the protocol, account, password, server, port, and path contained in the URI passed in parameter.
180
181A URI has the format protocol://[ac@]host[:port][path[?query][#fragment]].
182
183Cf man URI.
184
185=cut
186
187sub pb_get_uri {
188
189my $uri = shift || undef;
190
191pb_log(2,"DEBUG: uri:$uri\n");
192my ($scheme, $authority, $path, $query, $fragment) =
193         $uri =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?| if (defined $uri);
194my ($account,$host,$port) = $authority =~ m|(?:([^\@]+)\@)?([^:]+)(:(?:[0-9]+))?| if (defined $authority);
195
196$scheme = "" if (not defined $scheme);
197$authority = "" if (not defined $authority);
198$path = "" if (not defined $path);
199$account = "" if (not defined $account);
200$host = "" if (not defined $host);
201if (not defined $port) {
202    $port = "" 
203} else {
204    # Remove extra : at start
205    $port =~ s/^://;
206}
207
208pb_log(2,"DEBUG: scheme:$scheme ac:$account host:$host port:$port path:$path\n");
209return($scheme, $account, $host, $port, $path);
210}
211
212=item B<pb_get_date>
213
214This 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.
215
216Cf: man ctime and description of the struct tm.
217
218=cut
219
220sub pb_get_date {
221   
222return(localtime->sec(), localtime->min(), localtime->hour(), localtime->mday(), localtime->mon(), localtime->year(), localtime->wday(), localtime->yday(), localtime->isdst());
223}
224
225=item B<pb_log_init>
226
227This function initializes the global variables used by the pb_log function.
228
229The first parameter is the debug level which will be considered during the run of the program?
230The second parameter is a pointer on a file descriptor used to print the log info.
231
232As 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.
233
234The call to B<pb_log_init> is typically done after getting a parameter on the CLI indicating the level of verbosity expected.
235
236=cut
237
238sub pb_log_init {
239
240$pbdebug = shift || 0;
241$pbLOG = shift || \*STDOUT;
242pb_log(1,"Debug value: $pbdebug\n");
243
244} 
245
246=item B<pb_log>
247
248This 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.
249
250Here is a usage example:
251
252  pb_log_init(2,\*STDERR);
253  pb_log(1,"Hello World 1\n");
254  pb_log(2,"Hello World 2\n");
255  pb_log(3,"Hello World 3\n");
256
257  will print:
258 
259  Hello World 1
260  Hello World 2
261
262=cut 
263
264sub pb_log {
265
266my $dlevel = shift;
267my $msg = shift;
268
269print $pbLOG "$msg" if ($dlevel <= $pbdebug);
270print "$msg" if (($dlevel == 0) && ($pbLOG != \*STDOUT));
271}
272
273
274=item B<pb_display_file>
275
276This function print the content of the file passed in parameter.
277If a second parameter is given, this is the descriptor of the logfile to write to in addtion to STDOUT.
278
279This is a cat equivalent function.
280
281=cut
282
283sub pb_display_file {
284
285my $file=shift;
286my $desc=shift || undef;
287
288return if (not -f $file);
289my $cnt = pb_get_content($file);
290print "$cnt\n";
291print $desc "$cnt\n" if (defined $desc);
292}
293
294=item B<pb_get_content>
295
296This function returns the content of the file passed in parameter.
297
298=cut
299
300sub pb_get_content {
301
302my $file=shift;
303
304my $bkp = $/;
305undef $/;
306open(R,$file) || die "Unable to open $file: $!";
307my $content=<R>;
308close(R);
309chomp($content);
310$/ = $bkp;
311return($content);
312}
313
314
315=item B<pb_set_content>
316
317This function put the content of a variable passed as second parameter into the file passed as first parameter.
318
319=cut
320
321sub pb_set_content {
322
323my $file=shift;
324my $content=shift;
325
326my $bkp = $/;
327undef $/;
328open(R,"> $file") || die "Unable to write to $file: $!";
329print R "$content";
330close(R);
331$/ = $bkp;
332}
333
334=item B<pb_syntax_init>
335
336This function initializes the global variable used by the pb_syntax function.
337
338The parameter is the message string which will be printed when calling pb_syntax
339
340=cut
341
342sub pb_syntax_init {
343
344$pbsynmsg = shift || "Error";
345}
346
347=item B<pb_syntax>
348
349This function prints the syntax expected by the application, based on pod2usage, and exits.
350The first parameter is the return value of the exit.
351The second parameter is the verbosity as expected by pod2usage.
352
353Cf: man Pod::Usage
354
355=cut
356
357sub pb_syntax {
358
359my $exit_status = shift || -1;
360my $verbose_level = shift || 0;
361
362my $filehandle = \*STDERR;
363
364$filehandle = \*STDOUT if ($exit_status == 0);
365
366pod2usage( { -message => $pbsynmsg,
367             -exitval => $exit_status  ,
368             -verbose => $verbose_level,
369             -output  => $filehandle } );
370}
371
372=item B<pb_temp_init>
373
374This 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.
375
376=cut
377
378sub pb_temp_init {
379
380if (not defined $ENV{'TMPDIR'}) {
381    $ENV{'TMPDIR'}="/tmp";
382}
383$ENV{'PBTMP'} = tempdir( "pb.XXXXXXXXXX", DIR => $ENV{'TMPDIR'}, CLEANUP => 1 );
384}
385
386=item B<pb_get_osrelease>
387
388This function returns the release of our operating system
389
390=cut
391
392sub pb_get_osrelease {
393
394# On linux can also use /proc/sys/kernel/osrelease
395my $rel = `uname -r`;
396chomp($rel);
397return($rel);
398}
399
400
401=item B<pb_get_arch>
402
403This function returns the architecture of our local environment and
404standardize on i386 for those platforms. It also solves issues where a i386 VE on x86_64 returns x86_64 wrongly
405
406=cut
407
408sub pb_get_arch {
409
410my $arch = `uname -m`;
411chomp($arch);
412$arch =~ s/i.86/i386/;
413# For Solaris
414$arch =~ s/i86pc/i386/;
415
416return($arch);
417}
418
419=item B<pb_check_requirements>
420
421This function checks that the commands needed for the subsystem are indeed present.
422The required commands are passed as a coma separated string as first parameter.
423The optional commands are passed as a coma separated string as second parameter.
424
425=cut
426
427sub pb_check_requirements {
428
429my $req = shift || undef;
430my $opt = shift || undef;
431my $appname = shift || undef;
432
433my ($req2,$opt2) = (undef,undef);
434$req2 = $req->{$appname} if (defined $req and defined $appname);
435$opt2 = $opt->{$appname} if (defined $opt and defined $appname);
436
437# cmds is a string of coma separated commands
438if (defined $req2) {
439    foreach my $file (split(/,/,$req2)) {
440        pb_check_req($file,0);
441    }
442}
443
444# opts is a string of coma separated commands
445if (defined $opt2) {
446    foreach my $file (split(/,/,$opt2)) {
447        pb_check_req($file,1);
448    }
449}
450}
451
452=item B<pb_check_req>
453
454This function checks existence of a command and return its full pathname or undef if not found.
455The command name is passed as first parameter.
456The second parameter should be 0 if the command is mandatory, 1 if optional.
457
458=cut
459
460sub pb_check_req {
461
462my $file = shift;
463my $opt = shift || 1;
464my $found = undef;
465
466pb_log(2,"Checking availability of $file...");
467# Check for all dirs in the PATH
468foreach my $p (split(/:/,$ENV{'PATH'})) {
469    if (-x "$p/$file") {
470        $found =  "$p/$file";
471        last;
472    }
473}
474
475if (not $found) {
476    pb_log(2,"KO\n");
477    if ($opt eq 1) {
478        pb_log(2,"Unable to find optional command $file\n");
479    } else {
480        die pb_log(0,"Unable to find required command $file\n");
481    }
482} else {
483    pb_log(2,"OK\n");
484}
485return($found);
486}
487
488=back
489
490=head1 WEB SITES
491
492The 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/>.
493
494=head1 USER MAILING LIST
495
496None exists for the moment.
497
498=head1 AUTHORS
499
500The Project-Builder.org team L<http://trac.project-builder.org/> lead by Bruno Cornec L<mailto:bruno@project-builder.org>.
501
502=head1 COPYRIGHT
503
504Project-Builder.org is distributed under the GPL v2.0 license
505described in the file C<COPYING> included with the distribution.
506
507=cut
508
5091;
Note: See TracBrowser for help on using the repository browser.