view release on metacpan or  search on metacpan

lib/Pick/TCL.pm  view on Meta::CPAN

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>, C<SSHPASS> and/or C<TIMEOUT> 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:

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), new() will establish
a L<Net::OpenSSH> link to C<HOST> or 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 constructor options must be a balanced hash"
        unless scalar(@_) % 2 == 0;
    my %options = @_;
    $options{'VM'} = 'pick0' unless defined($options{'VM'});
    unless (defined($options{'USER'}))
    {
        # Default Pick username to remote Unix username if set
        my $u = $options{'SSHUSER'};
        # Otherwise local username
        $u = eval { getpwuid($<); } unless defined($u);
        # Handle platforms without a working getpwuid()
        $u = getlogin() unless defined($u);
    }
    $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 (defined($options{'TIMEOUT'}))
    {
      $options{'TIMEOUT'} = 0 + $options{'TIMEOUT'};
    } else {
      $options{'TIMEOUT'} = 15;
    }
    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> synchronously 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)>).

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

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