Astro-IRAF-CL
view release on metacpan or search on metacpan
$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'}){
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'} = [];
}
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 @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');
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{
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;
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)/);
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;
}
=item *
package_is_loaded($package) - Returns 1 if package is loaded, else 0, useful for ensuring a package is not loaded twice (this isn't fatal).
=item *
package_exists($package) - Checks if an IRAF package is available for loading, (via the IRAF command "deftask") returns 1, if true, else 0.
=item *
unload_package($package) - Unload a package (the same as typing "bye" in CL). Note that you must unload in the correct order (last in - first out) or the script will die as it would not be able to keep a correct track of the current package and its a...
=item *
unload_all_packages - Unload all packages that have been loaded in the current session, this is called automatically when the script ends or the object goes out of scope in anyway.
=item *
get_current_package - Returns the name of the current package, if none is loaded you get an undefined string.
=item *
=back
The position in the list is based on them being pushed onto a Perl array, so the most recent command is 0 (zero). The %params is the same as the hash passed into the exec() function.
=head1 NOTES
You can create as many concurrent IRAF objects as you want (or your system can manage anyway). You should note that each one really needs its own uparm directoctory from which to work to avoid parameter value collisions which could cause chaos. This ...
Some IRAF programs may need more persuasion than others to believe that they are being used in a non-interactive mode (well non-graphical anyway). If you have problems with this, you could try using the IRAF command "stty xterm", this has worked for ...
The script will convert long commands into lots of shorter strings and enter each into the CL interpreter followed by a line continuation. This allows much longer commands to be entered than by just sending it all in one go. The routine tries to brea...
=head1 BUGS
These are not so much bugs as short-comings with the current code.
There is no way to specify a time out length, or any error/exception handlers when executing the command directly rather than via the exec() call.
There is currently no way when executing a command from the history to also recall any previously specified time out or error/exception handlers. This can be thought of as both a bug and a feature.
Any bugs, modifications or suggestions for improvements should be sent to the email address given below.
( run in 0.870 second using v1.01-cache-2.11-cpan-6aa56a78535 )