######################################################################
# 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) {
        $line =~ s/[\r\n]+ $//x;    # chomp broken on Windows?
        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__