PBS::PBSConfig - Handles PBS configuration

PerlBuildSystem documentation Contained in the PerlBuildSystem distribution.

Index

Code Index:

NAME

Top

PBS::PBSConfig - Handles PBS configuration

DESCRIPTION

Top

Every loaded package has a configuration. The first configuration, loaded through the pbs utility is stored in the 'PBS' package and is influenced by pbs command line switches. Subsequent configurations are loaded when a subpbs is run. The configuration name and contents reflect the loaded package parents and the subpbs configuration.

GetPbsConfig can be used (though not recommended), in Pbsfiles, to get the current pbs configuration. The configuration name is __PACKAGE__. The returned scalaris a reference to the configuration hash.

	# in a Pbsfile
	use Data::TreeDumper ;

	my $pbs_config = GetPbsConfig(__PACKAGE__) ;
	PrintInfo(DumpTree( $pbs_config->{SOURCE_DIRECTORIES}, "Source directories")) ;

AUTHOR

Top

Khemir Nadim ibn Hamouda. nadim@khemir.net

PerlBuildSystem documentation Contained in the PerlBuildSystem distribution. 
package PBS::PBSConfig ;
use PBS::Debug ;

use 5.006 ;
use strict ;
use warnings ;
use Data::Dumper ;
use Data::TreeDumper ;
use File::Spec::Functions qw(:ALL) ;

require Exporter ;
use AutoLoader qw(AUTOLOAD) ;

our @ISA = qw(Exporter) ;
our %EXPORT_TAGS = ('all' => [ qw() ]) ;
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ) ;
our @EXPORT = qw(GetPbsConfig GetBuildDirectory GetSourceDirectories CollapsePath PARSE_SWITCHES_IGNORE_ERROR PARSE_PRF_SWITCHES_IGNORE_ERROR) ;
our $VERSION = '0.03' ;

use Getopt::Long ;
use Pod::Parser ;
use Cwd ;
use File::Spec;

use PBS::Output ;
use PBS::Log ;
use PBS::Constants ;
use PBS::PBSConfigSwitches ;

#-------------------------------------------------------------------------------

my %pbs_configuration ;

sub RegisterPbsConfig
{
my $package  = shift ;
my $configuration= shift ;

if(ref $configuration eq 'HASH')
	{
	$pbs_configuration{$package} = $configuration;
	}
else
	{
	PrintError("RegisterPbsConfig: switches are to be encapsulated within a hash reference!\n") ;
	}
}

#-------------------------------------------------------------------------------

sub GetPbsConfig
{
my $package  = shift || caller() ;

if(defined $pbs_configuration{$package})
	{
	return($pbs_configuration{$package}) ;
	}
else
	{
	PrintError("GetPbsConfig: no configuration for package '$package'! Returning empty set.\n") ;
	Carp::confess ;
	return({}) ;
	}
}

#-------------------------------------------------------------------------------

sub GetBuildDirectory
{
my $package  = shift || caller() ;

if(defined $pbs_configuration{$package})
	{
	return($pbs_configuration{$package}{BUILD_DIRECTORY}) ;
	}
else
	{
	PrintError("GetBuildDirectory: no configuration for package '$package'! Returning empty string.\n") ;
	Carp::confess ;
	return('') ;
	}
}

#-------------------------------------------------------------------------------

sub GetSourceDirectories
{
my $package  = shift || caller() ;

if(defined $pbs_configuration{$package})
	{
	return([@{$pbs_configuration{$package}{SOURCE_DIRECTORIES}}]) ;
	}
else
	{
	PrintError("GetSourceDirectories: no configuration for package '$package'! Returning empty list.\n") ;
	Carp::confess ;
	return([]) ;
	}
}

#-------------------------------------------------------------------------------

use constant PARSE_SWITCHES_IGNORE_ERROR => 1 ;

