File Coverage

blib/lib/Astro/IRAF/CL.pm

Criterion	Covered	Total	%
statement	30	469	6.4
branch	0	140	0.0
condition	0	80	0.0
subroutine	10	59	16.9
pod	0	25	0.0
total	40	773	5.1

package Astro::IRAF::CL;
use strict;
use warnings;

$SIG{INT} = sub {die}; # Without this DESTROY() does not get called
		       # when ctrl-c is used for some reason.

use Carp;
use vars qw($VERSION $AUTOLOAD $TIMEOUT);

$VERSION = '0.2.0';

use Fcntl qw(:DEFAULT);

use Cwd;
use Expect 1.15;
use Env qw(IRAF_START);

my $DEBUG = 0;

$Expect::Debug=$DEBUG;
$Expect::Exp_Internal=$DEBUG;
$Expect::Log_Stdout=$DEBUG;

$TIMEOUT = 10; # Time out for internal commands (seconds).

sub new{
  my ($class,%params) = @_;

  my $self = bless {}, $class;

  $self->{'start_params'}    = \%params; #Need this to allow restart post-crash

  $self->{'iraf_start'}      = $params{'iraf_start'}||$self->_get_iraf_start();

  $self->{'debug'}           = $params{'debug'}           || 0;
  $self->{'work_dir'}        = $params{'work_dir'}        || cwd;
  $self->{'log'}             = $params{'log'}             || *STDERR;
  $self->{'display_startup'} = $params{'display_startup'} || 0;

  $self->{'cl_prompt'}       = qr/^cl>\s+/;
  $self->{'continue_prompt'} = qr/>>>\s+/;

  $self->{'packages'}        = []; # For loading/unloading packages.
  $self->{'command_history'} = [];
  $self->{'dead'}            = 1; # It is dead until the CL is running.

  $self->{'session'} = $self->_startup;

  $self->_get_available_commands_and_packages('main');

  if (exists $params{'packages'}){
    foreach my $package (@{$params{'packages'}}){
      $self->load_package($package);
    }
  }

  if (exists $params{'set'}){
    $self->set(%{$params{'set'}});
  }

  return $self;
}

sub _get_iraf_start{
  my $self = shift @_;

  my $startdir;

  if (defined $IRAF_START){	# If a user has an odd place for their IRAF
    $startdir = $IRAF_START;	# base directory then they should use this
				# environment variable to say so.
  }
  else{

    # Make educated guesses as to where the IRAF login.cl might be hiding.

    # If you have any other alternatives you could add them in here
    # This is only really for general places rather than unique odd places
    # though, use IRAF_START or the uparm parameter for those.

    my $found = 0;

    use Env qw(USER HOME);

    my $username = getlogin() || getpwuid($<) || $USER || `whoami`;

    foreach ($HOME,"$HOME/iraf","/home/$username/iraf","/home/$username") {

      if (-e "$_/login.cl" && -d "$_/uparm/"){
	$startdir = $_;
	$found = 1;
	last;
      }
    }

    croak "Do not know where to start IRAF from" if !$found;
  }

  return $startdir;
}

sub _lock_startdir{
  my $self = shift @_;

  sysopen(STARTDIR,"$self->{'iraf_start'}/Astro-IRAF-CL.LOCK",O_WRONLY|O_CREAT|O_EXCL) or croak "\nERROR: Could not get a lock on $self->{'iraf_start'}: $!\n\nThis IRAF start directory is already in use by another Astro::IRAF::CL object,\nyou must specify a different starting position via the iraf_start parameter.\n\nDied";

  $self->{'STARTDIR_FH'} = *STARTDIR;

}

sub _unlock_startdir{
  my $self = shift @_;

  close ($self->{'STARTDIR_FH'}) or croak "could not close lock FH";
  unlink "$self->{'iraf_start'}/Astro-IRAF-CL.LOCK";

}

