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

Last change on this file was 2514, checked in by Bruno Cornec, 3 months ago

adds function pb_path_nbfiles to Base

File size: 16.2 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-today
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 croak/;
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(@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 pb_path_nbfiles pb_exit $pbdebug $pbLOG $pbdisplaytype $pblocale);
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 = eval { mkpath(@dir, 0, 0755) };
110confess "pb_mkdir_p @dir failed in ".getcwd().": $@" if ($@);
111return($ret);
112}
113
114=item B<pb_rm_rf>
115
116Internal rm -rf function. Supports multiple parameters.
117
118Based on File::Path rmtree.
119
120=cut
121
122sub pb_rm_rf {
123my @dir = @_;
124my $ret = rmtree(@dir, 0, 0);
125return($ret);
126}
127
128=item B<pb_system>
129
130Encapsulate the "system" call for better output and return value test.
131Needs a $ENV{'PBTMP'} variable which is created by calling the pb_mktemp_init function.
132Needs pb_log support, so pb_log_init should have been called before.
133
134The first parameter is the shell command to call. This command should NOT use redirections.
135The second parameter is the message to print on screen. If none is given, then the command is printed.
136The 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. If value is verbose_PREF, then every output command will be prefixed with PREF.
137This function returns as a result the return value of the system command.
138
139If no error reported, it prints OK on the screen, just after the message. Else it prints the errors generated.
140
141=cut
142
143sub pb_system {
144
145my $cmd=shift;
146my $cmt=shift || $cmd;
147my $verbose=shift;
148my $redir = "";
149
150pb_log(0,"$cmt... ") if ((! defined $verbose) || ($verbose ne "quiet"));
151pb_log(1,"Executing $cmd\n");
152
153croak('Please call pb_temp_init in your code before using pb_system') if (not defined "$ENV{'PBTMP'}");
154unlink("$ENV{'PBTMP'}/system.$$.log") if (-f "$ENV{'PBTMP'}/system.$$.log");
155$redir = "2>> $ENV{'PBTMP'}/system.$$.log 1>> $ENV{'PBTMP'}/system.$$.log" if ((! defined $verbose) || ($verbose ne "noredir"));
156
157# If sudo used, then be more verbose
158pb_log(0,"Executing $cmd\n") if (($pbdebug < 1) && ($cmd =~ /^\s*\S*sudo/o) && (defined $Global::pb_show_sudo) && ($Global::pb_show_sudo =~ /true/oi));
159
160system("$cmd $redir");
161my $res = $?;
162# Exit now if the command may fail
163if ((defined $verbose) and ($verbose =~ /mayfail/)) {
164    pb_log(0,"NOT OK but non blocking\n") if ($res != 0);
165    pb_log(0,"OK\n") if ($res == 0);
166    pb_display_file("$ENV{'PBTMP'}/system.$$.log",undef,$verbose) if ((-f "$ENV{'PBTMP'}/system.$$.log") and ($verbose =~ /verbose/));
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",undef,$verbose) 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=$$\n");
183    }
184} else {
185    pb_log(0,"OK\n") if ((! defined $verbose) || ($verbose ne "quiet"));
186    pb_display_file("$ENV{'PBTMP'}/system.$$.log",undef,$verbose) 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;
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;
256$pbLOG = shift;
257
258$pbdebug = 0 if (not defined $pbdebug);
259$pbLOG = \*STDOUT if (not defined $pbLOG);
260pb_log(1,"Debug value: $pbdebug\n");
261
262} 
263
264=item B<pb_log>
265
266This 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.
267
268Here is a usage example:
269
270  pb_log_init(2,\*STDERR);
271  pb_log(1,"Hello World 1\n");
272  pb_log(2,"Hello World 2\n");
273  pb_log(3,"Hello World 3\n");
274
275  will print:
276 
277  Hello World 1
278  Hello World 2
279
280=cut 
281
282sub pb_log {
283
284my $dlevel = shift;
285my $msg = shift;
286
287$dlevel = 0 if (not defined $dlevel);
288$msg = "" if (not defined $msg);
289$pbLOG = \*STDOUT if (not defined $pbLOG);
290
291print $pbLOG "$msg" if ($dlevel <= $pbdebug);
292print "$msg" if (($dlevel == 0) && ($pbLOG != \*STDOUT));
293}
294
295
296=item B<pb_display_file>
297
298This function prints the content of the file passed in parameter.
299If a second parameter is given, this is the descriptor of the logfile to write to in addtion to STDOUT.
300If a third parameter is given, this is the prefix providing it's writen as verbose_PREF. In which case the PREF string will be added before the line output.
301
302This is a cat equivalent function.
303
304=cut
305
306sub pb_display_file {
307
308my $file=shift;
309my $desc=shift;
310my $prefix=shift;
311
312return if (not -f $file);
313my $cnt = pb_get_content($file);
314# If we have a prefix, then add it at each line
315if ((defined $prefix) and ($prefix =~ "_")) {
316    $prefix =~ s/verbose_//;
317    $cnt =~ s/(.*)\n/$prefix$1\n/g;
318} else {
319    $prefix = "";
320}
321print "$prefix$cnt";
322print $desc "$prefix$cnt" if (defined $desc);
323}
324
325=item B<pb_get_content>
326
327This function returns the content of the file passed in parameter.
328
329=cut
330sub pb_get_content {
331
332my $file=shift;
333
334open(R,$file) || die "Unable to open $file: $!";
335local $/;
336my $content=<R>;
337close(R);
338return($content);
339}
340
341
342=item B<pb_set_content>
343
344This function put the content of a variable passed as second parameter into the file passed as first parameter.
345
346=cut
347
348sub pb_set_content {
349
350my $file=shift;
351my $content=shift;
352
353my $bkp = $/;
354undef $/;
355open(R,"> $file") || die "Unable to write to $file: $!";
356print R "$content";
357close(R);
358$/ = $bkp;
359}
360
361=item B<pb_exit>
362
363Fundtion to call before exiting pb so cleanup is done
364
365=cut
366
367sub pb_exit {
368
369my $ret = shift;
370$ret = 0 if (not defined $ret);
371pb_log(0,"Please remove manually $ENV{'PBTMP'} after debug analysis\n") if ($pbdebug > 1);
372exit($ret);
373}
374
375=item B<pb_syntax_init>
376
377This function initializes the global variable used by the pb_syntax function.
378
379The parameter is the message string which will be printed when calling pb_syntax
380
381=cut
382
383sub pb_syntax_init {
384
385$pbsynmsg = shift || "Error";
386}
387
388=item B<pb_syntax>
389
390This function prints the syntax expected by the application, based on pod2usage, and exits.
391The first parameter is the return value of the exit.
392The second parameter is the verbosity as expected by pod2usage.
393
394Cf: man Pod::Usage
395
396=cut
397
398sub pb_syntax {
399
400my $exit_status = shift;
401my $verbose_level = shift;
402
403my $filehandle = \*STDERR;
404
405# Don't do it upper as before as when the value is 0
406# it is considered false and then exit was set to -1
407$exit_status = -1 if (not defined $exit_status);
408$verbose_level = 0 if (not defined $verbose_level);
409
410$filehandle = \*STDOUT if ($exit_status == 0);
411
412eval {
413    require Pod::Usage;
414    Pod::Usage->import();
415};
416if ($@) {
417    # No Pod::Usage found not printing usage. Old perl only
418    pb_exit();
419} else {
420    pod2usage(  -message => $pbsynmsg,
421            -exitval => $exit_status,
422            -verbose => $verbose_level,
423            -output  => $filehandle );
424}
425}
426
427=item B<pb_temp_init>
428
429This 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.
430
431=cut
432
433sub pb_temp_init {
434
435my $pbkeep = shift; 
436
437# Do not keep temp files by default
438$pbkeep = 0 if (not defined $pbkeep);
439
440if (not defined $ENV{'TMPDIR'}) {
441    $ENV{'TMPDIR'}="/tmp";
442}
443
444# Makes this function compatible with perl 5.005x
445eval {
446    require File::Temp;
447    File::Temp->import("tempdir");
448};
449if ($@) {
450    # File::Temp not found, harcoding stuff
451    # Inspired by http://cpansearch.perl.org/src/TGUMMELS/File-MkTemp-1.0.6/File/MkTemp.pm
452    # Copyright 1999|2000 Travis Gummels.  All rights reserved. 
453    # This may be used and modified however you want.
454    my $template = "pb.XXXXXXXXXX";
455    my @template = split //, $template;
456    my @letters = split(//,"1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ");
457    for (my $i = $#template; $i >= 0 && ($template[$i] eq 'X'); $i--){
458        $template[$i] = $letters[int(rand 52)];
459    }
460    undef $template;
461    $template = pack "a" x @template, @template;
462    $ENV{'PBTMP'} = "$ENV{'TMPDIR'}/$template";
463    pb_mkdir_p($ENV{'PBTMP'});
464} else {
465    if (($pbdebug > 1) || ($pbkeep == 1)) {
466        $ENV{'PBTMP'} = tempdir( "pb.XXXXXXXXXX", DIR => $ENV{'TMPDIR'});
467        pb_log(2,"DEBUG: Creating a non-volatile temporary directory ($ENV{'PBTMP'})\n");
468    } else {
469        $ENV{'PBTMP'} = tempdir( "pb.XXXXXXXXXX", DIR => $ENV{'TMPDIR'}, CLEANUP => 1 );
470    }
471}
472}
473
474=item B<pb_get_osrelease>
475
476This function returns the release of our operating system
477
478=cut
479
480sub pb_get_osrelease {
481
482# On linux can also use /proc/sys/kernel/osrelease
483my $rel = `uname -r`;
484chomp($rel);
485return($rel);
486}
487
488
489=item B<pb_get_arch>
490
491This function returns the architecture of our local environment and
492standardize on i386 for those platforms.
493
494=cut
495
496sub pb_get_arch {
497
498my $arch = `uname -m`;
499chomp($arch);
500$arch =~ s/i[3456]86/i386/;
501# For Solaris
502$arch =~ s/i86pc/i386/;
503
504return($arch);
505}
506
507=item B<pb_check_requirements>
508
509This function checks that the commands needed for the subsystem are indeed present.
510The required commands are passed as a comma separated string as first parameter.
511The optional commands are passed as a comma separated string as second parameter.
512
513=cut
514
515sub pb_check_requirements {
516
517my $req = shift;
518my $opt = shift;
519my $appname = shift;
520
521my ($req2,$opt2) = (undef,undef);
522$req2 = $req->{$appname} if (defined $req and defined $appname);
523$opt2 = $opt->{$appname} if (defined $opt and defined $appname);
524
525# cmds is a string of comma separated commands
526if (defined $req2) {
527    foreach my $file (split(/,/,$req2)) {
528        pb_check_req($file,0);
529    }
530}
531
532# opts is a string of comma separated commands
533if (defined $opt2) {
534    foreach my $file (split(/,/,$opt2)) {
535        pb_check_req($file,1);
536    }
537}
538}
539
540=item B<pb_check_req>
541
542This function checks existence of a command and return its full pathname or undef if not found.
543The command name is passed as first parameter.
544The second parameter should be 0 if the command is mandatory, 1 if optional.
545It returns the full path name of the command if found, undef otherwise and dies if that was a mandatory command
546
547=cut
548
549sub pb_check_req {
550
551my $file = shift;
552my $opt = shift;
553my $found = undef;
554
555$opt = 1 if (not defined $opt);
556
557pb_log(2,"Checking availability of $file...");
558# Check for all dirs in the PATH
559foreach my $p (split(/:/,$ENV{'PATH'})) {
560    if (-x "$p/$file") {
561        $found =  "$p/$file";
562        last;
563    }
564}
565
566if (not $found) {
567    pb_log(2,"KO\n");
568    if ($opt eq 1) {
569        pb_log(2,"Unable to find optional command $file\n");
570    } else {
571        die pb_log(0,"Unable to find required command $file\n");
572    }
573} else {
574    pb_log(2,"OK\n");
575}
576return($found);
577}
578
579=item B<pb_path_expand>
580
581Expand out a path by environment variables as ($ENV{'ENVVAR'}) and ~
582
583=cut
584
585sub pb_path_expand {
586
587my $path = shift;
588
589eval { $path =~ s/(\$ENV.+\})/$1/eeg; };
590$path =~ s/^\~/$ENV{'HOME'}/;
591
592return($path);
593}
594
595=item B<pb_path_nbfiles>
596
597Return the number of files in a directory
598
599=cut
600
601sub pb_path_nbfiles {
602
603my $path = shift;
604my $nb = 0;
605
606opendir(DIR,$path) || confess "Unable to open directory $path: $!";
607foreach my $f (readdir(DIR)) {
608    next if ($f =~ /^\.[\.]*$/);
609    $nb++;
610}
611closedir(DIR);
612
613return($nb);
614}
615
616=back
617
618=head1 WEB SITES
619
620The 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/>.
621
622=head1 USER MAILING LIST
623
624None exists for the moment.
625
626=head1 AUTHORS
627
628The Project-Builder.org team L<http://trac.project-builder.org/> lead by Bruno Cornec L<mailto:bruno@project-builder.org>.
629
630=head1 COPYRIGHT
631
632Project-Builder.org is distributed under the GPL v2.0 license
633described in the file C<COPYING> included with the distribution.
634
635=cut
636
6371;
Note: See TracBrowser for help on using the repository browser.