File Coverage

blib/lib/IPC/PerlSSH/Base.pm
Criterion Covered Total %
statement 65 80 81.2
branch 22 32 68.7
condition 2 7 28.5
subroutine 9 12 75.0
pod 0 8 0.0
total 98 139 70.5


line stmt bran cond sub pod time code
1             # You may distribute under the terms of either the GNU General Public License
2             # or the Artistic License (the same terms as Perl itself)
3             #
4             # (C) Paul Evans, 2006-2012 -- leonerd@leonerd.org.uk
5              
6             package IPC::PerlSSH::Base;
7              
8 12     12   920 use strict;
  12         23  
  12         381  
9 12     12   81 use warnings;
  12         21  
  12         338  
10              
11 12     12   68 use Carp;
  12         22  
  12         13684  
12              
13             our $VERSION = '0.16';
14              
15             =head1 NAME
16              
17             C - base functionallity behind L
18              
19             =head1 DESCRIPTION
20              
21             This module provides the low-level message formatting and parsing code used by
22             C, and the perl code to be executed on the remote server once a
23             connection is established.
24              
25             This split exists, in order to make it easier to write other modules that use
26             the same behaviour. For example, an asynchronous version could be written
27             using this as a base class.
28              
29             =cut
30              
31             # Some functions we'll share with the remote
32             my $SHARE_PERL = <<'EOP';
33             sub pack_message
34             {
35             my ( $message, @args ) = @_;
36              
37             my $buffer = "$message\n";
38             $buffer .= scalar( @args ) . "\n";
39              
40             foreach my $arg ( @args ) {
41             if( !defined $arg ) {
42             $buffer .= "U\n";
43             }
44             else {
45             $buffer .= length( $arg ) . "\n" . "$arg";
46             }
47             }
48              
49             return $buffer;
50             }
51              
52             EOP
53              
54 77 100   77 0 1459 eval "$SHARE_PERL; 1" or die $@;
  77         193  
  77         271  
  77         197  
  9349         14902  
  1         3  
  9348         22231  
  77         1103  
55              
56             # And now for the main loop of the remote firmware
57             my $REMOTE_PERL = <<'EOP';
58             sub send_message
59             {
60             my ( $message, @args ) = @_;
61             print STDOUT pack_message( $message, @args );
62             }
63              
64             sub read_message
65             {
66             local $/ = "\n";
67              
68             my $message = ;
69             defined $message or return "QUIT";
70             chomp $message;
71              
72             my $numargs = ;
73             defined $numargs or die "Expected number of arguments\n";
74             chomp $numargs;
75              
76             my @args;
77             while( $numargs ) {
78             my $arglen = ;
79             defined $arglen or die "Expected length of argument\n";
80             chomp $arglen;
81              
82             if( $arglen eq "U" ) {
83             push @args, undef;
84             }
85             else {
86             my $arg = "";
87             while( $arglen ) {
88             my $n = read( STDIN, $arg, $arglen, length $arg );
89             die "read() returned $!\n" unless( defined $n );
90             $arglen -= $n;
91             }
92              
93             push @args, $arg;
94             }
95             $numargs--;
96             }
97              
98             return ( $message, @args );
99             }
100              
101             my %compilers;
102             my %stored_procedures;
103              
104             sub store
105             {
106             my ( $package, %subs ) = @_;
107              
108             my $compiler;
109             unless( $compiler = $compilers{$package} ) {
110             my $preamble = delete $subs{_init} || "";
111             $compiler = eval "package $package; $preamble; sub { eval \$_[0] }";
112             if( $@ ) {
113             send_message( "DIED", "While compiling initialisation code: $@" );
114             return;
115             }
116             $compilers{$package} = $compiler;
117             }
118              
119             foreach my $name ( keys %subs ) {
120             $stored_procedures{$name} = $compiler->( "sub { $subs{$name} }" ) and next;
121             send_message( "DIED", "While compiling code for $name: $@" );
122             return;
123             }
124              
125             send_message( "OK" );
126             return;
127             }
128              
129             while( 1 ) {
130             my ( $message, @args ) = read_message;
131              
132             if( $message eq "QUIT" ) {
133             # Immediate controlled shutdown
134             exit( 0 );
135             }
136              
137             if( $message eq "EVAL" ) {
138             my $code = shift @args;
139              
140             my $subref = eval "sub { $code }";
141             if( $@ ) {
142             send_message( "DIED", "While compiling code: $@" );
143             next;
144             }
145              
146             my @results = eval { $subref->( @args ) };
147             if( $@ ) {
148             send_message( "DIED", "While running code: $@" );
149             next;
150             }
151              
152             send_message( "RETURNED", @results );
153             next;
154             }
155            
156             if( $message eq "STORE" ) {
157             store( "main", @args );
158             next;
159             }
160              
161             if( $message eq "STOREPKG" ) {
162             store( @args );
163             next;
164             }
165              
166             if( $message eq "CALL" ) {
167             my $name = shift @args;
168              
169             my $subref = $stored_procedures{$name};
170             if( !defined $subref ) {
171             send_message( "DIED", "No such stored procedure '$name'" );
172             next;
173             }
174              
175             my @results = eval { $subref->( @args ) };
176             if( $@ ) {
177             send_message( "DIED", "While running code: $@" );
178             next;
179             }
180              
181             send_message( "RETURNED", @results );
182             next;
183             }
184              
185             send_message( "DIED", "Unknown message $message" );
186             }
187             EOP
188              
189             sub build_command
190             {
191 0     0 0 0 my $self = shift;
192 0         0 my %opts = @_;
193 0         0 return $self->build_command_from( \%opts );
194             }
195              
196             sub build_command_from
197             {
198 10     10 0 23 my $self = shift;
199 10         21 my ( $opts ) = @_;
200              
201 10         19 my @command;
202 10 50       49 if( exists $opts->{Command} ) {
203 10         32 my $c = delete $opts->{Command};
204 10 100 66     112 @command = ref($c) && UNIVERSAL::isa( $c, "ARRAY" ) ? @$c : ( "$c" );
205             }
206             else {
207 0 0       0 my $host = delete $opts->{Host} or
208             croak ref($self)." requires a Host, a Command or a Readfunc/Writefunc pair";
209              
210 0 0       0 defined $opts->{User} and $host = "$opts->{User}\@$host";
211 0         0 delete $opts->{User};
212              
213 0         0 my @options;
214              
215 0 0       0 push @options, "-p", delete $opts->{Port} if defined $opts->{Port};
216              
217 0 0       0 push @options, @{ delete $opts->{SshOptions} } if defined $opts->{SshOptions};
  0         0  
218              
219 0   0     0 @command = ( delete $opts->{SshPath} || "ssh", @options, $host, delete $opts->{Perl} || "perl" );
      0        
220             }
221              
222 10         48 return @command;
223             }
224              
225             sub send_firmware
226             {
227 12     12 0 41 my $self = shift;
228              
229 12         465 $self->write( <
230             use strict;
231             \$| = 1;
232             $SHARE_PERL
233              
234             $REMOTE_PERL
235             __END__