sub _startup{
  my $self = shift @_;

  $self->_lock_startdir;

  chdir $self->{'iraf_start'} ||croak "Could not cd to $self->{'iraf_start'}";

  my $t = Expect->spawn('cl') || croak "Cannot spawn CL: $!";

  $t->expect(30,'-re',$self->{'cl_prompt'});
  croak "Did not get CL prompt after starting up" if $t->error;

  $self->{'dead'} = 0; # It is now alive.

  my $output = $t->before();
  my @output = split /\n/,$output;
  if ($self->{'display_startup'}){
    for (@output){print STDOUT $_ . "\n"}
  }

  chdir $self->{'work_dir'} || croak "Could not cd to $self->{'work_dir'}";

  $t->print("cd $self->{'work_dir'}\r");
  $t->expect($TIMEOUT,"cd $self->{'work_dir'}\r\n");
  $t->expect($TIMEOUT,'-re',$self->{'cl_prompt'});
  croak "Did not get CL prompt back after trying to cd to $self->{'cl_prompt'}"
    if $t->error;

  return $t;
}

sub restart{
  my $self = shift @_;

# Kill the session if it isn't already dead.

  $self->end() if !$self->{'dead'};

# Reset various parameters so everything works nicely.

  $self->{'dead'} = 0;
  $self->{'cl_prompt'} = qr/^cl>\s+/;

  $self->{'session'} = $self->_startup;

  $self->_get_available_commands_and_packages('main');

# Get the list of previously loaded packages then reset the list.

  my @prev_loaded_packages = @{$self->{'packages'}};
  $self->{'packages'} = [];

# Load packages that were originally specified at start time.

  if (exists $self->{'start_params'}{'packages'}){
    foreach my $package (@{$self->{'start_params'}{'packages'}}){
      $self->load_package($package);
    }
  }

# Set definitions that were originally specified.

  if (exists $self->{'start_params'}{'set'}){
    $self->set(%{$self->{'start_params'}{'set'}});
  }

# Load any other packages that were subsequently loaded.

  foreach my $package (@prev_loaded_packages){
    $self->load_package($package) if !$self->package_is_loaded($package);
  }

}


sub _internal_command{
  my ($self,$command) = @_;

  my $session = $self->{'session'};

  $session->print("$command\r");
  $session->expect($TIMEOUT,"$command\r\n");
  $session->expect($TIMEOUT,'-re',$self->{'cl_prompt'});

  my $output = $session->before();
  $output =~ s/(\r\n)*$//;

  return $output;
}

## IRAF package management.

sub package_is_loaded{
  my ($self,$package) = @_;

  my $loaded = grep {$_ eq $package} @{$self->{'packages'}};

  return $loaded;
}

sub package_exists{
  my ($self,$package) = @_;

  my $defined = $self->_internal_command("print deftask\(\"$package\"\)");

  my $result = $defined eq 'yes' ? 1 : 0;

  return $result;
}


sub load_package{
  my ($self,$package) = @_;

  if (!$self->package_exists($package)){
    croak "Error: Trying to load a package ($package) that does not exist";
  }

  $self->_register_package($package);

  my $output = $self->_internal_command("$package");
  $self->_add_to_command_history($package);

  my @output = $output ? split(/\n/,$output) : ();

  $self->_get_available_commands_and_packages($package);

  return @output;
}

sub _register_package{
  my ($self,$package) = @_;

  my $new_prompt = $self->_get_package_prompt($package);

  $self->_set_cl_prompt($new_prompt);

  unshift @{$self->{'packages'}},$package;

}

sub _get_package_prompt{
  my ($self,$package) = @_;

  my $new_prompt = substr($package,0,2);
  $new_prompt = qr/^$new_prompt>\s+/;

  return $new_prompt;
}

sub _deregister_package{
  my ($self,$package) =  @_;

  my $current_package = $self->get_current_package();

  $package ||= $current_package;

  croak "Unloading packages in wrong order, current package is $current_package, you are trying to unload $package" if $package ne $current_package;

  shift @{$self->{'packages'}};

  my $next_package = $self->get_current_package() || 'cl';

  my $new_prompt = $self->_get_package_prompt($next_package);

  $self->_set_cl_prompt($new_prompt);

}

sub unload_package{
  my ($self,$package) =  @_;

  $self->_deregister_package($package);

  my $output = $self->_internal_command('bye');
  $self->_add_to_command_history('bye');

  my @output = $output ? split(/\n/,$output) : ();

  delete ${$self->{'available_commands'}}{'package'};
  delete ${$self->{'available_packages'}}{'package'};

  return @output;
}

