package Pick::TCL;

use 5.006;
use strict;
use warnings;
use Carp;
use Errno;

=head1 NAME

Pick::TCL - class to run commands in a Pick TCL shell

=head1 VERSION

Version 0.02

=cut

###################
# PACKAGE GLOBALS #
###################

our $VERSION = '0.02';
our %_mods;

#########################
# OPTIONAL DEPENDENCIES #
#########################

BEGIN
{
    %_mods = ();
    if (eval { require IPC::Run; })
    {
        $_mods{'local'} = 'IPC::Run';
    }
    if (eval { require Net::OpenSSH; })
    {
        $_mods{'remote'} = 'Net::OpenSSH';
    }
}

if (scalar(keys %_mods) == 0)
{
    croak "Pick::TCL requires either IPC::Run or Net::OpenSSH";
}

=head1 SYNOPSIS

    use Pick::TCL;

    # Establish connection
    my $ap = Pick::TCL->new(%options);
    
    # Execute commands
    my $output = $ap->exec('TCL.COMMAND PARAMS (OPTIONS)');
    my $unsanitised = $ap->execraw('TCL.COMMAND PARAMS (OPTIONS)');

    # Clean up
    $ap->logout();

=head1 DESCRIPTION

C<Pick::TCL> provides a class to run arbitrary B<TCL> (that's
I<Terminal Control Language>, not the "other" TCL) commands in a
local or remote Pick or Pick-like environment,

=over 4

=item Local connections

require either L<IPC::Run> or L<Net::OpenSSH> to be installed and usable.

=item Remote connections

require L<Net::OpenSSH> to be installed and usable.

=back

Note that C<Pick::TCL> will croak if used when neither L<IPC::Run>
nor L<Net::OpenSSH> are usable.

=cut

###################
# Private methods #
###################

# Get an ssh link. Returns 1 on success. On failure returns undef
# and sets $!
sub _bring_up_ssh
{
    my $self = shift;

    # Build connection string
    my %options = %{$$self{'_OPTIONS'}};
    my $cs = defined($options{'SSHUSER'}) ? $options{'SSHUSER'} : "";
    $cs .= ':'.$options{'SSHPASS'} if defined($options{'SSHPASS'});
    $cs .= '@' unless $cs eq '';
    $cs .= $options{'HOST'};
    $cs .= ':'.$options{'PORT'} if defined($options{'PORT'});

    # Survive in Taint mode
    local %ENV;
    $ENV{'PATH'} = "";
    
    # Find ssh binary
    unless (defined($options{'SSHCMD'}))
    {
        my $cmd = '';
        foreach my $c (qw[/usr/local/bin/ssh /usr/bin/ssh /bin/ssh])
        {
          next unless -x $c;
          $cmd = $c;
          last;
        }
        croak "Pick::TCL: can't find ssh" unless $cmd;
        $$self{'_OPTIONS'}->{'SSHCMD'} = $cmd;
    }

    # Bring up link
    croak "Pick::TCL: No usable module found for remote connections"
        unless $_mods{'remote'};
    my $ssh = undef;
    $ssh = Net::OpenSSH->new($cs, ssh_cmd => $$self{'_OPTIONS'}->{'SSHCMD'},
        master_stderr_discard => 1, timeout => 15, kill_ssh_on_timeout => 1,
        default_ssh_opts => [ '-oConnectionAttempts=0' ] );
    my $e = $ssh->error;
    if ($e)
    {
        carp "Pick::TCL: Failed to bring up ssh link: $e";
        $! = &Errno::ETIMEDOUT;
        return undef;
    }
    $$self{'_SSH'} = \$ssh;
    return 1;
}

# Tear down & re-establish an ssh link
sub _reconnect_ssh
{
    my $self = shift;
    if (ref($$self{'_SSH'}))
    {
        ${$$self{'_SSH'}}->DESTROY;
    }
    delete($$self{'_SSH'});
    return $self->_bring_up_ssh();
}

=head1 CLASS METHODS

=head2 new(%options)

Returns a new C<Pick::TCL> object on success (or C<undef>
on failure). C<%options> is optional and if present may contain
any combination of the following keys:

=over 4

=item HOST

The hostname of the Pick host. If specified, all calls to Pick
will be made via a L<Net::OpenSSH> link to the host of the
supplied name; if not specified, Pick is presumed to be running
on the local host and L<Net::OpenSSH> is not used
(unless L<IPC::Run> is missing and C<HOST> is not specified, in
which case C<HOST> will be set implicitly to C<localhost>).

=item PORT

Only valid if C<HOST> is also set. Specifies the TCP port on
which to connect to B<sshd>(8) on C<HOST>. Defaults to 22.

=item SSHUSER

Only valid if C<HOST> is also given. Specifies the Unix username
to supply to the remote B<sshd>(8) on C<HOST>. Defaults to the
current local username.

=item SSHPASS