sub ParseSwitches
{
my ($pbs_config, $switches_to_parse, $ignore_error) = @_ ;
$pbs_config ||= {} ;

my $success_message = '' ;

local @ARGV = ( # default colors
		  '-ci'  => 'green'
		, '-ci2' => 'bold blue'
		, '-cw'  => 'yellow'
		, '-cw2' => 'bold yellow'
		, '-ce'  => 'red'
		, '-cd'  => 'magenta'
		, '-cs'  => 'bold green'
		, '-cu'  => 'cyan'
		) ;
		
Getopt::Long::Configure('no_auto_abbrev', 'no_ignore_case', 'require_order') ;

my @flags = PBS::PBSConfigSwitches::Get_GetoptLong_Data($pbs_config) ;
unless(GetOptions(@flags))
	{
	return([0, "Error in default colors configuration." . __FILE__ . ':' . __LINE__ . "\n"], $pbs_config, @ARGV) ;
	}

@ARGV = @$switches_to_parse ;

# tweek option parsing so we can mix switches with targets
my $contains_switch ;
my @targets ;

do
	{
	while(@ARGV && $ARGV[0] !~ /^-/)
		{
		#~ print "target => $ARGV[0] \n" ;
		push @targets, shift @ARGV ;
		}
		
	$contains_switch = @ARGV ;
	
	local $SIG{__WARN__} 
		= sub 
			{
			PrintWarning $_[0] unless $ignore_error ;
			} ;
			
	unless(GetOptions(@flags))
		{
		return(0, "Try perl pbs.pl -h.\n", $pbs_config, @ARGV) unless $ignore_error;
		}
	}
while($contains_switch) ;

$pbs_config->{TARGETS} = \@targets ;
 
return(1, $success_message, $pbs_config) ;
}

#-------------------------------------------------------------------------------

sub GetUserName
{
my $user = 'no_user_set' ;

if(defined $ENV{USER} && $ENV{USER} ne '')
	{
	$user = $ENV{USER} ;
	}
elsif(defined $ENV{USERNAME} && $ENV{USERNAME} ne '')
	{
	$user = $ENV{USERNAME} ;
	}
	
return($user) ;
}

#-------------------------------------------------------------------------------