sub get_current_package{
  my $self = shift @_;

  my $current_package = ${$self->{'packages'}}[0];

  return $current_package;

}

sub unload_all_packages{
  my $self = shift @_;

  while (defined (my $current_package = $self->get_current_package)){
    $self->unload_package($current_package);
  }

}

##

## History manipulation routines.

sub _add_to_command_history{
  my ($self,$command) = @_;

  push @{$self->{'command_history'}},$command;

  if ($self->{'debug'}){
    my $log = $self->{'log'};
    print $log 'CL: ' . $command . "\n";
  }

}

sub get_from_command_history{
  my ($self,$position) = @_;

  return ${$self->{'command_history'}}[$position];

}

sub exec_from_history{
  my ($self,$position,%params) = @_;

  my $command = $self->get_from_command_history($position);

  my @output = $self->exec(command => $command,
			   %params);

  if (wantarray){
    return @output;
  }
  elsif(defined wantarray){
    return $output[0];
  }

}

## Set parameter routines

sub _set_cl_prompt{
  my ($self,$prompt) = @_;

  $self->{'cl_prompt'} = $prompt;

}

sub set_log{
  my ($self,$log) = @_;

  $self->{'log'} = $log;
}

## Error handlers.

sub cl_warning_handler{
  my ($self,$command,$handler) = @_;

  my $session = $self->{'session'};
  $session->expect($TIMEOUT,'-re',$self->{'cl_prompt'});

  my $error = $session->before();

  print STDERR "The command $command encountered a CL Warning:\n\n$error\n";

  if (defined $handler){
    print STDERR "Passing off to warning handler\n";
    $handler->($self);
  }

  return;
}

sub cl_error_handler{
  my ($self,$command,$handler) = @_;

  my $session = $self->{'session'};
  $session->expect($TIMEOUT,'-re',$self->{'cl_prompt'});

  my $error = $session->before();

  print STDERR "The command $command encountered a CL ERROR:\n\n$error\n";

  if (defined $handler){
    print STDERR "Passing off to error handler\n";
    $handler->($self);
  }
  else{
    die;
  }

  return;
}

sub eof_handler{
  my ($self,$command,$handler) = @_;

  print STDERR "The command $command suffered an eof error\n";

  if (defined $handler){
    print STDERR "Passing off to death handler\n";
    $handler->($self);
  }
  else{
    die;
  }

  return;
}

sub timeout_handler{
  my ($self,$command,$timeout,$handler) = @_;

  my $session = $self->{'session'};

  $session->print("\cc"); # Send the command a control-c to stop it
  $session->expect($TIMEOUT,'-re',$self->{'cl_prompt'},
		   [eof => sub{&eof_handler($self,"control-c to $command")}]);

  print STDERR "The command \"$command\" timed out after $timeout seconds\n";

  if (defined $handler){
    print STDERR "Passing off to timeout handler\n";
    $handler->($self);
  }
  else{
    die;
  }

  return;
}

## IRAF session variable management.

sub set{
  my ($self,%params) = @_;

  my @output;
  foreach my $key (keys %params){
    my $value = $params{$key};

    my $output;
    if ($self->exists($key)){
      $output = $self->_internal_command("reset $key = $value");
      $self->_add_to_command_history("reset $key = $value");
    }
    else{
      $output = $self->_internal_command("set $key = $value");
      $self->_add_to_command_history("set $key = $value");
    }

    push @output,$output;
  }

  return @output;
}

sub show{
  my ($self,$key) = @_;

  my $output = '';
  if ($self->exists($key)){
    $output = $self->_internal_command("show $key");
    $self->_add_to_command_history("show $key");
  }

  return $output;

}

sub exists{
  my ($self,$key) = @_;

  my $output = $self->_internal_command("print (defvar (\"$key\"))");

  if ($output eq 'yes'){
    return 1;
  }
  else{
    return 0;
  }
}

sub _get_available_commands_and_packages{
  my ($self,$package) = @_;

  my $list = $self->_internal_command('?');

  my @list = split /\n/,$list;

  my @commands;
  my @packages;
  foreach my $line (@list){
    chomp $line;
    $line =~ s/^\s+//;
    my @foo = split /\s+/,$line;

    for (@foo){
      if (m/^([^.]+)\.$/){
	push @packages,$1;
      }
      else{
	push @commands,$_;
      }
    }

  }

  $self->{'available_commands'}{$package} = [@commands];
  $self->{'available_packages'}{$package} = [@packages];

}

