package Util::Parfile;
##############################################################################
#
# DESCRIPTION: This is an interface to an IRAF/FTOOLS parameter file.
#
# HISTORY
# HISTORY: $Log: Parfile.pm,v $
# HISTORY: Revision 1.6 2014/02/27 07:01:07 apsop
# HISTORY: VERSION header now shows CVS Revision
# HISTORY:
# HISTORY: Revision 1.5 2011/01/18 20:43:38 apsop
# HISTORY: Modified subroutine set for better handling of parametr files
# HISTORY:
# HISTORY: Revision 1.4 2007/04/18 22:45:38 apsop
# HISTORY: Bug fix on the error call.
# HISTORY:
# HISTORY: Revision 1.3 2007/01/31 15:43:37 apsop
# HISTORY: Read and write parameter files directly from Perl, instead of calling pset/pget.
# HISTORY:
# HISTORY: Revision 1.2 2006/08/01 20:35:34 apsop
# HISTORY: Add in CVS history indicator.
# HISTORY:
# 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: $Revision: 1.6 $
#
##############################################################################
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}={};
}
sub _parse_line {
my $self = shift;
my $line =shift;
chomp $line;
my @fields;
my $quote=0;
######################################################
# Line delimited by commas. Have to deal with commas
# embedded in quotes.
######################################################
foreach my $s ( split(',', $line, -1) ){
if($quote){
$fields[-1] .= ',' . $s;
}else{
push @fields, $s;
}
$quote = (++$quote)%2 if( $s =~ /"/ && $s !~ /".*"/ );
}
if( @fields != 7 ){
$self->error("Unable to parse parameter line: |$line|");
}
return @fields;
}
############################################################################
# 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(open PARFILE, "<$self->{NAME}") {
$value="";
while (<PARFILE>) {
next if /^#/;
my @fields = $self->_parse_line($_);
next unless $fields[0] =~ /^\s*${param}\s*$/;
$value = $fields[3];
$value =~ s/^[\"\s]+//;
$value =~ s/[\"\s]+$//;
# last;
}
close PARFILE;
}else{
$value="";
$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
# appears.
###############################################################
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{
my $self=shift;
my $params=shift;
my @keys = keys(%$params);
my @K = sort {$a cmp $b} @keys;
my %Hk;
my $strK = '';
foreach my $k (@K){
$strK .= "$k, ";
$Hk{$k} = 1;
}
$strK =~ s/\,\s+$//;
my $temp = $self->{NAME} .".tmp";
unless( open TEMP, ">$temp" ){
$self->error("Can't open for reading file");
return;
}
my %Par;
if(open PARFILE, "<$self->{NAME}") {
my $changes = 0;
foreach my $line (<PARFILE>) {
# my $param = ( grep $line=~/^\s*$_\s*,/, @keys )[0];
# if($param){
my $param = (split/\,/, $line )[0];
if(exists $Hk{$param}){
my $value = $params->{$param};
$value = '"'. $value .'"' if $value=~/[^\w\.\-\+]/;
my @fields = $self->_parse_line($line);
$fields[3] = $value;
$line = join(',', @fields) ."\n";
$changes++;
$Par{$param} = 1;
}
print TEMP $line;
}
close PARFILE;
if ($changes > scalar(@keys)) {
my $strer = '';
foreach my $k (keys %Par) {
if (!exists $Hk{$k}) {
$strer .= "Param $k does not exist in file $self->{NAME}\n";
}
}
$self->error($strer);
}
}else{
$self->error("Can't read parameters using perl from");
close TEMP;
unlink $temp;
return;
}
close TEMP;
rename $temp, $self->{NAME};
##############################################
# now set the parameters in internal storage
# in case we want to read them later
##############################################
foreach my $key (@keys) {
if( $params->{$key} eq '' ){
delete $self->{CACHE}->{$key};
}else{
$self->{CACHE}->{$key} = $params->{$key};
}
}
}
sub set_pset { #({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;