Only valid if C<HOST> is also given. Specifies that password
authentication should be used, with the given Unix password.
If C<HOST> is given but C<SSHPASS> is not, public key
authentication is used instead of password authentication.

=item SSHCMD

Only valid if C<HOST> is also given. Specifies the full path
to the B<ssh>(1) binary (in case L<Net::OpenSSH> cannot find
it). If not specified, only F</usr/local/bin/ssh>,
F</usr/bin/ssh> and F</bin/ssh> (in that order) are tried.

=item VM

The name of the Pick virtual machine to which to connect.
Defaults to C<pick0>.

=item USER

The user name with which to log on to C<VM>. Defaults
to the value of C<SSHUSER> (or to the current Unix username
if C<HOST> is not given).

=item PASS

The password with which to log on to C<VM>, if required.

=item MD

The Pick I<master dictionary> to log onto, if required.

=item MDPASS

Only valid if C<MD> is also given. The password for C<MD>,
if required.

=item PICKBIN

The full path to the Pick binary on C<HOST>. Defaults
to F</usr/bin/ap>.

=item OPTVM

The switch to pass to C<PICKBIN> indicating that the
next parameter is a VM / config-file name. Defaults to
C<-n>.

=item OPTSILENT

The switch to pass to C<PICKBIN> in order to suppress
logon and logoff messages. Defaults to C<-s>.

=item OPTDATA

The switch to pass to C<PICKBIN> indicating that the
next parameter contains "stacked" data for input to
the Pick session. Defaults to C<-d>.

=back

All keys are optional, with the caveats that if C<PORT>,
C<SSHUSER> and/or C<SSHPASS> are specified, for those options
to take effect C<HOST> must also be specified; and likewise
C<MDPASS> has no effect without C<MD>.

=head3 Note:

C<new()> does not actually try to log on to C<VM> -- where
Pick is local, the C<%options> are merely stored in the
C<Pick::TCL> object for later use; on the other hand if
C<HOST> is set (i.e. Pick is remote), C<new()> will establish
a L<Net::OpenSSH> link to C<HOST> or C<croak()> trying.

=cut

sub new
{
    my $class = shift;
    if (ref($class))
    {
        # Reset existing login
        $class->logout();
        $class = ref($class);
    }
    my $self = {};

    # Check/set options
    croak "Pick::TCL consructor options must be a balanced hash"
        unless scalar(@_) % 2 == 0;
    my %options = @_;
    $options{'VM'} = 'pick0' unless defined($options{'VM'});
    unless (defined($options{'USER'}))
    {
        $options{'USER'} =
            defined($options{'SSHUSER'}) ? $options{'SSHUSER'} : getpwuid($<);
    }
    $options{'PICKBIN'} = '/usr/bin/ap' unless defined($options{'PICKBIN'});
    $options{'OPTDATA'} = '-d' unless defined($options{'OPTDATA'});
    $options{'OPTSILENT'} = '-s' unless defined($options{'OPTSILENT'});
    $options{'OPTVM'} = '-n' unless defined($options{'OPTVM'});
    if ((not defined($options{'HOST'})) && (not defined($_mods{'local'})))
    {
        # For a local VM, if we're missing IPC::Run, just ssh to the
        # loopback interface instead
        $options{'HOST'} = 'localhost';
    }
    $$self{'_OPTIONS'} = \%options;
    bless $self, $class;

    # Check ssh host reachable
    if ($options{'HOST'})
    {
        return undef unless $self->_bring_up_ssh();
    }

    return $self;
}

=head1 INSTANCE METHODS

=head2 $ap->exec($tclcmd, @input)

Executes the Pick B<TCL> command C<$tclcmd> on the Pick VM associated
with the C<Pick::TCL> object C<$ap> and returns the output.

In order to cope with the wide variety of terminal settings found on
different Pick systems in the wild (or in some cases, even on different
ports of the same VM, allocated dynamically...), line endings in the
returned output are sanitised: any sequence of one or more control
characters (other than tabs) is treated as a single line ending. As a
consequence, any consecutive line endings are collapsed.

In list context, returns a list of output lines; in scalar context,
returns all output lines joined with line feeds.

The second parameter, C<@input>, is optional. If specified, its
elements, joined with carriage returns, are supplied as input to
the B<TCL> session.

On caller or Pick error (including if Pick or ssh emit anything
on C<stderr>), returns false, sets C<$!> and emits a suitable
message. Likewise on B<ssh> error, except that exit codes 11 and 255
are ignored, in order to support ancient versions of L<sshd(8)>).

C<croak()>s if the call to a local VM fails outright.

=head2 $ap->execraw($tclcmd, @input)

Does the same thing as the C<exec()> method but without any
output sanitisation.

This is useful when dealing with binary output, or when consecutive
line breaks in output are significant. However, in those circumstances
the caller will need to know in advance the pertinent terminal settings
of the port to which it is connecting on the target Pick system and do
its own filtering of extraneous nulls, form feeds, etc. to suit.

=cut

