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

Last change on this file since 396 was 396, checked in by bruno, 11 years ago
  • pod doc done for Base.pm, and man page generated now for it
File size: 8.1 KB
RevLine 
[2]1#!/usr/bin/perl -w
2#
[395]3# Base subroutines brought by the the Project-Builder project
4# which can be easily used by whatever perl project
[2]5#
[395]6# Copyright B. Cornec 2007-2008
7# Provided under the GPL v2
8#
[2]9# $Id$
10#
11
[318]12package ProjectBuilder::Base;
13
[18]14use strict;
[5]15use lib qw (lib);
[9]16use File::Path;
[318]17use File::Temp qw(tempdir);
[8]18use Data::Dumper;
[318]19use Time::localtime qw(localtime);
[328]20use English;
[2]21
[318]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);
[395]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);
[318]34
[395]35=pod
[2]36
[395]37=head1 NAME
[2]38
[395]39ProjectBuilder::Base, part of the project-builder.org - module dealing with generic functions suitable for perl project development
[355]40
[395]41=head1 DESCRIPTION
[69]42
[395]43This modules provides generic functions suitable for perl project development
[69]44
[395]45=head1 SYNOPSIS
[69]46
[395]47  use ProjectBuilder::Base;
[313]48
[395]49  #
50  # Create a directory and its parents
51  #
52  pb_mkdir_p("/tmp/foo/bar");
[313]53
[395]54  #
55  # Remove recursively a directory and its children
56  #
57  pb_rm_rf("/tmp/foo");
[313]58
[395]59  #
60  # Encapsulate the system call for better output and return value test
61  #
62  pb_system("ls -l", "Printing directory content");
[314]63
[395]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]69
[395]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");
[313]74
[395]75  #
76  # Gives the current date in a table
77  #
78  @date = pb_get_date();
[2]79
[395]80  #
81  # Manages logs of the program
82  #
83  pb_log_init(2,\*STDOUT);
84  pb_log(1,"Message to print\n");
[313]85
[395]86  #
87  # Manages content of a file
88  #
89  pb_display_file("/etc/passwd");
90  my $cnt = pb_get_content("/etc/passwd");
[313]91
[395]92=head1 USAGE
[320]93
[395]94=over 4
[323]95
[395]96=item B<pb_mkdir_p>
[314]97
[395]98Internal mkdir -p function. Forces mode to 755. Supports multiple parameters.
[358]99
[396]100Based on File::Path mkpath.
101
[395]102=cut
[273]103
[74]104sub pb_mkdir_p {
[29]105my @dir = @_;
106my $ret = mkpath(@dir, 0, 0755);
107return($ret);
[9]108}
109
[396]110=item B<pb_rm_rf>
[395]111
112Internal rm -rf function. Supports multiple parameters.
113
[396]114Based on File::Path rmtree.
115
[395]116=cut
117
[74]118sub pb_rm_rf {
[29]119my @dir = @_;
120my $ret = rmtree(@dir, 0, 0);
121return($ret);
[9]122}
123
[395]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.
[396]133
[395]134If no error reported, it prints OK on the screen, just after the message. Else it prints the errors generated.
135
136=cut
137
[74]138sub pb_system {
[29]139
140my $cmd=shift;
[30]141my $cmt=shift || $cmd;
[29]142
[319]143pb_log(0,"$cmt... ");
[395]144pb_log(1,"Executing $cmd\n");
[293]145system($cmd);
[347]146my $res = $?;
147if ($res == -1) {
[319]148    pb_log(0,"failed to execute ($cmd) : $!\n");
[106]149    pb_display_file("$ENV{'PBTMP'}/system.log");
[347]150} elsif ($res & 127) {
[319]151    pb_log(0, "child ($cmd) died with signal ".($? & 127).", ".($? & 128) ? 'with' : 'without'." coredump\n");
[106]152    pb_display_file("$ENV{'PBTMP'}/system.log");
[347]153} elsif ($res == 0) {
[319]154    pb_log(0,"OK\n");
[29]155} else {
[319]156    pb_log(0, "child ($cmd) exited with value ".($? >> 8)."\n");
[106]157    pb_display_file("$ENV{'PBTMP'}/system.log");
[29]158}
[347]159return($res);
[30]160}
[74]161
[395]162=item B<pb_conf_read_if>
[106]163
[395]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.
[106]167
[395]168The format of the configuration file is as follows:
[106]169
[395]170key tag = value1,value2,...
[88]171
[395]172Supposing the file is called "$ENV{'HOME'}/.pbrc", containing the following:
[88]173
[396]174  $ cat $HOME/.pbrc
175  pbver pb = 3
176  pbver default = 1
177  pblist pb = 12,25
[313]178
[395]179calling it like this:
[313]180
[396]181  my ($k1, $k2) = pb_conf_read_if("$ENV{'HOME'}/.pbrc","pbver","pblist");
[313]182
[396]183will allow to get the mapping:
[313]184
[396]185  $k1->{'pb'}  contains 3
186  $ka->{'default'} contains 1
187  $k2->{'pb'} contains 12,25
188
[395]189Valid chars for keys and tags are letters, numbers, '-' and '_'.
[89]190
[395]191=cut
[242]192
[313]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
[395]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
[74]209sub pb_conf_read {
210
211my $conffile = shift;
212my @param = @_;
213my $trace;
214my @ptr;
[291]215my %h;
[74]216
[291]217open(CONF,$conffile) || die "Unable to open $conffile";
218while(<CONF>) {
219    if (/^\s*([A-z0-9-_]+)\s+([[A-z0-9-_]+)\s*=\s*(.+)$/) {
[327]220        pb_log(3,"DEBUG: 1:$1 2:$2 3:$3\n");
[291]221        $h{$1}{$2}=$3;
222    }
[74]223}
[291]224close(CONF);
[74]225
226for my $param (@param) {
[291]227    push @ptr,$h{$param};
[74]228}
[89]229return(@ptr);
[74]230}
231
[395]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]].
[396]237
[395]238Cf man URI.
239
240=cut
241
[314]242sub pb_get_uri {
[313]243
[314]244my $uri = shift || undef;
[313]245
[318]246pb_log(2,"DEBUG: uri:$uri\n");
[314]247my ($scheme, $authority, $path, $query, $fragment) =
[318]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
[315]258pb_log(2,"DEBUG: scheme:$scheme ac:$account host:$host port:$port path:$path\n");
[314]259return($scheme, $account, $host, $port, $path);
[313]260}
261
[395]262=item B<pb_get_date>
[313]263
[395]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.
[74]265
[395]266Cf: man ctime and description of the struct tm.
[74]267
[395]268=cut
[339]269
[315]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
[395]275=item B<pb_log_init>
[315]276
[395]277This function initializes the global variables used by the pb_log function.
[106]278
[395]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.
[315]281
[396]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
[395]286=cut
[319]287
[315]288sub pb_log_init {
[77]289
[315]290$debug = shift || 0;
291$LOG = shift || \*STDOUT;
292
293} 
294
[396]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
[315]313sub pb_log {
314
315my $dlevel = shift;
316my $msg = shift;
317
[318]318print $LOG "$msg" if ($dlevel <= $debug);
[315]319}
320
[396]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
[395]329sub pb_display_file {
[316]330
[395]331my $file=shift;
[316]332
[395]333return if (not -f $file);
334printf "%s\n",pb_get_content($file);
[316]335}
336
[396]337=item B<pb_get_content>
338
339This function returns the content of the file passed in parameter.
340
341=cut
342
[395]343# get content of a file in a variable
344sub pb_get_content {
[353]345
[395]346my $file=shift;
[353]347
[395]348my $bkp = $/;
349undef $/;
350open(R,$file) || die "Unable to open $file: $!";
351my $content=<R>;
352close(R);
353chomp($content);
354$/ = $bkp;
355return($content);
[353]356}
357
[2]3581;
Note: See TracBrowser for help on using the repository browser.