Util::Parfile (version $)


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;