sub CheckPbsConfig
{
my $pbs_config = shift ;

my $success_message = '' ;

#force options
$pbs_config->{DISPLAY_PROGRESS_BAR}++ ;
$pbs_config->{DISPLAY_COMPACT_DEPEND_INFORMATION}++ ;

# check the options
if(defined $pbs_config->{DISPLAY_DEPENDENCY_INFO})
	{
	delete $pbs_config->{DISPLAY_COMPACT_DEPEND_INFORMATION} ;
	}
	
#~ use Data::Validate::IP qw(is_ipv4 is_loopback_ipv4);
#~ if(exists $pbs_config{LIGHT_WEIGHT_FORK})
	#~ {
	#~ my ($server, $port) = split(':', $pbs_config->{LIGHT_WEIGHT_FORK}) ;
	
	#~ unless(is_ipv4($server) || is_loopback_ipv4($server))
		#~ {
		#~ die ERROR "Error: IP error '$pbs_config->{LIGHT_WEIGHT_FORK}' to -ubs\n" ;
		#~ }
	#~ }
	
# segmentation fault because of missing ':' and use statement placement.
#~ if(exists $pbs_config->{LIGHT_WEIGHT_FORK})
	#~ {
	#~ my ($server, $port) = split(':', $pbs_config->{LIGHT_WEIGHT_FORK}) ;
	#~ use Net:IP ;
	#~ my $ip = new Net::IP ($server) or die ERROR 'Error: invalid IP given to -ubs' ;
	#~ }
	
if(defined $pbs_config->{DISPLAY_COMPACT_DEPEND_INFORMATION})
	{
	$pbs_config->{NO_SUBPBS_INFO}++ ;
	}
	
if(defined $pbs_config->{DISPLAY_NO_PROGRESS_BAR})
	{
	delete $pbs_config->{DISPLAY_PROGRESS_BAR} ;
	}
	
if(defined $pbs_config->{DISPLAY_PROGRESS_BAR})
	{
	$PBS::Shell::silent_commands++ ;
	$PBS::Shell::silent_commands_output++ ;
	$pbs_config->{DISPLAY_NO_BUILD_HEADER}++ ;
	}
	
if(defined $pbs_config->{NO_WARP})
	{
	$pbs_config->{WARP} = 0 ;
	}
else
	{
	unless(defined $pbs_config->{WARP})
		{
		$pbs_config->{WARP} = 1.5 ;
		}
	}

if(defined $pbs_config->{DISPLAY_PBS_TIME})
	{
	$pbs_config->{DISPLAY_PBS_TOTAL_TIME}++ ;
	$pbs_config->{DISPLAY_TOTAL_BUILD_TIME}++ ;
	$pbs_config->{DISPLAY_TOTAL_DEPENDENCY_TIME}++ ;
	$pbs_config->{DISPLAY_CHECK_TIME}++ ;
	$pbs_config->{DISPLAY_WARP_TIME}++ ;
	}

if($pbs_config->{DISPLAY_DEPENDENCY_TIME})
	{
	$pbs_config->{DISPLAY_TOTAL_DEPENDENCY_TIME}++ ;
	}

if($pbs_config->{NO_SUBPBS_INFO} || $pbs_config->{DISPLAY_COMPACT_DEPEND_INFORMATION})
	{
	undef $pbs_config->{DISPLAY_DEPENDENCY_TIME} ;
	}

if($pbs_config->{TIME_BUILDERS})
	{
	$pbs_config->{DISPLAY_TOTAL_BUILD_TIME}++ ;
	}

$pbs_config->{DISPLAY_PBSUSE_TIME}++ if(defined $pbs_config->{DISPLAY_PBSUSE_TIME_ALL}) ;

$pbs_config->{DISPLAY_HELP}++ if defined $pbs_config->{DISPLAY_HELP_NARROW_DISPLAY} ;

$pbs_config->{DEBUG_DISPLAY_RULES}++ if defined $pbs_config->{DEBUG_DISPLAY_RULE_DEFINITION} ;

$pbs_config->{DISPLAY_USED_RULES}++ if defined $pbs_config->{DISPLAY_USED_RULES_NAME_ONLY} ;
	
$pbs_config->{DEBUG_DISPLAY_DEPENDENCIES}++ if defined $pbs_config->{DEBUG_DISPLAY_DEPENDENCY_RULE_DEFINITION} ;
$pbs_config->{DEBUG_DISPLAY_DEPENDENCIES}++ if defined $pbs_config->{DEBUG_DISPLAY_DEPENDENCIES_LONG} ;

if(@{$pbs_config->{DISPLAY_DEPENDENCIES_REGEX}})
	{
	$pbs_config->{DEBUG_DISPLAY_DEPENDENCIES}++ ;
	}
else
	{
	push @{$pbs_config->{DISPLAY_DEPENDENCIES_REGEX}}, '.*' ;
	}

$pbs_config->{DEBUG_DISPLAY_TRIGGER_INSERTED_NODES} = undef if(defined $pbs_config->{DEBUG_DISPLAY_DEPENDENCIES}) ;

$pbs_config->{DISPLAY_DIGEST}++ if defined $pbs_config->{DISPLAY_DIFFERENT_DIGEST_ONLY} ;


$pbs_config->{DISPLAY_SEARCH_INFO}++ if defined $pbs_config->{DISPLAY_SEARCH_ALTERNATES} ;

if(defined $pbs_config->{BUILD_AND_DISPLAY_NODE_INFO} || @{$pbs_config->{DISPLAY_BUILD_INFO}} || @{$pbs_config->{DISPLAY_NODE_INFO}})
	{
	undef $pbs_config->{BUILD_AND_DISPLAY_NODE_INFO} if (@{$pbs_config->{DISPLAY_BUILD_INFO}}) ;
	
	$pbs_config->{DISPLAY_NODE_ORIGIN}++ ;
	$pbs_config->{DISPLAY_NODE_DEPENDENCIES}++ ;
	$pbs_config->{DISPLAY_NODE_BUILD_CAUSE}++ ;
	$pbs_config->{DISPLAY_NODE_BUILD_RULES}++ ;
	$pbs_config->{DISPLAY_NODE_BUILDER}++ ;
	$pbs_config->{DISPLAY_NODE_BUILD_POST_BUILD_COMMANDS}++ ;
	
	undef $pbs_config->{DISPLAY_NO_BUILD_HEADER} ;
	}
	
# ------------------------------------------------------------------------------

$pbs_config->{GENERATE_TREE_GRAPH_DISPLAY_ROOT_BUILD_DIRECTORY} = undef if(defined $pbs_config->{GENERATE_TREE_GRAPH_DISPLAY_BUILD_DIRECTORY}) ;

$pbs_config->{GENERATE_TREE_GRAPH_DISPLAY_CONFIG}++ if(defined $pbs_config->{GENERATE_TREE_GRAPH_DISPLAY_CONFIG_EDGE}) ;
$pbs_config->{GENERATE_TREE_GRAPH_DISPLAY_PBS_CONFIG}++ if(defined $pbs_config->{GENERATE_TREE_GRAPH_DISPLAY_PBS_CONFIG_EDGE}) ;

for my $cluster_node_regex (@{$pbs_config->{GENERATE_TREE_GRAPH_CLUSTER_NODE}})
	{
	#~ print "$cluster_node_regex " ;
	
	$cluster_node_regex = './' . $cluster_node_regex unless ($cluster_node_regex =~ /^\.|\//) ;
	$cluster_node_regex =~ s/\./\\./g ;
	$cluster_node_regex =~ s/\*/.*/g ;
	$cluster_node_regex = '^' . $cluster_node_regex . '$' ;
	
	#~ print "=> $cluster_node_regex\n" ;
	}

for my $exclude_node_regex (@{$pbs_config->{GENERATE_TREE_GRAPH_EXCLUDE}})
	{
	#~ print "$exclude_node_regex => " ;
	$exclude_node_regex =~ s/\./\\./g ;
	$exclude_node_regex =~ s/\*/.\*/g ;
	#~ print "$exclude_node_regex\n" ;
	}

for my $include_node_regex (@{$pbs_config->{GENERATE_TREE_GRAPH_INCLUDE}})
	{
	#~ print "$include_node_regex => " ;
	$include_node_regex =~ s/\./\\./g ;
	$include_node_regex =~ s/\*/.\*/g ;
	#~ print "$include_node_regex\n" ;
	}
	
#-------------------------------------------------------------------------------
# build or not switches
if($pbs_config->{NO_BUILD} && $pbs_config->{FORCE_BUILD})
	{
	return(0, "-force_build and -no_build switch can't be given simulteanously\n") ;
	}
	
$pbs_config->{DO_BUILD} = 0 if $pbs_config->{NO_BUILD} ;

unless($pbs_config->{FORCE_BUILD})
	{
	while(my ($debug_flag, $value) = each %$pbs_config) 
		{
		if($debug_flag =~ /^DEBUG/ && defined $value)
			{
			$pbs_config->{DO_BUILD} = 0 ;
			keys %$pbs_config;
			last ;
			}
		}
	}
#-------------------------------------------------------------------------------

$pbs_config->{DISPLAY_DIGEST}++ if $pbs_config->{DISPLAY_DIFFERENT_DIGEST_ONLY} ;

$pbs_config->{DISPLAY_FILE_LOCATION}++ if $pbs_config->{DISPLAY_ALL_FILE_LOCATION} ;
$pbs_config->{DEBUG_DISPLAY_BUILD_SEQUENCE}++ if defined $pbs_config->{DEBUG_DISPLAY_BUILD_SEQUENCE_NAME_ONLY} ;

$Data::Dumper::Maxdepth = $pbs_config->{MAX_DEPTH} if defined $pbs_config->{MAX_DEPTH} ;
$Data::Dumper::Indent   = $pbs_config->{INDENT_STYLE} if defined $pbs_config->{INDENT_STYLE} ;

if(defined $pbs_config->{DISTRIBUTE} && ! defined $pbs_config->{JOBS})
	{
	$pbs_config->{JOBS} = 0 ; # let distributor determine how many jobs
	}

if(defined $pbs_config->{JOBS} && $pbs_config->{JOBS} < 0)
	{
	return(0, "Invalid value '$pbs_config->{JOBS}' for switch -j/-jobs\n") ;
	}
	
if(defined $pbs_config->{DEBUG_DISPLAY_TREE_NODE_TRIGGERED_REASON})
	{
	$pbs_config->{DEBUG_DISPLAY_TREE_NODE_TRIGGERED} = 1 ;
	}

if(defined $pbs_config->{DEBUG_DISPLAY_TREE_NAME_ONLY})
	{
	$pbs_config->{DEBUG_DISPLAY_TEXT_TREE} = '' unless $pbs_config->{DEBUG_DISPLAY_TEXT_TREE} ;
	}
	
if(defined $pbs_config->{DISPLAY_TEXT_TREE_USE_ASCII})
	{
	$pbs_config->{DISPLAY_TEXT_TREE_USE_ASCII} = 1 ;
	}
else
	{
	$pbs_config->{DISPLAY_TEXT_TREE_USE_ASCII} = 0 ;
	}

$pbs_config->{DISPLAY_TEXT_TREE_MAX_DEPTH} = -1 unless defined $pbs_config->{DISPLAY_TEXT_TREE_MAX_DEPTH} ;

#--------------------------------------------------------------------------------

$Data::TreeDumper::Startlevel = 1 ;
$Data::TreeDumper::Useascii   = $pbs_config->{DISPLAY_TEXT_TREE_USE_ASCII} ;
$Data::TreeDumper::Maxdepth   = $pbs_config->{DISPLAY_TEXT_TREE_MAX_DEPTH} ;

#--------------------------------------------------------------------------------

my ($pbsfile, $error_message) = GetPbsfileName($pbs_config) ;

return(0, $error_message) unless defined $pbsfile ;

$pbs_config->{PBSFILE} = $pbsfile ;
$pbs_config->{PBSFILE} = './' . $pbs_config->{PBSFILE} unless $pbs_config->{PBSFILE}=~ /^\.|\// ;

#--------------------------------------------------------------------------------

my $cwd = getcwd() ;
if(0 == @{$pbs_config->{SOURCE_DIRECTORIES}})
	{
	push @{$pbs_config->{SOURCE_DIRECTORIES}}, $cwd ;
	}

for my $plugin_path (@{$pbs_config->{PLUGIN_PATH}})
	{
	unless(file_name_is_absolute($plugin_path))
		{
		$plugin_path = catdir($cwd, $plugin_path)  ;
		}
		
	$plugin_path = PBS::PBSConfig::CollapsePath($plugin_path ) ;
	}
	
unless(defined $pbs_config->{BUILD_DIRECTORY})
	{
	if(defined $pbs_config->{MANDATORY_BUILD_DIRECTORY})
		{
		return(0, "No Build directory given and --mandatory_build_directory set.\n") ;
		}
	else
		{
		$pbs_config->{BUILD_DIRECTORY} = $cwd . "/out_" . GetUserName() ;
		}
	}

if(defined $pbs_config->{LIB_PATH})
	{
	for my $lib_path (@{$pbs_config->{LIB_PATH}})
		{
		$lib_path .= '/' unless $lib_path =~ /\/$/ ;
		}
	}

# compute a signature for the current PBS run
# check if a signature exists in the output directory
# OK if the signatures match
# on mismatch, ask for another output directory or force override

CheckPackageDirectories($pbs_config) ;

#----------------------------------------- Log -----------------------------------------
undef $pbs_config->{CREATE_LOG} if defined $pbs_config->{DISPLAY_LAST_LOG} ;

PBS::Log::CreatePbsLog($pbs_config) if(defined $pbs_config->{CREATE_LOG}) ;


return(1, $success_message) ;
}

#-------------------------------------------------------------------------------

my $parse_prf_switches_run = 0 ; # guaranty we load stuff in the right package

use constant PARSE_PRF_SWITCHES_IGNORE_ERROR => 1 ;

sub ParsePrfSwitches
{
my ($no_anonymous_pbs_response_file, $pbs_response_file_to_use, $load_package, $ignore_error) = @_ ; # reference to the config in the PBS namespace

my $package = caller() ;
my $prf_load_package = 'PBS_PRF_SWITCHES_' . $package . '_' . $parse_prf_switches_run ;

if(defined $load_package)
	{
	$prf_load_package = $load_package ;
	}
else
	{
	# we load the prf in its own namespace
	PBS::PBSConfig::RegisterPbsConfig($prf_load_package, {}) ;
	}
	
my $pbs_response_file ;
unless($no_anonymous_pbs_response_file)
	{
	$pbs_response_file = 'pbs.prf' if(-e 'pbs.prf') ;
	}

my $user = GetUserName() ;

$pbs_response_file = "$user.prf" if(-e "$user.prf") ;
$pbs_response_file =  $pbs_response_file_to_use if(defined $pbs_response_file_to_use) ;

if($pbs_response_file)
	{
	unless(-e $pbs_response_file)
		{
		die ERROR "Error! Can't find prf '$pbs_response_file'." ;
		}
		
	PBS::PBSConfig::RegisterPbsConfig($prf_load_package, {PRF_IGNORE_ERROR => $ignore_error}) ;
	
	use PBS::PBS;
	PBS::PBS::LoadFileInPackage
		(
		  'Pbsfile' # $type
		, $pbs_response_file
		, $prf_load_package
		, {} #$pbs_config
		, "use PBS::Prf ;\n" #$pre_code
		 ."use PBS::Output ;\n"
		, '' #$post_code
		) ;

	my $pbs_config = GetPbsConfig($prf_load_package) ;
	delete $pbs_config->{PRF_IGNORE_ERROR} ;
	
	return($pbs_response_file, $pbs_config) ;
	}
else
	{
	return('no prf defined', {}) ;
	}
}

#-------------------------------------------------------------------------------

sub GetPbsfileName
{
my $pbs_config = shift ;

my $pbsfile = '' ;
my $error_message = '' ;

if(defined $pbs_config->{PBSFILE})
	{
	$pbsfile = $pbs_config->{PBSFILE} ;
	}
else
	{
	my @pbsfile_names;
	if($^O eq 'MSWin32')
		{
		@pbsfile_names = qw(pbsfile.pl pbsfile) ;
		}
	else
		{
		@pbsfile_names = qw(Pbsfile.pl pbsfile.pl Pbsfile pbsfile) ;
		}

	my %existing_pbsfile = map{( $_ => 1)} grep { -e "./$_"} @pbsfile_names ;
	
	if(keys %existing_pbsfile)
		{
		if(keys %existing_pbsfile == 1)
			{
			($pbsfile) = keys %existing_pbsfile ;
			}
		else
			{
			$error_message = "PBS has found the following Pbsfiles:\n" ;
			
			for my $found_pbsfile (keys %existing_pbsfile)
				{
				$error_message .= "\t$found_pbsfile\n" ;
				}
				
			$error_message .= "Only one can be defined!\n" ;
			}
		}
	else
		{
		$error_message = "No 'Pbsfile' to define build.\n" ;
		}
	}

return($pbsfile, $error_message) ;
}

#-------------------------------------------------------------------------------

sub CollapsePath
{
#remove '.' and '..' from a path

my $collapsed_path = shift ;

#~ PrintDebug $collapsed_path  ;

$collapsed_path =~ s~(?<!\.)\./~~g ;
$collapsed_path =~ s~/\.$~~ ;

1 while($collapsed_path =~ s~[^/]+/\.\./~~) ;
$collapsed_path =~ s~[^/]+/\.\.$~~ ;

# remove double separators
$collapsed_path =~ s~\/+~\/~g ;

# collaps to root
$collapsed_path =~ s~^/(\.\./)+~/~ ;

#remove trailing '/'
$collapsed_path =~ s~/$~~ unless $collapsed_path eq '/' ;

#~ PrintDebug " => $collapsed_path\n"  ;

return($collapsed_path) ;
}

#-------------------------------------------------------------------------------

sub CheckPackageDirectories
{
my $pbs_config = shift ;

my $cwd = getcwd() ;

if(defined $pbs_config->{SOURCE_DIRECTORIES})
	{
	for my $source_directory (@{$pbs_config->{SOURCE_DIRECTORIES}})
		{
		unless(file_name_is_absolute($source_directory))
			{
			$source_directory = catdir($cwd, $source_directory) ;
			}
			
		$source_directory = CollapsePath($source_directory) ;
		}
	}
	
if(defined $pbs_config->{BUILD_DIRECTORY})
{
	unless(file_name_is_absolute($pbs_config->{BUILD_DIRECTORY}))
		{
		$pbs_config->{BUILD_DIRECTORY} = catdir($cwd, $pbs_config->{BUILD_DIRECTORY}) ;
		}
		
	$pbs_config->{BUILD_DIRECTORY} = CollapsePath($pbs_config->{BUILD_DIRECTORY}) ;
	}
}

#-------------------------------------------------------------------------------

1 ;

#-------------------------------------------------------------------------------

__END__