File Coverage

blib/lib/IPC/PerlSSH/Base.pm

Criterion	Covered	Total	%
statement	65	80	81.2
branch	21	32	65.6
condition	2	7	28.5
subroutine	9	12	75.0
pod	0	8	0.0
total	97	139	69.7

#  You may distribute under the terms of either the GNU General Public License
#  or the Artistic License (the same terms as Perl itself)
#
#  (C) Paul Evans, 2006-2012 -- [e-mail]

package IPC::PerlSSH::Base;

use strict;
use warnings;

use Carp;

our $VERSION = '0.17';

=head1 NAME

C - base functionallity behind L

=head1 DESCRIPTION

This module provides the low-level message formatting and parsing code used by
C, and the perl code to be executed on the remote server once a
connection is established.

This split exists, in order to make it easier to write other modules that use
the same behaviour. For example, an asynchronous version could be written
using this as a base class.

=cut

# Some functions we'll share with the remote
my $SHARE_PERL = <<'EOP';
sub pack_message
{
   my ( $message, @args ) = @_;

   my $buffer = "$message\n";
   $buffer .= scalar( @args ) . "\n";

   foreach my $arg ( @args ) {
      if( !defined $arg ) {
         $buffer .= "U\n";
      }
      else {
         $buffer .= length( $arg ) . "\n" . "$arg";
      }
   }

   return $buffer;
}

EOP

eval "$SHARE_PERL; 1" or die $@;

# And now for the main loop of the remote firmware
my $REMOTE_PERL = <<'EOP';
sub send_message
{
   my ( $message, @args ) = @_;
   print STDOUT pack_message( $message, @args );
}

sub read_message
{
   local $/ = "\n";

   my $message = ;
   defined $message or return "QUIT";
   chomp $message;

   my $numargs = ;
   defined $numargs or die "Expected number of arguments\n";
   chomp $numargs;

   my @args;
   while( $numargs ) {
      my $arglen = ;
      defined $arglen or die "Expected length of argument\n";
      chomp $arglen;

      if( $arglen eq "U" ) {
         push @args, undef;
      }
      else {
         my $arg = "";
         while( $arglen ) {
            my $n = read( STDIN, $arg, $arglen, length $arg );
            die "read() returned $!\n" unless( defined $n );
            $arglen -= $n;
         }

         push @args, $arg;
      }
      $numargs--;
   }

   return ( $message, @args );
}

my %compilers;
my %stored_procedures;

sub store
{
   my ( $package, %subs ) = @_;

   my $compiler;
   unless( $compiler = $compilers{$package} ) {
      my $preamble = delete $subs{_init} || "";
      $compiler = eval "package $package; $preamble; sub { eval \$_[0] }";
      if( $@ ) {
         send_message( "DIED", "While compiling initialisation code: $@" );
         return;
      }
      $compilers{$package} = $compiler;
   }

   foreach my $name ( keys %subs ) {
      $stored_procedures{$name} = $compiler->( "sub { $subs{$name} }" ) and next;
      send_message( "DIED", "While compiling code for $name: $@" );
      return;
   }

   send_message( "OK" );
   return;
}

while( 1 ) {
   my ( $message, @args ) = read_message;

   if( $message eq "QUIT" ) {
      # Immediate controlled shutdown
      exit( 0 );
   }

   if( $message eq "EVAL" ) {
      my $code = shift @args;

      my $subref = eval "sub { $code }";
      if( $@ ) {
         send_message( "DIED", "While compiling code: $@" );
         next;
      }

      my @results = eval { $subref->( @args ) };
      if( $@ ) {
         send_message( "DIED", "While running code: $@" );
         next;
      }

      send_message( "RETURNED", @results );
      next;
   }

   if( $message eq "STORE" ) {
      store( "main", @args );
      next;
   }

   if( $message eq "STOREPKG" ) {
      store( @args );
      next;
   }

   if( $message eq "CALL" ) {
      my $name = shift @args;

      my $subref = $stored_procedures{$name};
      if( !defined $subref ) {
         send_message( "DIED", "No such stored procedure '$name'" );
         next;
      }

      my @results = eval { $subref->( @args ) };
      if( $@ ) {
         send_message( "DIED", "While running code: $@" );
         next;
      }

      send_message( "RETURNED", @results );
      next;
   }

   send_message( "DIED", "Unknown message $message" );
}
EOP

sub build_command
{
   my $self = shift;
   my %opts = @_;
   return $self->build_command_from( \%opts );
}

sub build_command_from
{
   my $self = shift;
   my ( $opts ) = @_;

   my @command;
   if( exists $opts->{Command} ) {
      my $c = delete $opts->{Command};
      @command = ref($c) && UNIVERSAL::isa( $c, "ARRAY" ) ? @$c : ( "$c" );
   }
   else {
      my $host = delete $opts->{Host} or
         croak ref($self)." requires a Host, a Command or a Readfunc/Writefunc pair";

      defined $opts->{User} and $host = "$opts->{User}\@$host";
      delete $opts->{User};

      my @options;

      push @options, "-p", delete $opts->{Port} if defined $opts->{Port};

      push @options, @{ delete $opts->{SshOptions} } if defined $opts->{SshOptions};

      @command = ( delete $opts->{SshPath} || "ssh", @options, $host, delete $opts->{Perl} || "perl" );
   }

   return @command;
}

sub send_firmware
{
   my $self = shift;

   $self->write( <
use strict;
\$| = 1;
$SHARE_PERL

$REMOTE_PERL
__END__