package Util::Parfile;
##############################################################################
#
# DESCRIPTION: This is an interface to an IRAF/FTOOLS parameter file.
#
# HISTORY: 1.0 -> 1.1 2002-04-01
# HISTORY: Fixed a minor bug in the error method. When this method is
# HISTORY: called by the class and not by an object, $self->{NAME} is
# HISTORY: meaningless. Made a sort of a cludgly fix by only appending
# HISTORY: the parfile name to the message if the log is defined.
# HISTORY:
# HISTORY: 1.1 -> 1.2 2002-04-19
# HISTORY: Changed the FTOOLS initialization method to take the install
# HISTORY: directory and not the bin directory and also to add the
# HISTORY: lib directory to LD_LIBRARY_PATH, since the FTOOLS initialization
# HISTORY: now only does this when it runs a tool.
# HISTORY:
# HISTORY: 1.2 -> 1.3
# HISTORY: Added special handling for when LD_LIBRARY_PATH is not already set
# HISTORY:
# HISTORY: 1.3 -> 1.4 2003-12-05
# HISTORY: now set LD_LIBRARY_PATh before running pget and then restore it when
# HISTORY: done.
# HISTORY: 1.4 -> 1.5 2005-04-01 Compensate for bug in pset which doesn't
# HISTORY: handle null values properly.
#
# VERSION: 1.5
#
##############################################################################
require Exporter;
*import = \&Exporter::import;
@EXPORT_OK = qw(isa can);
use IPC::Open3;
#use Util::Log;
use strict;
my $PGET="";
my $PSET="";
my $LOG="";
my $LD_LIBRARY_PATH="";
######################################
# constructor
######################################
sub new { #(name)
my $proto = shift;
my $class = ref($proto) || $proto;
my $self={};
$self->{NAME} = shift;
$self->{CACHE} = {}; # storage to remember params we have read
$self->{PGET_STDERR}="pget_stderr.log";
unlink $self->{PGET_STDERR};
bless($self,$class);
########################################
# make sure the parfile exists
########################################
if( ! -f $self->{NAME} ) {
$self->error("No such parfile");
}
return $self;
}
##############
# ACCESSORS:
##############
############################################
# get or set the name of the parameter file
############################################
sub name {
my $self = shift;
if (@_) { $self->{NAME} = shift }
return $self->{NAME};
}
######################################################################
# get or set the name of the program used to read the parameter file.
######################################################################
sub pget {
my $self = shift;
if (@_) {
#######################
# setting
#######################
$PGET = shift;
if( ! -x $PGET ) {
$self->error("Can't execute $PGET program");
}
}
return $PGET;
}
##########################################################################
# get or set the name of the program used to write to the parameter file.
##########################################################################
sub pset {
my $self = shift;
if (@_) { $PSET = shift }
return $PSET;
}
##########################################################################
# get or set the name of the Util::Log object.
# returns a new Util::NoLog object if there is no Log.
##########################################################################
sub log {
my $self = shift;
if (@_) { $LOG = shift }
if($LOG) {return $LOG}
else {return Util::NoLog->new() }
}
##########################################################################
# set the parfile reader and writer (pget and pset) given the
# FTOOLS instalation directory
##########################################################################
sub ftools {
my $self = shift;
my $ftools = shift;
###############################################
# get the pget/pset binary directory and the
# shared object library directory
###############################################
my $bin="$ftools/bin";
my $lib="$ftools/lib";
$LD_LIBRARY_PATH = $lib;
$self->pget("$bin/pget");
$self->pset("$bin/pset");
}
####################
# METHODS:
####################
##########################################################################
# prepare the LD_LIBRARY path for running pset or pget
##########################################################################
sub set_ld_library_path {
my $self = shift;
$self->{ORIGINAL_PATH}=$ENV{LD_LIBRARY_PATH};
if($LD_LIBRARY_PATH) {
##################################
# need to set the LD_LIBRARY_PATH
# before running pget
##################################
if($ENV{LD_LIBRARY_PATH}) {
$ENV{LD_LIBRARY_PATH}="$LD_LIBRARY_PATH:$ENV{LD_LIBRARY_PATH}";
} else {
$ENV{LD_LIBRARY_PATH}=$LD_LIBRARY_PATH;
}
}
} # end of set_ld_library_path method
##########################################################################
# return LD_LIBRARY path to its value the last time set_ld_library_path
# was run
##########################################################################
sub restore_ld_library_path {
my $self = shift;
$ENV{LD_LIBRARY_PATH}=$self->{ORIGINAL_PATH};
}
##########################################################################
# Parameter values are chached internally to save time when
# doing multiple reads of the same parameter. This can cause
# problems if the parameter is modified by some other means, so this method
# can be used to wipe out all cached values
##########################################################################
sub clear_param_cache {
my $self=shift;
$self->{CACHE}={};
}
############################################################################
# Read a value from the parfile.
# Note that parameter values are chached - see "clear_param_cache".
# For real values parameters, the optional
# accuracy argument specifies the number of decimal places to round to.
# For example accuracy=0.01 would round to the nearest hundredth.
###########################################################################
sub read {
my $self = shift;
my $param = shift;
my $accuracy=shift;
#####################################
# make sure the parameter is defined
# to avoid messes with pget
#####################################
if(!$param) {
$self->error("no parameter given to read from");
return "";
}
################################################
# get the parameter value in one of three ways
################################################
my $value;
if($self->{CACHE}->{$param} ) {
###############################################
# already read this param, return stored value
###############################################
$value=$self->{CACHE}->{$param};
} else {
################################################
# first time for this value get it from parfile
################################################
if($PGET) {
#####################################################
# we know a program for reading parfiles, so use it
# Note we redirect stderr to a tmp file instead of
# being clever with open3. The reason was the waitpid
# was hanging intermittently when this method was
# run via the in_per_parent mechanism.
#####################################################
$self->set_ld_library_path();
$value=`$PGET ./$self->{NAME} $param 2>$self->{PGET_STDERR}`;
$self->restore_ld_library_path();
chomp($value);
#####################################
# check for errors
#####################################
if( -s $self->{PGET_STDERR} ) {
###########################################
# there was an error, so read the file...
##########################################
open ERRORS, "<$self->{PGET_STDERR}";
my @errors=<ERRORS>;
close ERRORS;
########################################################
# clean up the stderr log now since
# reporting an error may call this method recursively
# to set nprocerrors
#######################################################
unlink $self->{PGET_STDERR};
##############################
# and report the error
##############################
$self->error("Error: ".
join ('', @errors) .
", while reading $param from");
} # end if there was an error
######################################
# clean up the stderr log
######################################
unlink $self->{PGET_STDERR};
} else {
####################################################
# No method defined for reading parfiles - probably
# because we don't know FTOOLSBIN yet - so
# just go and parse the parfile using perl
####################################################
if(open PARFILE, "<$self->{NAME}") {
$value="";
while (<PARFILE>) {
chomp;
if(/^\s*$param\s*,/) {
s/^[^,]*,[^,]*,[^,]*,\s*(.*?)\s*,.*/$1/;
s/^\"\s*//;
s/\s*\"$//;
$value=$_;
}
}
} else {$value=""}
close PARFILE;
if($value eq "") {
$self->error("Can't read $param using perl from");
}
}
#####################################
# save the value for repeated calls
#####################################
$self->{CACHE}->{$param}=$value;
} # end if we need to read the parfile
#########################################################
# round the value if an accuracy was given and return
#########################################################
if(defined $accuracy) {
##########################
# round before returning
##########################
my $round;
if($value>=0) {$round= 0.5 }
if($value<=0) {$round=-0.5}
return int($value/$accuracy + $round) * $accuracy;
} else {
#########################
# return as-is
#########################
return $value
}
} # end of read method
###############################################################
# check if a particular parameter exists in a parfile, and
# return the number of times that the specificed parameter
# apears.
###############################################################
sub has {
my $self=shift;
my $param=shift;
open FILE, "<$self->{NAME}";
my $count=grep /^${param}\s*,/, <FILE>;
close FILE;
return $count;
}
###################################################
# internal error handler
###################################################
sub error {
my $self = shift;
my $message = shift;
if($LOG) {
######################################
# log is defined so write error there
######################################
$message .= " ".$self->{NAME};
$LOG->error(2,$message);
} else {
print STDERR "$message\n";
exit 1;
}
} # end of error method
########################################################
# set a parameter in the parfile.
# Note the parameters are given as reference to a hash.
########################################################
sub set { #({name1=>value1, name2=>value2 ...})
my $self=shift;
my $params=shift;
#############################################
# loop over all keys to construct an
# argument string for pset
#############################################
my $arg="";
my $key;
foreach $key (keys(%$params)) {
if( $params->{$key} eq '' ){
$arg .= "$key=\" \" ";
}else{
$arg .= "$key=\"$params->{$key}\" ";
}
}
############################################
# run pset to actually set the parameters
############################################
$self->set_ld_library_path();
my $output=`$PSET ./$self->{NAME} $arg 2>&1`;
if($output) {
print "$PSET ./$self->{NAME} $arg\n\n\n";
print "$output\n";
}
$self->restore_ld_library_path();
my $status=0;
if($output || $status) {
$self->error("$output Error setting $arg in");
}
##############################################
# now set the parameters in internal storage
# in case we want to read them later
##############################################
foreach $key (keys(%$params)) {
if( $params->{$key} eq '' ){
delete $self->{CACHE}->{$key};
}else{
$self->{CACHE}->{$key} = $params->{$key};
}
}
} # end of set method
############################################################################
# increments a parameter by a given amount (defaults to 1)
# the user must make sure it is a numerical parameter
############################################################################
sub increment {
my $self = shift;
my $param = shift;
my $increment = shift || 1;
my $value=$self->read($param);
$value += $increment;
$self->set({$param=>$value});
} # end of increment method
1;