sub list_available_commands{
  my ($self,$package) = @_;

  if (!$package){
    foreach my $package (keys %{$self->{'available_commands'}}){

      print STDOUT 'Package: ' . $package . "\n";

      foreach my $command (@{$self->{'available_commands'}{$package}}){

	print STDOUT "\t" . $command . "\n";

      }
    }
  }
  else{

    print STDOUT 'Package: ' . $package . "\n";

    foreach my $command (@{$self->{'available_commands'}{$package}}){

      print STDOUT "\t" . $command . "\n";

    }
  }
}

sub list_available_packages{
  my ($self,$package) = @_;

  if (!$package){
    foreach my $package (keys %{$self->{'available_packages'}}){

      print STDOUT 'Package: ' . $package . "\n";

      foreach my $command (@{$self->{'available_packages'}{$package}}){

	print STDOUT "\t" . $command . "\n";

      }
    }
  }
  else{

    print STDOUT 'Package: ' . $package . "\n";

    foreach my $command (@{$self->{'available_packages'}{$package}}){

      print STDOUT "\t" . $command . "\n";

    }
  }
}

sub package_is_available{
  my ($self,$package_wanted) = @_;

  foreach my $package_is_loaded (@{$self->{'packages'}},'main'){

    foreach my $package (@{$self->{'available_packages'}{$package_is_loaded}}){

      return 1 if $package eq $package_wanted;
    }
  }

  return 0;
}

sub command_is_available{
  my ($self,$command_wanted) = @_;

  foreach my $package_is_loaded (@{$self->{'packages'}},'main'){

    foreach my $command (@{$self->{'available_commands'}{$package_is_loaded}}){

      return 1 if $command eq $command_wanted;
    }
  }

  return 0;
}

