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

Last change on this file since 395 was 395, checked in by bruno, 11 years ago
  • Move all reusable functions into Base
  • Move all pb only functions into pb
  • pod doc for Base begining
File size: 7.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.
99Based in File::Path mkpath.
100
101=cut
102
103sub pb_mkdir_p {
104my @dir = @_;
105my $ret = mkpath(@dir, 0, 0755);
106return($ret);
107}
108
109=item B<pb_mkdir_p>
110
111Internal rm -rf function. Supports multiple parameters.
112Based in File::Path rmtree.
113
114=cut
115
116sub pb_rm_rf {
117my @dir = @_;
118my $ret = rmtree(@dir, 0, 0);
119return($ret);
120}
121
122=item B<pb_system>
123
124Encapsulate the "system" call for better output and return value test
125Needs a $ENV{'PBTMP'} variable which is created by calling the pb_mktemp_init function
126Needs pb_log support, so pb_log_init should have benn called before.
127
128The first parameter is the shell command to call.
129The second parameter is the message to print on screen. If none is given, then the command is printed.
130This function returns the result the return value of the system command.
131If no error reported, it prints OK on the screen, just after the message. Else it prints the errors generated.
132
133=cut
134
135sub pb_system {
136
137my $cmd=shift;
138my $cmt=shift || $cmd;
139
140pb_log(0,"$cmt... ");
141pb_log(1,"Executing $cmd\n");
142system($cmd);
143my $res = $?;
144if ($res == -1) {
145    pb_log(0,"failed to execute ($cmd) : $!\n");
146    pb_display_file("$ENV{'PBTMP'}/system.log");
147} elsif ($res & 127) {
148    pb_log(0, "child ($cmd) died with signal ".($? & 127).", ".($? & 128) ? 'with' : 'without'." coredump\n");
149    pb_display_file("$ENV{'PBTMP'}/system.log");
150} elsif ($res == 0) {
151    pb_log(0,"OK\n");
152} else {
153    pb_log(0, "child ($cmd) exited with value ".($? >> 8)."\n");
154    pb_display_file("$ENV{'PBTMP'}/system.log");
155}
156return($res);
157}
158
159=item B<pb_conf_read_if>
160
161This function returns a table of pointers on hashes
162corresponding to the keys in a configuration file passed in parameter.
163If that file doesn't exist, it returns undef.
164
165The format of the configuration file is as follows:
166
167key tag = value1,value2,...
168
169Supposing the file is called "$ENV{'HOME'}/.pbrc", containing the following:
170
171$ cat $HOME/.pbrc
172pbver pb = 3
173pbver default = 1
174pblist pb = 12,25
175
176calling it like this:
177
178my ($k1, $k2) = pb_conf_read_if("$ENV{'HOME'}/.pbrc","pbver","pblist");
179
180will allow to get the mapping
181$k1->{'pb'}  contains 3
182$ka->{'default'} contains 1
183$k2->{'pb'} contains 12,25
184
185Valid chars for keys and tags are letters, numbers, '-' and '_'.
186
187=cut
188
189sub pb_conf_read_if {
190
191my $conffile = shift;
192my @param = @_;
193
194open(CONF,$conffile) || return((undef));
195close(CONF);
196return(pb_conf_read($conffile,@param));
197}
198
199=item B<pb_conf_read>
200
201This function is similar to B<pb_conf_read_if> except that it dies when the file in parameter doesn't exist.
202
203=cut
204
205sub pb_conf_read {
206
207my $conffile = shift;
208my @param = @_;
209my $trace;
210my @ptr;
211my %h;
212
213open(CONF,$conffile) || die "Unable to open $conffile";
214while(<CONF>) {
215    if (/^\s*([A-z0-9-_]+)\s+([[A-z0-9-_]+)\s*=\s*(.+)$/) {
216        pb_log(3,"DEBUG: 1:$1 2:$2 3:$3\n");
217        $h{$1}{$2}=$3;
218    }
219}
220close(CONF);
221
222for my $param (@param) {
223    push @ptr,$h{$param};
224}
225return(@ptr);
226}
227
228=item B<pb_get_uri>
229
230This function returns a list of 6 parameters indicating the protocol, account, password, server, port, and path contained in the URI passed in parameter.
231
232A URI has the format protocol://[ac@]host[:port][path[?query][#fragment]].
233Cf man URI.
234
235=cut
236
237sub pb_get_uri {
238
239my $uri = shift || undef;
240
241pb_log(2,"DEBUG: uri:$uri\n");
242my ($scheme, $authority, $path, $query, $fragment) =
243         $uri =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?| if (defined $uri);
244my ($account,$host,$port) = $authority =~ m|(?:([^\@]+)\@)?([^:]+)(:(?:[0-9]+))?| if (defined $authority);
245
246$scheme = "" if (not defined $scheme);
247$authority = "" if (not defined $authority);
248$path = "" if (not defined $path);
249$account = "" if (not defined $account);
250$host = "" if (not defined $host);
251$port = "" if (not defined $port);
252
253pb_log(2,"DEBUG: scheme:$scheme ac:$account host:$host port:$port path:$path\n");
254return($scheme, $account, $host, $port, $path);
255}
256
257=item B<pb_get_date>
258
259This 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.
260
261Cf: man ctime and description of the struct tm.
262
263=cut
264
265sub pb_get_date {
266   
267return(localtime->sec(), localtime->min(), localtime->hour(), localtime->mday(), localtime->mon(), localtime->year(), localtime->wday(), localtime->yday(), localtime->isdst());
268}
269
270=item B<pb_log_init>
271
272This function initializes the global variables used by the pb_log function.
273
274The first parameter is the debug level which will be considered during the run of the program?
275The second parameter is a pointer on a file descriptor used to print the log info.
276
277=cut
278
279sub pb_log_init {
280
281$debug = shift || 0;
282$LOG = shift || \*STDOUT;
283
284} 
285
286sub pb_log {
287
288my $dlevel = shift;
289my $msg = shift;
290
291print $LOG "$msg" if ($dlevel <= $debug);
292}
293
294# cat equivalent function
295sub pb_display_file {
296
297my $file=shift;
298
299return if (not -f $file);
300printf "%s\n",pb_get_content($file);
301}
302
303# get content of a file in a variable
304sub pb_get_content {
305
306my $file=shift;
307
308my $bkp = $/;
309undef $/;
310open(R,$file) || die "Unable to open $file: $!";
311my $content=<R>;
312close(R);
313chomp($content);
314$/ = $bkp;
315return($content);
316}
317
3181;
Note: See TracBrowser for help on using the repository browser.