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

Last change on this file since 423 was 423, checked in by bruno, 11 years ago
  • Improved pbdistrocheck to support -v flags
  • Fix Ubuntu issue on distribution detection
  • some more pb_log added
File size: 8.3 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_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  # Analysis a URI and return its components in a table
68  #
69  my ($scheme, $account, $host, $port, $path) = pb_get_uri("svn+ssh://ac@my.server.org/path/to/dir");
70
71  #
72  # Gives the current date in a table
73  #
74  @date = pb_get_date();
75
76  #
77  # Manages logs of the program
78  #
79  pb_log_init(2,\*STDOUT);
80  pb_log(1,"Message to print\n");
81
82  #
83  # Manages content of a file
84  #
85  pb_display_file("/etc/passwd");
86  my $cnt = pb_get_content("/etc/passwd");
87
88=head1 USAGE
89
90=over 4
91
92=item B<pb_mkdir_p>
93
94Internal mkdir -p function. Forces mode to 755. Supports multiple parameters.
95
96Based on File::Path mkpath.
97
98=cut
99
100sub pb_mkdir_p {
101my @dir = @_;
102my $ret = mkpath(@dir, 0, 0755);
103return($ret);
104}
105
106=item B<pb_rm_rf>
107
108Internal rm -rf function. Supports multiple parameters.
109
110Based on File::Path rmtree.
111
112=cut
113
114sub pb_rm_rf {
115my @dir = @_;
116my $ret = rmtree(@dir, 0, 0);
117return($ret);
118}
119
120=item B<pb_system>
121
122Encapsulate the "system" call for better output and return value test
123Needs a $ENV{'PBTMP'} variable which is created by calling the pb_mktemp_init function
124Needs pb_log support, so pb_log_init should have benn called before.
125
126The first parameter is the shell command to call.
127The second parameter is the message to print on screen. If none is given, then the command is printed.
128This function returns the result the return value of the system command.
129
130If no error reported, it prints OK on the screen, just after the message. Else it prints the errors generated.
131
132=cut
133
134sub pb_system {
135
136my $cmd=shift;
137my $cmt=shift || $cmd;
138
139pb_log(0,"$cmt... ");
140pb_log(1,"Executing $cmd\n");
141system($cmd);
142my $res = $?;
143if ($res == -1) {
144    pb_log(0,"failed to execute ($cmd) : $!\n");
145    pb_display_file("$ENV{'PBTMP'}/system.log");
146} elsif ($res & 127) {
147    pb_log(0, "child ($cmd) died with signal ".($? & 127).", ".($? & 128) ? 'with' : 'without'." coredump\n");
148    pb_display_file("$ENV{'PBTMP'}/system.log");
149} elsif ($res == 0) {
150    pb_log(0,"OK\n");
151} else {
152    pb_log(0, "child ($cmd) exited with value ".($? >> 8)."\n");
153    pb_display_file("$ENV{'PBTMP'}/system.log");
154}
155return($res);
156}
157
158=item B<pb_get_uri>
159
160This function returns a list of 6 parameters indicating the protocol, account, password, server, port, and path contained in the URI passed in parameter.
161
162A URI has the format protocol://[ac@]host[:port][path[?query][#fragment]].
163
164Cf man URI.
165
166=cut
167
168sub pb_get_uri {
169
170my $uri = shift || undef;
171
172pb_log(2,"DEBUG: uri:$uri\n");
173my ($scheme, $authority, $path, $query, $fragment) =
174         $uri =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?| if (defined $uri);
175my ($account,$host,$port) = $authority =~ m|(?:([^\@]+)\@)?([^:]+)(:(?:[0-9]+))?| if (defined $authority);
176
177$scheme = "" if (not defined $scheme);
178$authority = "" if (not defined $authority);
179$path = "" if (not defined $path);
180$account = "" if (not defined $account);
181$host = "" if (not defined $host);
182$port = "" if (not defined $port);
183
184pb_log(2,"DEBUG: scheme:$scheme ac:$account host:$host port:$port path:$path\n");
185return($scheme, $account, $host, $port, $path);
186}
187
188=item B<pb_get_date>
189
190This 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.
191
192Cf: man ctime and description of the struct tm.
193
194=cut
195
196sub pb_get_date {
197   
198return(localtime->sec(), localtime->min(), localtime->hour(), localtime->mday(), localtime->mon(), localtime->year(), localtime->wday(), localtime->yday(), localtime->isdst());
199}
200
201=item B<pb_log_init>
202
203This function initializes the global variables used by the pb_log function.
204
205The first parameter is the debug level which will be considered during the run of the program?
206The second parameter is a pointer on a file descriptor used to print the log info.
207
208As 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.
209
210The call to B<pb_log_init> is typically done after getting a parameter on the CLI indicating the level of verbosity expected.
211
212=cut
213
214sub pb_log_init {
215
216$debug = shift || 0;
217$LOG = shift || \*STDOUT;
218pb_log(1,"Debug value: $debug\n");
219
220} 
221
222=item B<pb_log>
223
224This 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.
225
226Here is a usage example:
227
228  pb_log_init(2,\*STDERR);
229  pb_log(1,"Hello World 1\n");
230  pb_log(2,"Hello World 2\n");
231  pb_log(3,"Hello World 3\n");
232
233  will print:
234 
235  Hello World 1
236  Hello World 2
237
238=cut 
239
240sub pb_log {
241
242my $dlevel = shift;
243my $msg = shift;
244
245print $LOG "$msg" if ($dlevel <= $debug);
246}
247
248=item B<pb_display_file>
249
250This function print the content of the file passed in parameter.
251
252This is a cat equivalent function.
253
254=cut
255
256sub pb_display_file {
257
258my $file=shift;
259
260return if (not -f $file);
261printf "%s\n",pb_get_content($file);
262}
263
264=item B<pb_get_content>
265
266This function returns the content of the file passed in parameter.
267
268=cut
269
270sub pb_get_content {
271
272my $file=shift;
273
274my $bkp = $/;
275undef $/;
276open(R,$file) || die "Unable to open $file: $!";
277my $content=<R>;
278close(R);
279chomp($content);
280$/ = $bkp;
281return($content);
282}
283
284=item B<pb_syntax_init>
285
286This function initializes the global variable used by the pb_syntax function.
287
288The parameter is the message string which will be printed when calling pb_syntax
289
290=cut
291
292sub pb_syntax_init {
293
294$synmsg = shift || "Error";
295}
296
297=item B<pb_syntax>
298
299This function prints the syntax expected by the application, based on pod2usage, and exits.
300The first parameter is the return value of the exit.
301The second parameter is the verbosity as expected by pod2usage.
302
303Cf: man Pod::Usage
304
305=cut
306
307sub pb_syntax {
308
309my $exit_status = shift || -1;
310my $verbose_level = shift || 0;
311
312my $filehandle = \*STDERR;
313
314$filehandle = \*STDOUT if ($exit_status == 0);
315
316pod2usage( { -message => $synmsg,
317             -exitval => $exit_status  ,
318             -verbose => $verbose_level,
319             -output  => $filehandle } );
320}
321
322=item B<pb_temp_init>
323
324This 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.
325
326=cut
327
328sub pb_temp_init {
329
330if (not defined $ENV{'TMPDIR'}) {
331    $ENV{'TMPDIR'}="/tmp";
332}
333$ENV{'PBTMP'} = tempdir( "pb.XXXXXXXXXX", DIR => $ENV{'TMPDIR'}, CLEANUP => 1 );
334}
335
336=back
337
338=head1 WEB SITES
339
340The 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/>.
341
342=head1 USER MAILING LIST
343
344None exists for the moment.
345
346=head1 AUTHORS
347
348The Project-Builder.org team L<http://trac.project-builder.org/> lead by Bruno Cornec L<mailto:bruno@project-builder.org>.
349
350=head1 COPYRIGHT
351
352Project-Builder.org is distributed under the GPL v2.0 license
353described in the file C<COPYING> included with the distribution.
354
355=cut
356
3571;
Note: See TracBrowser for help on using the repository browser.