sub exec{
  my ($self,%params) = @_;

  my $t = $self->{'session'};

  my @commands;

  if (exists $params{'command'}){
    @commands = split /\;/,$params{'command'};
    map {s/^\s+//} @commands;
  }
  else{
    croak 'You must specify an IRAF command to execute';
  }

  my $timeout = defined $params{'timeout'} ? $params{'timeout'} : undef;
  my $error_handler   = $params{'error_handler'}   || undef;
  my $warning_handler = $params{'warning_handler'} || undef;
  my $death_handler   = $params{'death_handler'}   || undef;
  my $timeout_handler = $params{'timeout_handler'} || undef;

  my ($q_timeout,$q_eof,$q_error,$q_warning,$not_available) = (0,0,0,0,0);

  my @output;

  foreach my $command (@commands){

    $self->_add_to_command_history($command);

    if (length($command) > 2047){
      my $length = length($command);
      croak "The length of the command $command is $length, this exceeds the maximum allowed CL command buffer size of 2047";
    }

    my ($helpfile,$helpname) = (0,'');
    if ($command =~ m/^help\s+(.+)/){
      $helpname = $1;
      $command = "help $helpname | type dev=text";
      $helpfile = 1;
    }

    if (length($command) > 72){

      my @strings = &_break_into_strings(string => $command,
					 max_length => 72);

      my $command_part;
      for my $k (0..($#strings-1)){
	$command_part = $strings[$k];

	$t->print("$command_part \\\r");
	$t->expect($TIMEOUT,'-ex',"$command_part \\\r\n");
	$t->expect($TIMEOUT,'-re',$self->{'continue_prompt'});
      }
      $command_part = $strings[$#strings];

      $t->print("$command_part\r");
      $t->expect($TIMEOUT,'-ex',"$command_part\r\n");
    }
    else{

      $t->print("$command\r");
      $t->expect($TIMEOUT,
		 [timeout => sub {&timeout_handler($self,$command,$TIMEOUT,
						   $timeout_handler);
				  $q_timeout = 1}],
		 '-ex',"$command\r\n");
    }

## Package management.

    my $possible_prompt = '#THIS SHOULD NEVER BE MATCHED#'; # Unless changed.

    if ($command =~ m/^\s*bye\s*$/){ # Removing the current package.
      $self->_deregister_package();
    }
    elsif ($command =~ m/^\s*\w+\s*$/){ # Possibly loading new package.
      if ($self->package_is_available($command)){
	$possible_prompt = $self->_get_package_prompt($command);
      }
    }
##

    $t->expect($timeout,
	       [timeout => sub {&timeout_handler($self,$command,$timeout,
						 $timeout_handler);
				$q_timeout = 1; exp_continue}],
	       [eof     => sub {&eof_handler($self,$command,
					     $death_handler);
				$q_eof = 1; exp_continue}],
	       '-re','^Warning:',sub {&cl_warning_handler($self,$command,
							  $warning_handler);
				    $q_warning = 1; exp_continue},
	       '-re','^ERROR:',sub {&cl_error_handler($self,$command,
						      $error_handler);
				    $q_error = 1; exp_continue},
	       '-ex','No help available for',sub{print STDERR "No help available for $helpname\n";
						 $not_available = 1;
					       },
	       '-re',$possible_prompt,sub{$self->_register_package($command)},
	       '-re',$self->{'cl_prompt'});

    next if ($q_timeout || $q_error || $q_eof || $not_available);

    my $output =  $t->exp_before();
    my @lines = split /\n/,$output;

    foreach my $line (@lines){
      chomp $line;
      $line =~ s/[\000-\037\x80-\xff]//g; # Remove any crud from the output.
      push @output,$line if ($helpfile || $line =~ m/(\d|\w)/);
    }

  }

  if (wantarray){
    return @output;
  }
  elsif(defined wantarray){
    return $output[0];
  }

}

sub load_task{
  my ($self,%params) = @_;

  my $name = $params{'name'} || croak 'Need a name for the task';
  my $file = $params{'file'} || croak "Need a filename for the task $name";
  my $task = $params{'task'} || '';
  my $par_file = $params{'par_file'} || 0; # Is there a param file or not?

  if ($task){
    open(FH,">$file");
    print FH $task . "\n";
    close(FH);
  }
  else{
    croak "You must give either a task command or a file containing the command for task $name" if !-e $file;
  }

# Check whether or not the task has been previously defined,
# the answer will be 'yes' or 'no'.

  my $defined_task = $self->_internal_command("print deftask\(\"$name\"\)");

# If there is not a parameter file to go with this script then we need to
# put a $ in front of the task name.

  $name = "\$" . $name if !$par_file;

# Load the task depending on whether or not it is previously defined.

  if ($defined_task eq 'no'){
    $self->_internal_command("task $name = $file");
    $self->_add_to_command_history("task $name = $file");
  }
  else{
    $self->_internal_command("redefine $name = $file");
    $self->_add_to_command_history("redefine $name = $file");
  }

}

sub _run_command{
  my ($self,$command,@pieces) = @_;

  my $class = ref $self;
  $command =~ s/^$class\:\://;

  foreach my $piece (@pieces){
    if (ref($piece) eq 'HASH'){

      foreach my $key (keys %{$piece}){
	my $value = ${$piece}{$key};
	$command = join ' ',$command,$key;
	$command = join '=',$command,$value if defined $value;
      }
    }
    else{
      $command = join ' ',$command,$piece;
    }
  }

  my @output = $self->exec(command => $command);

  return @output;
}

sub end{
  my $self = shift @_;

  return if $self->{'dead'};	# Ensure end() is not called more than once.

  $self->unload_all_packages;

  my $t = $self->{'session'};

  $t->print("\r");
  $t->expect($TIMEOUT,'-re',$self->{'cl_prompt'});

  $t->print("logout\r");
  $t->expect($TIMEOUT,"logout\r\n");

  $t->soft_close();

  $self->_unlock_startdir;

  $self->{'dead'} = 1;
}

sub DESTROY{
  my $self = shift @_;

  $self->end();

}

sub AUTOLOAD{
  no strict 'refs';
  my $self = shift @_;

  if ($AUTOLOAD =~ /.*::get_(\w+)/ && exists $self->{$1}){
    my $attr_name = $1;

    *{$AUTOLOAD} = sub { return $_[0]->{$attr_name}};

    return $self->{$attr_name};
  }
  else{
    my @output = _run_command($self,$AUTOLOAD,@_);
    if (wantarray){
      return @output;
    }
    elsif (defined wantarray){
      return $output[0];
    }
  }

}

# Description of subroutine _break_into_strings():
#
# This is a subroutine to take a long string and break it, on white
# space, into sub-strings that are less than or equal to some,
# user-specified maximum length.
#
# It must not break the string in the middle of an assignment context,
# e.g. foo = bar, this can only be broken before the foo or after the
# bar.
#
# Anything that is single or double-quoted in an assignment context
# must not be broken either. So, foo = "bar baz quux igwop" can only
# break before the foo or after the closing double-quote following the
# igwop.
#
# Single-quotes must be allowed inside double-quotes and vice-versa,
# escaping of quote signs must also be allowed, e.g. foo = "a'b",
# foo = "a\"b", foo = 'a"b', foo = 'a\'b'
#
# The routine takes in two parameters, the long string to be broken
# and the maximum allowed length of the returned strings. Possibly, a
# parameter controlling the string separator to split the input string
# on could be added. This would also be used for joining the strings
# again after tokenisation.
#
# The routine returns the list of correct length strings upon
# completion.
#
# Currently, single over-length strings are allowed where a long
# assignment occurs. A warning is given but possibly an error should
# be thrown but for my case the maximum length I will set will be much
# lower than the real maximum allowed length.
#

sub _break_into_strings{
  my %params = @_;

  my $long_string = $params{'string'}     || croak 'Need an input string';
  my $max_length  = $params{'max_length'} || 75;

  my @tokens = split /\s+/,$long_string;
  my @tokens2;

# Variables for storing current state.

  my ($in_assign,$equals,$in_squote,$in_dquote) = (0,0,0,0);

  my $posn = 0;
  for my $token (@tokens){

    if ($token eq '=') {
      $in_assign = 1;
      $equals = 1;
    }

    if ($in_assign){

      if ($equals){

	# Append that equals sign along with the necessary whitespace.

	$tokens2[-1] .= ' =';

	# Look ahead to see what's coming and see if we are going to start
	# a section of double or single quotes and change state if so.

	if ($tokens[$posn+1] =~ m/^\"/){
	  $in_dquote = 1;
	}
	elsif ($tokens[$posn+1] =~ m/^\'/){
	  $in_squote = 1;
	}
      }
      else{

	# Append the token plus necessary whitespace.

	$tokens2[-1] = $tokens2[-1] . ' ' . $token;

	# Work out if we need to close this assignment section yet.

	if (!$in_squote && !$in_dquote){ # Single value to append so stop.
	  $in_assign = 0;
	}
	elsif ($in_dquote && $token =~ m/(\\*)\"$/){
	  my $num = length $1;
	  if (!$num || (($num % 2) == 0)){ # Even num, thus not escaped.
	    $in_dquote = 0;
	    $in_assign = 0;
	  }
	}
	elsif ($in_squote && $token =~ m/(\\*)\'$/){
	  my $num = length $1;
	  if (!$num || (($num % 2) == 0)){ # Even num, thus not escaped.
	    $in_squote = 0;
	    $in_assign = 0;
	  }
	}

      }

      $equals = 0; # Always turn off the equals state.
    }
    else{
      push @tokens2,$token; # Nowt special here just add token to output stack.
    }

    ++$posn; # Keeping track of position in input stack.
  }

  # Build final stack of output strings with correct maximum length.
  # Note that if a single string is longer than the allowed maximum
  # length it will still be pushed on, thus best to ensure max_length
  # is a bit less than the real maximum allowed length. I think it's
  # better this way for my situation than to lose strings or keep
  # breaking.

  my @output;
  my $i = 0;
  $output[$i] = shift @tokens2;

  while (defined (my $line = shift @tokens2)){

    if ((length($output[$i]) + length($line) + 1) <= $max_length){
      $output[$i] = $output[$i] . ' ' . $line;
    }
    else{
      ++$i;

      my $length = length($line);
      if ($length > $max_length){
	carp "WARNING: Single assignment length ($length) is longer than maximum allowed string length ($max_length) in call to subroutine _break_into_strings(), will use anyway";
      }

      $output[$i] = $line;

    }
  }

  return @output;
}


1;
__END__