490 lines
12 KiB
Perl
490 lines
12 KiB
Perl
######################################################################
|
|
# EPICS BASE is distributed subject to a Software License Agreement
|
|
# found in file LICENSE that is included with this distribution.
|
|
#
|
|
# Original Author: Shantha Condamoor, SLAC
|
|
# Creation Date: 1-Sep-2011
|
|
# Current Author: Andrew Johnson
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
package EPICS::IOC;
|
|
require 5.010;
|
|
|
|
=head1 NAME
|
|
|
|
EPICS::IOC - Manage an EPICS IOC
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use EPICS::IOC;
|
|
|
|
my $ioc = EPICS::IOC->new;
|
|
$ioc->debug(1); # Show IOC stdio streams
|
|
|
|
$ioc->start('bin/@ARCH@/ioc', 'iocBoot/ioc/st.cmd');
|
|
$ioc->cmd; # Wait for the iocsh prompt
|
|
|
|
my @records = $ioc->dbl;
|
|
my @values = map { $ioc->dbgf($_); } @records;
|
|
|
|
$ioc->kill;
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
This module provides an object-oriented API for starting, interacting with and
|
|
stopping one or more EPICS IOCs under program control, and is generally intended
|
|
for writing test programs.
|
|
|
|
The IOC should not be configured to emit unsolicited messages on stdout as this
|
|
could interfere with the ability of the software to detect an end-of-command
|
|
from the IOC shell, which is achieved by setting the prompt to a known string
|
|
(normally C<__END__>). Unsolicited messages on stderr will not cause problems,
|
|
but can't be seen on Windows systems.
|
|
|
|
=head1 CONSTRUCTOR
|
|
|
|
=over 4
|
|
|
|
=cut
|
|
|
|
use Symbol 'gensym';
|
|
use IPC::Open3;
|
|
use IO::Select;
|
|
|
|
|
|
=item new ()
|
|
|
|
Calling C<new> creates an C<EPICS::IOC> object that can be used to start and
|
|
interact with a single IOC. After this IOC has been shut down (by calling its
|
|
C<kill> method) the C<EPICS::IOC> object may be reused for another IOC.
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
sub new {
|
|
my $proto = shift;
|
|
my $class = ref $proto || $proto;
|
|
|
|
my $self = {
|
|
pid => undef,
|
|
stdin => gensym,
|
|
stdout => gensym,
|
|
stderr => gensym,
|
|
select => IO::Select->new(),
|
|
errbuf => '',
|
|
debug => 0,
|
|
terminator => '__END__'
|
|
};
|
|
|
|
bless $self, $class;
|
|
}
|
|
|
|
=head1 METHODS
|
|
|
|
=over 4
|
|
|
|
=item debug ( [FLAG] )
|
|
|
|
Each C<EPICS::IOC> object has its own debug flag which when non-zero causes all
|
|
IOC console traffic sent or read by other methods to be printed to stdout along
|
|
with the IOC's pid and a direction indicator. The C<debug> method optionally
|
|
sets and returns the value of this flag.
|
|
|
|
The optional FLAG is treated as a true/false value. If provided this sets the
|
|
debug flag value.
|
|
|
|
The method's return value is the current (new if given) value of the flag.
|
|
|
|
=cut
|
|
|
|
sub debug {
|
|
my $self = shift;
|
|
|
|
$self->{debug} = shift if scalar @_;
|
|
return $self->{debug};
|
|
}
|
|
|
|
|
|
=item start ( EXECUTABLE [, ARGUMENTS ...] )
|
|
|
|
Launch an IOC binary given by EXECUTABLE with ARGUMENTS. The method dies if it
|
|
can't run the program as given, or if the IOC is already running.
|
|
|
|
In most cases the C<cmd> method should be called next with no command string,
|
|
which waits for the IOC's boot process to finish and the first iocsh prompt to
|
|
be displayed.
|
|
|
|
The C<start> method sets two environment variables that control how the IOC
|
|
shell behaves: C<IOCSH_HISTEDIT_DISABLE> is set to prevent it calling the GNU
|
|
Readline library, and C<IOCSH_PS1> is set to a known string which is used as a
|
|
terminator for the previous command.
|
|
|
|
=cut
|
|
|
|
sub start {
|
|
my ($self, $exe, @args) = @_;
|
|
|
|
croak("IOC already running") if $self->started;
|
|
|
|
# Turn off readline or its equivalents
|
|
local $ENV{IOCSH_HISTEDIT_DISABLE} = "TRUE";
|
|
|
|
# The iocsh prompt marks the end of the previous command
|
|
local $ENV{IOCSH_PS1} = $self->{terminator} . "\n";
|
|
|
|
# Run the IOC as a child process
|
|
$self->{pid} = open3($self->{stdin}, $self->{stdout}, $self->{stderr},
|
|
$exe, @args)
|
|
or die "can't start $exe: $!";
|
|
|
|
$self->{select}->add($self->{stderr});
|
|
|
|
printf "#%d running %s\n", $self->{pid}, $exe if $self->{debug};
|
|
}
|
|
|
|
|
|
=item pid ()
|
|
|
|
Returns the process-ID of the IOC process, or undef if the IOC process has not
|
|
yet been started.
|
|
|
|
=cut
|
|
|
|
sub pid {
|
|
my $self = shift;
|
|
|
|
return $self->{pid};
|
|
}
|
|
|
|
|
|
=item started ()
|
|
|
|
Returns a true value if the IOC has been started and not yet killed. This state
|
|
will not change if the IOC dies by itself, it indicates that the start method
|
|
has been called without the kill method.
|
|
|
|
=cut
|
|
|
|
sub started {
|
|
my $self = shift;
|
|
|
|
return defined($self->pid);
|
|
}
|
|
|
|
|
|
=item _send ( COMMAND )
|
|
|
|
The C<_send> method is a primitive for internal use that sends a COMMAND string
|
|
to the IOC shell, and prints it to stdout if the debug flag is set.
|
|
|
|
=cut
|
|
|
|
sub _send {
|
|
my ($self, $cmd) = @_;
|
|
my $stdin = $self->{stdin};
|
|
|
|
printf "#%d << %s", $self->{pid}, $cmd if $self->{debug};
|
|
|
|
local $SIG{PIPE} = sub {
|
|
printf "#%d << <PIPE>\n", $self->{pid} if $self->{debug};
|
|
};
|
|
|
|
print $stdin $cmd;
|
|
}
|
|
|
|
|
|
=item _getline ()
|
|
|
|
The C<_getline> method is also designed for internal use, it fetches a single
|
|
line output by the IOC, and prints it to stdout if the debug flag is set.
|
|
|
|
Any CR/LF is stripped from the line before returning it. If the stream gets
|
|
closed because the IOC shuts down an C<EOF> debug message may be shown and an
|
|
undef value will be returned.
|
|
|
|
=cut
|
|
|
|
sub _getline {
|
|
my $self = shift;
|
|
|
|
my $line = readline $self->{stdout};
|
|
if (defined $line) {
|
|
chomp $line;
|
|
printf "#%d >> %s\n", $self->{pid}, $line if $self->{debug};
|
|
}
|
|
elsif (eof($self->{stdout})) {
|
|
printf "#%d >> <EOF>\n", $self->{pid} if $self->{debug};
|
|
}
|
|
else {
|
|
printf "#%d Error: %s\n", $self->{pid}, $! if $self->{debug};
|
|
}
|
|
return $line;
|
|
}
|
|
|
|
|
|
=item _getlines ( [TERM] )
|
|
|
|
Another internal method C<_getlines> fetches multiple lines from the IOC. It
|
|
takes an optional TERM string or regexp parameter which is matched against each
|
|
input line in turn to determine when the IOC's output has been completed.
|
|
Termination also occurs on an EOF from the output stream.
|
|
|
|
The return value is a list of all the lines received (with the final CR/LF
|
|
stripped) including the line that matched the terminator.
|
|
|
|
=cut
|
|
|
|
sub _getlines {
|
|
my ($self, $term) = @_;
|
|
|
|
my @response = ();
|
|
|
|
while (my $line = $self->_getline) {
|
|
push @response, $line;
|
|
last if defined $term && $line =~ $term;
|
|
}
|
|
return @response;
|
|
}
|
|
|
|
|
|
=item _geterrors ( )
|
|
|
|
Returns a list of lines output by the IOC to stderr since last called. Only
|
|
complete lines are included, and trailing newlines have been removed.
|
|
|
|
NOTE: This doesn't work on Windows because it uses select which Perl doesn't
|
|
support on that OS, but it doesn't seem to cause any problems for short-lived
|
|
IOCs at least, it just never returns any text from the IOC's stderr output.
|
|
|
|
=cut
|
|
|
|
sub _geterrors {
|
|
my ($self) = @_;
|
|
my @errors;
|
|
|
|
while ($self->{select}->can_read(0.01)) {
|
|
sysread $self->{stderr}, my $errbuf, 1024;
|
|
push @errors, split m/\n/, $self->{errbuf} . $errbuf, -1;
|
|
last unless @errors;
|
|
$self->{errbuf} = pop @errors;
|
|
}
|
|
return @errors;
|
|
}
|
|
|
|
=item cmd ( [COMMAND [, ARGUMENTS ...]] )
|
|
|
|
If the C<cmd> method is given an optional COMMAND string along with any number
|
|
of ARGUMENTS it constructs a command-line, quoting each argument as necessary.
|
|
This is sent to the IOC and a line read back and discarded if it matches the
|
|
command-line.
|
|
|
|
With no COMMAND string the method starts here; it then collects lines from the
|
|
IOC until one matches the terminator. A list of all the lines received prior to
|
|
the terminator line is returned.
|
|
|
|
=cut
|
|
|
|
sub cmd {
|
|
my ($self, $cmd, @args) = @_;
|
|
|
|
my @response;
|
|
my $term = $self->{terminator};
|
|
|
|
if (defined $cmd) {
|
|
if (@args) {
|
|
# FIXME: This quoting stuff isn't quite right
|
|
my @qargs = map {
|
|
m/^ (?: -? [0-9.eE+\-]+ ) | (?: " .* " ) $/x ? $_ : "'$_'"
|
|
} @args;
|
|
$cmd .= ' ' . join(' ', @qargs);
|
|
}
|
|
$self->_send("$cmd\n");
|
|
|
|
my $echo = $self->_getline;
|
|
return @response unless defined $echo; # undef => reached EOF
|
|
if ($echo ne $cmd) {
|
|
return @response if $echo =~ $term;
|
|
push @response, $echo;
|
|
}
|
|
}
|
|
|
|
push @response, $self->_getlines($term);
|
|
pop @response if @response and $response[-1] =~ $term;
|
|
|
|
my @errors = $self->_geterrors;
|
|
if (scalar @errors && $self->{debug}) {
|
|
my $indent = sprintf "#%d e>", $self->{pid};
|
|
print map {"$indent $_\n"} @errors;
|
|
}
|
|
|
|
return @response;
|
|
}
|
|
|
|
=item kill ()
|
|
|
|
The C<kill> method attempts to stop an IOC that is still running in several
|
|
ways. First it sends an C<exit> command to the IOC shell. Next it closes the
|
|
IOC's stdin stream which will trigger an end-of-file on that stream, and it
|
|
fetches any remaining lines from the IOC's stdout stream before closing both
|
|
that and the stderr stream. Finally (unless running on MS-Windows) it sends a
|
|
SIGTERM signal to the child process and waits for it to clean up.
|
|
|
|
=cut
|
|
|
|
sub kill {
|
|
my $self = shift;
|
|
|
|
return ()
|
|
unless $self->started;
|
|
|
|
$self->_send("exit\n"); # Don't wait
|
|
|
|
close $self->{stdin};
|
|
$self->{stdin} = gensym;
|
|
|
|
my @response = $self->_getlines; # No terminator
|
|
close $self->{stdout};
|
|
$self->{stdout} = gensym;
|
|
|
|
$self->{select}->remove($self->{stderr});
|
|
close $self->{stderr};
|
|
$self->{stderr} = gensym;
|
|
|
|
if ($^O ne "MSWin32") {
|
|
kill 'TERM', $self->{pid};
|
|
waitpid $self->{pid}, 0;
|
|
}
|
|
$self->{pid} = undef;
|
|
|
|
return @response;
|
|
}
|
|
|
|
=item DESTROY ()
|
|
|
|
C<EPICS::IOC> objects have a destructor which calls the C<kill> method, but it
|
|
is not recommended that this be relied on to terminate an IOC process. Better to
|
|
use an C<END {}> block and/or trap the necessary signals to explicitly kill the
|
|
IOC.
|
|
|
|
=cut
|
|
|
|
sub DESTROY {
|
|
shift->kill;
|
|
}
|
|
|
|
|
|
=back
|
|
|
|
=head1 CONVENIENCE METHODS
|
|
|
|
The following methods provide an easy way to perform various common IOC
|
|
operations.
|
|
|
|
=over 4
|
|
|
|
=item dbLoadRecords ( FILE [, MACROS] )
|
|
|
|
Instructs the IOC to load a database (.db) from FILE. If provided, the MACROS
|
|
parameter is a single string containing one or more comma-separated assignment
|
|
statements like C<a=1> for macros that are used in the database file.
|
|
|
|
This method can also be used to load a database definition (.dbd) file.
|
|
|
|
=cut
|
|
|
|
sub dbLoadRecords {
|
|
my ($self, $file, $macros) = @_;
|
|
|
|
$macros = '' unless defined $macros;
|
|
$self->cmd('dbLoadRecords', $file, $macros);
|
|
}
|
|
|
|
=item iocInit ()
|
|
|
|
Start the IOC executing.
|
|
|
|
=cut
|
|
|
|
sub iocInit {
|
|
shift->cmd('iocInit');
|
|
}
|
|
|
|
=item dbl ( [RECORDTYPE])
|
|
|
|
This method uses the C<dbl> command to fetch a list of all of the record names
|
|
the IOC has loaded. If a RECORDTYPE name is given, the list will only comprise
|
|
records of that type.
|
|
|
|
=cut
|
|
|
|
sub dbl {
|
|
my ($self, $rtyp) = @_;
|
|
|
|
return $self->cmd('dbl', $rtyp)
|
|
}
|
|
|
|
=item dbgf ( PV )
|
|
|
|
The C<dbgf> method returns the value of the process variable PV, or C<undef> if
|
|
the PV doesn't exist. This only works when the PV holds a scalar or an array
|
|
with one element.
|
|
|
|
=cut
|
|
|
|
# Regexps for the output from dbgf, currently supporting scalars only
|
|
my $RXdbfstr = qr/ DB[FR]_(STRING) : \s* " ( (?> \\. | [^"\\] )* ) " /x;
|
|
my $RXdbfint = qr/ DB[FR]_(U?(?:CHAR|SHORT|LONG|INT64)) : \s* ( -? [0-9]+ ) /x;
|
|
my $RXdbfflt = qr/ DB[FR]_(FLOAT|DOUBLE) : \s* ( [0-9.eE+\-]+ ) /x;
|
|
my $RXdbf = qr/ (?| $RXdbfstr | $RXdbfint | $RXdbfflt ) /x;
|
|
|
|
sub dbgf {
|
|
my ($self, $pv) = @_;
|
|
|
|
my @res = $self->cmd('dbgf', $pv);
|
|
return undef unless scalar @res;
|
|
|
|
my ($type, $result) = ($res[0] =~ m/^ $RXdbf /x);
|
|
$result =~ s/\\([\\"'])/$1/gx
|
|
if $type eq 'STRING';
|
|
return $result;
|
|
}
|
|
|
|
=item dbpf ( PV, VALUE )
|
|
|
|
This method sets PV to VALUE, and returns the new value, or C<undef> if the PV
|
|
doesn't exist. If the put fails the return value is the previous value of the
|
|
PV. As with the C<dbgf> method this only works for scalar or single-element
|
|
arrays, but PV may be an array field which will be set to one element.
|
|
|
|
=cut
|
|
|
|
sub dbpf {
|
|
my ($self, $pv, $val) = @_;
|
|
|
|
my @res = $self->cmd('dbpf', $pv, $val);
|
|
return undef unless scalar @res;
|
|
|
|
my ($type, $result) = ($res[0] =~ m/^ $RXdbf /x);
|
|
$result =~ s/\\([\\"'])/$1/gx
|
|
if $type eq 'STRING';
|
|
return $result;
|
|
}
|
|
|
|
=back
|
|
|
|
=head1 COPYRIGHT AND LICENSE
|
|
|
|
Portions Copyright (C) 2011 UChicago Argonne LLC, as Operator of Argonne
|
|
National Laboratory.
|
|
|
|
This software is distributed under the terms of the EPICS Open License.
|
|
|
|
=cut
|
|
|
|
1;
|
|
|
|
__END__
|