view release on metacpan or  search on metacpan

CL.pm  view on Meta::CPAN

    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");
  }

}