sub execraw
{
    my $self = shift;
    my $func = 'Pick::TCL::execraw()';
    croak "$func is not a class method" unless ref($self);
    if (scalar(@_) == 0)
    {
        carp "$func: cowardly refusing to execute a null TCL command";
        $! = &Errno::ENOMSG;
        return undef;
    }
    my $tclcmd = shift;
    my $input = undef;
    $input = join "\r", @_ if scalar(@_) > 0;

    # User logon sequence
    my $logon = "";
    foreach my $k (qw/USER PASS MD MDPASS/)
    {
        $logon .= $$self{'_OPTIONS'}->{$k} . "\n"
            if defined($$self{'_OPTIONS'}->{$k});
    }

    # Build Pick command
    my @args = ( $$self{'_OPTIONS'}->{'PICKBIN'},
        $$self{'_OPTIONS'}->{'OPTVM'}, $$self{'_OPTIONS'}->{'VM'},
        $$self{'_OPTIONS'}->{'OPTSILENT'}, $$self{'_OPTIONS'}->{'OPTDATA'},
        $logon . $tclcmd . "\r" );
    my ($result, $err) = ("", "");
    $ENV{'PATH'} = "";

    # Run command
    if (defined($$self{'_SSH'}))
    {
        # Remote VM
        unless ($self->_reconnect_ssh())
        {
            carp "$func: $!";
            return undef;
        }
        my $ssh = $$self{'_SSH'};
        ($result, $err) = $$ssh->capture2({stdin_data => $input}, @args);
        my $serr = $$ssh->error();
        if (($serr) && ($serr ne 'child exited with code 11')
            && ($serr ne 'child exited with code 255'))
        {
            carp "$func: fatal error: $serr detail ($! $?): $err";
            carp "$func: stdout was $result";
            $! = &Errno::EBADFD;
            return undef;
        }
    } else {
        # Local VM
        IPC::Run::run([ \@args, \$input, \$result, \$err ])
            or croak "Broken pipe to Pick: $!";
        if ($err)
        {
            carp "$func: $err";
            $! = &Errno::EBADFD;
            return undef;
        }
    }
    return $result;
}


sub exec
{
    my $self = shift;
    my $func = 'Pick::TCL::exec()';
    croak "$func is not a class method" unless ref($self);
    if (scalar(@_) == 0)
    {
        carp "$func: cowardly refusing to execute a null TCL command";
        $! = &Errno::ENOMSG;
        return wantarray ? () : undef;
    }

    # Get response & sanitise
    my $raw = $self->execraw(@_) or return wantarray ? () : undef;
    my @lines = split /[^\x09\x20-\x7e]+/m, $raw;
    return wantarray ? @lines : join "\n", @lines;
}

=head2 $ap->logout()

Destroys the connection. Not required to be called explicitly before
exit; does nothing when Pick is local.

=cut

sub logout
{
    my $self = shift;
    croak "Pick::TCL::logout() is not a class method" unless ref($self);
    if (ref($$self{'_SSH'}))
    {
        my $ssh = $$self{'_SSH'};
        $$ssh->DESTROY();
        delete $$self{'_SSH'};
    }
}

=head1 CAVEATS

=head2 Escaping metacharacters

The commands sent to C<exec()> and C<execraw()> are always interpreted by
the Pick B<TCL> interpreter -- so be sure to escape anything that needs
escaping in B<TCL> before feeding it to C<exec()> or C<execraw()> (no
different from running native).

If C<HOST> is set, there's also the remote login shell to consider.
C<Pick::TCL> uses L<Net::OpenSSH> (which does auto-escaping of most
metacharacters) for the remote link, so this should not cause problems
either, so long as the remote user's login shell is set to the Bourne
shell, or at least something that's sufficiently compatible with it.

Note especially that when C<HOST> is set, parentheses around options
to B<TCL> commands must be balanced (even though the Pick B<TCL>
interpreter does not normally require that), as unbalanced parentheses
will likely confuse the remote shell.

=head2 Pick flavours

C<Pick::TCL> has only been tested with D3/Linux as the target Pick
platform (setting C<PICKBIN> to F</usr/bin/d3>). It should also work
unmodified with targets running D3/AIX, D3/SCO or legacy Advanced
Pick systems (on any host OS on which an sshd can be found or built).

No attempt has been made thus far to cater specifically to other /
licensee / "Pick-like" target platforms, although the configurability
provided through C<%OPTIONS> may be sufficient to work with some.

=head1 AUTHOR

Jack Burton, C<< <jack@saosce.com.au> >>

=head1 BUGS

Please report any bugs or feature requests
to C<bug-pick-tcl at rt.cpan.org>, or through the web interface
at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Pick-TCL>.
I will be notified, and then you'll automatically be notified of
progress on your bug as I make changes.

=head1 ACKNOWLEDGEMENTS

Thanks to Jemalong Wool who provided funding for initial development.

=head1 LICENSE AND COPYRIGHT

Copyright 2013 Jack Burton.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.

=cut

1; # End of Pick::TCL
