source: devel/pb/lib/ProjectBuilder/Base.pm @ 396

Last change on this file since 396 was 396, checked in by bruno, 12 years ago
  • pod doc done for Base.pm, and man page generated now for it
File size: 8.1 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 English;
21
22# Inherit from the "Exporter" module which handles exporting functions.
23 
24use Exporter;
25 
26# Export, by default, all the functions into the namespace of
27# any code which uses this module.
28 
29our $debug = 0;
30our $LOG = \*STDOUT;
31
32our @ISA = qw(Exporter);
33our @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 $debug $LOG);
34
35=pod
36
37=head1 NAME
38
39ProjectBuilder::Base, part of the project-builder.org - module dealing with generic functions suitable for perl project development
40
41=head1 DESCRIPTION
42
43This modules provides generic functions suitable for perl project development
44
45=head1 SYNOPSIS
46
47  use ProjectBuilder::Base;
48
49  #
50  # Create a directory and its parents
51  #
52  pb_mkdir_p("/tmp/foo/bar");
53
54  #
55  # Remove recursively a directory and its children
56  #
57  pb_rm_rf("/tmp/foo");
58
59  #
60  # Encapsulate the system call for better output and return value test
61  #
62  pb_system("ls -l", "Printing directory content");
63
64  #
65  # Read hash codes of values from a configuration file and return table of pointers
66  #
67  my ($k1, $k2) = pb_conf_read_if("$ENV{'HOME'}/.pbrc","key1","key2");
68  my ($k) = pb_conf_read("$ENV{'HOME'}/.pbrc","key");
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/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");
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.
132This function returns the result the return value of the system command.
133
134If no error reported, it prints OK on the screen, just after the message. Else it prints the errors generated.
135
136=cut
137
138sub pb_system {
139
140my $cmd=shift;
141my $cmt=shift || $cmd;
142
143pb_log(0,"$cmt... ");
144pb_log(1,"Executing $cmd\n");
145system($cmd);
146my $res = $?;
147if ($res == -1) {
148    pb_log(0,"failed to execute ($cmd) : $!\n");
149    pb_display_file("$ENV{'PBTMP'}/system.log");
150} elsif ($res & 127) {
151    pb_log(0, "child ($cmd) died with signal ".($? & 127).", ".($? & 128) ? 'with' : 'without'." coredump\n");
152    pb_display_file("$ENV{'PBTMP'}/system.log");
153} elsif ($res == 0) {
154    pb_log(0,"OK\n");
155} else {
156    pb_log(0, "child ($cmd) exited with value ".($? >> 8)."\n");
157    pb_display_file("$ENV{'PBTMP'}/system.log");
158}
159return($res);
160}
161
162=item B<pb_conf_read_if>
163
164This function returns a table of pointers on hashes
165corresponding to the keys in a configuration file passed in parameter.
166If that file doesn't exist, it returns undef.
167
168The format of the configuration file is as follows:
169
170key tag = value1,value2,...
171
172Supposing the file is called "$ENV{'HOME'}/.pbrc", containing the following:
173
174  $ cat $HOME/.pbrc
175  pbver pb = 3
176  pbver default = 1
177  pblist pb = 12,25
178
179calling it like this:
180
181  my ($k1, $k2) = pb_conf_read_if("$ENV{'HOME'}/.pbrc","pbver","pblist");
182
183will allow to get the mapping:
184
185  $k1->{'pb'}  contains 3
186  $ka->{'default'} contains 1
187  $k2->{'pb'} contains 12,25
188
189Valid chars for keys and tags are letters, numbers, '-' and '_'.
190
191=cut
192
193sub pb_conf_read_if {
194
195my $conffile = shift;
196my @param = @_;
197
198open(CONF,$conffile) || return((undef));
199close(CONF);
200return(pb_conf_read($conffile,@param));
201}
202
203=item B<pb_conf_read>
204
205This function is similar to B<pb_conf_read_if> except that it dies when the file in parameter doesn't exist.
206
207=cut
208
209sub pb_conf_read {
210
211my $conffile = shift;
212my @param = @_;
213my $trace;
214my @ptr;
215my %h;
216
217open(CONF,$conffile) || die "Unable to open $conffile";
218while(<CONF>) {
219    if (/^\s*([A-z0-9-_]+)\s+([[A-z0-9-_]+)\s*=\s*(.+)$/) {
220        pb_log(3,"DEBUG: 1:$1 2:$2 3:$3\n");
221        $h{$1}{$2}=$3;
222    }
223}
224close(CONF);
225
226for my $param (@param) {
227    push @ptr,$h{$param};
228}
229return(@ptr);
230}
231
232=item B<pb_get_uri>
233
234This function returns a list of 6 parameters indicating the protocol, account, password, server, port, and path contained in the URI passed in parameter.
235
236A URI has the format protocol://[ac@]host[:port][path[?query][#fragment]].
237
238Cf man URI.
239
240=cut
241
242sub pb_get_uri {
243
244my $uri = shift || undef;
245
246pb_log(2,"DEBUG: uri:$uri\n");
247my ($scheme, $authority, $path, $query, $fragment) =
248         $uri =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?| if (defined $uri);
249my ($account,$host,$port) = $authority =~ m|(?:([^\@]+)\@)?([^:]+)(:(?:[0-9]+))?| if (defined $authority);
250
251$scheme = "" if (not defined $scheme);
252$authority = "" if (not defined $authority);
253$path = "" if (not defined $path);
254$account = "" if (not defined $account);
255$host = "" if (not defined $host);
256$port = "" if (not defined $port);
257
258pb_log(2,"DEBUG: scheme:$scheme ac:$account host:$host port:$port path:$path\n");
259return($scheme, $account, $host, $port, $path);
260}
261
262=item B<pb_get_date>
263
264This 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.
265
266Cf: man ctime and description of the struct tm.
267
268=cut
269
270sub pb_get_date {
271   
272return(localtime->sec(), localtime->min(), localtime->hour(), localtime->mday(), localtime->mon(), localtime->year(), localtime->wday(), localtime->yday(), localtime->isdst());
273}
274
275=item B<pb_log_init>
276
277This function initializes the global variables used by the pb_log function.
278
279The first parameter is the debug level which will be considered during the run of the program?
280The second parameter is a pointer on a file descriptor used to print the log info.
281
282As 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.
283
284The call to B<pb_log_init> is typically done after getting a parameter on the CLI indicating the level of verbosity expected.
285
286=cut
287
288sub pb_log_init {
289
290$debug = shift || 0;
291$LOG = shift || \*STDOUT;
292
293} 
294
295=item B<pb_log>
296
297This 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.
298
299Here is a usage example:
300
301  pb_log_init(2,\*STDERR);
302  pb_log(1,"Hello World 1\n");
303  pb_log(2,"Hello World 2\n");
304  pb_log(3,"Hello World 3\n");
305
306  will print:
307 
308  Hello World 1
309  Hello World 2
310
311=cut 
312
313sub pb_log {
314
315my $dlevel = shift;
316my $msg = shift;
317
318print $LOG "$msg" if ($dlevel <= $debug);
319}
320
321=item B<pb_display_file>
322
323This function print the content of the file passed in parameter.
324
325This is a cat equivalent function.
326
327=cut
328
329sub pb_display_file {
330
331my $file=shift;
332
333return if (not -f $file);
334printf "%s\n",pb_get_content($file);
335}
336
337=item B<pb_get_content>
338
339This function returns the content of the file passed in parameter.
340
341=cut
342
343# get content of a file in a variable
344sub pb_get_content {
345
346my $file=shift;
347
348my $bkp = $/;
349undef $/;
350open(R,$file) || die "Unable to open $file: $!";
351my $content=<R>;
352close(R);
353chomp($content);
354$/ = $bkp;
355return($content);
356}
357
3581;
Note: See TracBrowser for help on using the repository browser.