Added Perl EPICS::IOC module and netget test program
This commit is contained in:
Andrew Johnson
488
modules/database/src/tools/EPICS/IOC.pm
Normal file
488
modules/database/src/tools/EPICS/IOC.pm
Normal file
@@ -0,0 +1,488 @@
|
||||
######################################################################
|
||||
# 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;
|
||||
$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[-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__
|
||||
@@ -1,5 +1,5 @@
|
||||
#*************************************************************************
|
||||
# Copyright (c) 2012 UChicago Argonne LLC, as Operator of Argonne
|
||||
# Copyright (c) 2018 UChicago Argonne LLC, as Operator of Argonne
|
||||
# National Laboratory.
|
||||
# EPICS BASE is distributed subject to a Software License Agreement found
|
||||
# in file LICENSE that is included with this distribution.
|
||||
@@ -24,6 +24,9 @@ PERL_MODULES += DBD/Record.pm
|
||||
PERL_MODULES += DBD/Registrar.pm
|
||||
PERL_MODULES += DBD/Variable.pm
|
||||
|
||||
PERL_MODULES += EPICS/IOC.pm
|
||||
HTMLS += EPICS/IOC.html
|
||||
|
||||
PERL_SCRIPTS += databaseModuleDirs.pm
|
||||
|
||||
PERL_SCRIPTS += makeIncludeDbd.pl
|
||||
|
||||
@@ -145,6 +145,9 @@ asyncproctest_SRCS += asyncproctest_registerRecordDeviceDriver.cpp
|
||||
TESTFILES += $(COMMON_DIR)/asyncproctest.dbd ../asyncproctest.db
|
||||
TESTS += asyncproctest
|
||||
|
||||
# Host-only tests of softIoc/softIocPVA, caget and pvget (if present)
|
||||
TESTS += netget
|
||||
|
||||
# epicsRunRecordTests runs all the test programs in a known working order.
|
||||
testHarness_SRCS += epicsRunRecordTests.c
|
||||
|
||||
|
||||
62
modules/database/test/std/rec/netget.plt
Normal file
62
modules/database/test/std/rec/netget.plt
Normal file
@@ -0,0 +1,62 @@
|
||||
#!/usr/bin/env perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use lib '@TOP@/lib/perl';
|
||||
|
||||
use Test::More tests => 3;
|
||||
use EPICS::IOC;
|
||||
|
||||
$ENV{HARNESS_ACTIVE} = 1 if scalar @ARGV && shift eq '-tap';
|
||||
|
||||
my $bin = "@TOP@/bin/@ARCH@";
|
||||
my $exe = ($^O =~ m/^(MSWin32|cygwin)$/x) ? '.exe' : '';
|
||||
my $prefix = "test-$$";
|
||||
|
||||
my $ioc = EPICS::IOC->new();
|
||||
#$ioc->debug(1);
|
||||
|
||||
$SIG{__DIE__} = $SIG{'INT'} = $SIG{'QUIT'} = sub {
|
||||
$ioc->kill
|
||||
if ref($ioc) eq 'EPICS::IOC' && $ioc->started;
|
||||
BAIL_OUT('Caught signal');
|
||||
};
|
||||
|
||||
my $softIoc = "$bin/softIocPVA$exe";
|
||||
$softIoc = "$bin/softIoc$exe"
|
||||
unless -x $softIoc;
|
||||
BAIL_OUT("Can't find a softIoc executable")
|
||||
unless -x $softIoc;
|
||||
|
||||
$ioc->start($softIoc, '-x', $prefix);
|
||||
$ioc->cmd; # Wait for command prompt
|
||||
|
||||
my $pv = "$prefix:BaseVersion";
|
||||
|
||||
my @pvs = $ioc->dbl('stringin');
|
||||
grep(m/$pv/, @pvs)
|
||||
or BAIL_OUT('No BaseVersion record found');
|
||||
|
||||
my $version = $ioc->dbgf("$pv");
|
||||
like($version, qr/^ \d+ \. \d+ \. \d+ /x,
|
||||
"Got BaseVersion '$version' from iocsh");
|
||||
|
||||
my $caget = "$bin/caget$exe";
|
||||
SKIP: {
|
||||
skip "caget not available", 1 unless -x $caget;
|
||||
like(`$caget $pv`, qr/$pv \s+ \Q$version\E/x,
|
||||
'Got same BaseVersion from caget');
|
||||
}
|
||||
|
||||
my $pvget = "$bin/pvget$exe";
|
||||
SKIP: {
|
||||
skip "softIocPVA not available", 1
|
||||
if $softIoc eq "$bin/softIoc$exe";
|
||||
skip "pvget not available", 1
|
||||
unless -x $pvget;
|
||||
like(`$pvget $pv`, qr/$pv \s+ \Q$version\E/x,
|
||||
'Got same BaseVersion from pvget');
|
||||
}
|
||||
|
||||
$ioc->kill;
|
||||
Reference in New Issue
Block a user