Util::Parfile (version 1.5)


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;