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

#!/usr/bin/perl -w
#
# Base subroutines brought by the the Project-Builder project
# which can be easily used by whatever perl project
#
# Copyright B. Cornec 2007-2008
# Provided under the GPL v2
#
# $Id$
#

package ProjectBuilder::Base;

use strict;
use lib qw (lib);
use File::Path;
use File::Temp qw(tempdir);
use Data::Dumper;
use Time::localtime qw(localtime);
use English;

# Inherit from the "Exporter" module which handles exporting functions.
 
use Exporter;
 
# Export, by default, all the functions into the namespace of
# any code which uses this module.
 
our $debug = 0;
our $LOG = \*STDOUT;

our @ISA = qw(Exporter);
our @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);

=pod

=head1 NAME

ProjectBuilder::Base, part of the project-builder.org - module dealing with generic functions suitable for perl project development

=head1 DESCRIPTION

This modules provides generic functions suitable for perl project development 

=head1 SYNOPSIS

  use ProjectBuilder::Base;

  #
  # Create a directory and its parents
  #
  pb_mkdir_p("/tmp/foo/bar");

  #
  # Remove recursively a directory and its children
  #
  pb_rm_rf("/tmp/foo");

  #
  # Encapsulate the system call for better output and return value test
  #
  pb_system("ls -l", "Printing directory content");

  #
  # Read hash codes of values from a configuration file and return table of pointers
  #
  my ($k1, $k2) = pb_conf_read_if("$ENV{'HOME'}/.pbrc","key1","key2");
  my ($k) = pb_conf_read("$ENV{'HOME'}/.pbrc","key");

  #
  # Analysis a URI and return its components in a table
  #
  my ($scheme, $account, $host, $port, $path) = pb_get_uri("svn+ssh://ac@my.server.org/path/to/dir");

  #
  # Gives the current date in a table
  #
  @date = pb_get_date();

  #
  # Manages logs of the program
  #
  pb_log_init(2,\*STDOUT);
  pb_log(1,"Message to print\n");

  #
  # Manages content of a file
  #
  pb_display_file("/etc/passwd");
  my $cnt = pb_get_content("/etc/passwd");

=head1 USAGE

=over 4

=item B<pb_mkdir_p>

Internal mkdir -p function. Forces mode to 755. Supports multiple parameters.

Based on File::Path mkpath.

=cut

sub pb_mkdir_p {
my @dir = @_;
my $ret = mkpath(@dir, 0, 0755);
return($ret);
}

=item B<pb_rm_rf>

Internal rm -rf function. Supports multiple parameters.

Based on File::Path rmtree.

=cut

sub pb_rm_rf {
my @dir = @_;
my $ret = rmtree(@dir, 0, 0);
return($ret);
}

=item B<pb_system>

Encapsulate the "system" call for better output and return value test
Needs a $ENV{'PBTMP'} variable which is created by calling the pb_mktemp_init function
Needs pb_log support, so pb_log_init should have benn called before.

The first parameter is the shell command to call.
The second parameter is the message to print on screen. If none is given, then the command is printed.
This function returns the result the return value of the system command.

If no error reported, it prints OK on the screen, just after the message. Else it prints the errors generated.

=cut

sub pb_system {

my $cmd=shift;
my $cmt=shift || $cmd;

pb_log(0,"$cmt... ");
pb_log(1,"Executing $cmd\n");
system($cmd);
my $res = $?;
if ($res == -1) {
    pb_log(0,"failed to execute ($cmd) : $!\n");
    pb_display_file("$ENV{'PBTMP'}/system.log");
} elsif ($res & 127) {
    pb_log(0, "child ($cmd) died with signal ".($? & 127).", ".($? & 128) ? 'with' : 'without'." coredump\n");
    pb_display_file("$ENV{'PBTMP'}/system.log");
} elsif ($res == 0) {
    pb_log(0,"OK\n");
} else {
    pb_log(0, "child ($cmd) exited with value ".($? >> 8)."\n");
    pb_display_file("$ENV{'PBTMP'}/system.log");
}
return($res);
}

=item B<pb_conf_read_if>

This function returns a table of pointers on hashes
corresponding to the keys in a configuration file passed in parameter.
If that file doesn't exist, it returns undef.

The format of the configuration file is as follows:

key tag = value1,value2,...

