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

Last change on this file since 402 was 402, checked in by bruno, 11 years ago

Split Base.pm and Distribution.pm to create a new perl-ProjectBuilder? module (for CPAN submission as well)

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