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

Last change on this file since 1077 was 1077, checked in by bruno, 9 years ago

r3961@localhost: bruno | 2010-07-22 22:39:23 +0200

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