Supposing the file is called "$ENV{'HOME'}/.pbrc", containing the following:

  $ cat $HOME/.pbrc
  pbver pb = 3
  pbver default = 1
  pblist pb = 12,25

calling it like this:

  my ($k1, $k2) = pb_conf_read_if("$ENV{'HOME'}/.pbrc","pbver","pblist");

will allow to get the mapping:

  $k1->{'pb'}  contains 3
  $ka->{'default'} contains 1
  $k2->{'pb'} contains 12,25

Valid chars for keys and tags are letters, numbers, '-' and '_'.

=cut

sub pb_conf_read_if {

my $conffile = shift;
my @param = @_;

open(CONF,$conffile) || return((undef));
close(CONF);
return(pb_conf_read($conffile,@param));
}

=item B<pb_conf_read>

This function is similar to B<pb_conf_read_if> except that it dies when the file in parameter doesn't exist.

=cut

sub pb_conf_read {

my $conffile = shift;
my @param = @_;
my $trace;
my @ptr;
my %h;

open(CONF,$conffile) || die "Unable to open $conffile";
while(<CONF>) {
    if (/^\s*([A-z0-9-_]+)\s+([[A-z0-9-_]+)\s*=\s*(.+)$/) {
        pb_log(3,"DEBUG: 1:$1 2:$2 3:$3\n");
        $h{$1}{$2}=$3;
    }
}
close(CONF);

for my $param (@param) {
    push @ptr,$h{$param};
}
return(@ptr);
}

=item B<pb_get_uri>

This function returns a list of 6 parameters indicating the protocol, account, password, server, port, and path contained in the URI passed in parameter.

A URI has the format protocol://[ac@]host[:port][path[?query][#fragment]].

Cf man URI.

=cut

sub pb_get_uri {

my $uri = shift || undef;

pb_log(2,"DEBUG: uri:$uri\n");
my ($scheme, $authority, $path, $query, $fragment) =
         $uri =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?| if (defined $uri);
my ($account,$host,$port) = $authority =~ m|(?:([^\@]+)\@)?([^:]+)(:(?:[0-9]+))?| if (defined $authority);

$scheme = "" if (not defined $scheme);
$authority = "" if (not defined $authority);
$path = "" if (not defined $path);
$account = "" if (not defined $account);
$host = "" if (not defined $host);
$port = "" if (not defined $port);

pb_log(2,"DEBUG: scheme:$scheme ac:$account host:$host port:$port path:$path\n");
return($scheme, $account, $host, $port, $path);
}

=item B<pb_get_date>

This 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.

Cf: man ctime and description of the struct tm.

=cut

sub pb_get_date {
    
return(localtime->sec(), localtime->min(), localtime->hour(), localtime->mday(), localtime->mon(), localtime->year(), localtime->wday(), localtime->yday(), localtime->isdst());
}

=item B<pb_log_init>

This function initializes the global variables used by the pb_log function.

The first parameter is the debug level which will be considered during the run of the program?
The second parameter is a pointer on a file descriptor used to print the log info.

As 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.

The call to B<pb_log_init> is typically done after getting a parameter on the CLI indicating the level of verbosity expected.

=cut

sub pb_log_init {

$debug = shift || 0;
$LOG = shift || \*STDOUT;

} 

=item B<pb_log>

This 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.

Here is a usage example:

  pb_log_init(2,\*STDERR);
  pb_log(1,"Hello World 1\n");
  pb_log(2,"Hello World 2\n");
  pb_log(3,"Hello World 3\n");

  will print:
  
  Hello World 1
  Hello World 2

=cut 

sub pb_log {

my $dlevel = shift;
my $msg = shift;

print $LOG "$msg" if ($dlevel <= $debug);
}

=item B<pb_display_file>

This function print the content of the file passed in parameter.

This is a cat equivalent function.

=cut

sub pb_display_file {

my $file=shift;

return if (not -f $file);
printf "%s\n",pb_get_content($file);
}

=item B<pb_get_content>

This function returns the content of the file passed in parameter.

=cut

# get content of a file in a variable
sub pb_get_content {

my $file=shift;

my $bkp = $/;
undef $/;
open(R,$file) || die "Unable to open $file: $!";
my $content=<R>;
close(R);
chomp($content);
$/ = $bkp;
return($content);
}

1;