148 sub new 149 { 150 my $class = shift; 151 my %opts = @_; 152 153 154 my ( $readfunc, $writefunc ) = ( $opts{Readfunc}, $opts{Writefunc} ); 155 156 my $pid = $opts{Pid}; 157 158 if( !defined $readfunc || !defined $writefunc ) { 159 my @command; 160 if( exists $opts{Command} ) { 161 my $c = $opts{Command}; 162 @command = ref($c) && $c->isa("ARRAY") ? @$c : ( "$c" ); 163 } 164 else { 165 my $host = $opts{Host} or 166 carp __PACKAGE__."->new() requires a Host, a Command or a Readfunc/Writefunc pair"; 167 168 @command = ( "ssh", $host, $opts{Perl} || "perl" ); 169 } 170 171 my ( $readpipe, $writepipe ); 172 $pid = open2( $readpipe, $writepipe, @command ); 173 174 $readfunc = sub { 175 if( defined $_[1] ) { 176 read( $readpipe, $_[0], $_[1] ); 177 } 178 else { 179 $_[0] = <$readpipe>; 180 length( $_[0] ); 181 } 182 }; 183 184 $writefunc = sub { 185 print $writepipe $_[0]; 186 }; 187 } 188 189 # Now stream it the "firmware" 190 $writefunc->( <<EOF ); 191 use strict; 192 193 $COMMON_PERL 194 195 $REMOTE_PERL 196 197 __END__ 198 EOF 199 200 my $self = { 201 readfunc => $readfunc, 202 writefunc => $writefunc, 203 pid => $pid, 204 }; 205 206 return bless $self, $class; 207 }
pp2@nereida:/tmp$ cat -n PerlSSH.pm 1 package IPC::PerlSSH; 2 use strict; 3 use Symbol; 4 use IPC::Open2; 5 use Carp; 6 7 our $VERSION = "0.06"; 8 9 my $COMMON_PERL = <<'EOP'; 10 sub read_operation 11 { 12 my ( $readfunc ) = @_; 13 14 local $/ = "\n"; 15 16 $readfunc->( my $operation, undef ); 17 defined $operation or die "Expected operation\n"; 18 chomp $operation; 19 20 $readfunc->( my $numargs, undef ); 21 defined $numargs or die "Expected number of arguments\n"; 22 chomp $numargs; 23 24 my @args; 25 while( $numargs ) { 26 $readfunc->( my $arglen, undef ); 27 defined $arglen or die "Expected length of argument\n"; 28 chomp $arglen; 29 30 my $arg = ""; 31 while( $arglen ) { 32 my $buffer; 33 my $n = $readfunc->( $buffer, $arglen ); 34 die "read() returned $!\n" unless( defined $n ); 35 $arg .= $buffer; 36 $arglen -= $n; 37 } 38 39 push @args, $arg; 40 $numargs--; 41 } 42 43 return ( $operation, @args ); 44 } 45 46 sub send_operation 47 { 48 my ( $writefunc, $operation, @args ) = @_; 49 50 # Buffer this for speed - this makes a big difference 51 my $buffer = ""; 52 53 $buffer .= "$operation\n"; 54 $buffer .= scalar( @args ) . "\n"; 55 56 foreach my $arg ( @args ) { 57 $buffer .= length( $arg ) . "\n" . "$arg"; 58 } 59 60 $writefunc->( $buffer ); 61 } 62 63 EOP
65 my $REMOTE_PERL = <<'EOP'; 66 $| = 1; 67 68 my %stored_procedures; 69 70 my $readfunc = sub { 71 if( defined $_[1] ) { 72 read( STDIN, $_[0], $_[1] ); 73 } 74 else { 75 $_[0] = <STDIN>; 76 length $_[0]; 77 } 78 }; 79 80 my $writefunc = sub { 81 print STDOUT $_[0]; 82 }; 83 84 while( 1 ) { 85 my ( $operation, @args ) = read_operation( $readfunc ); 86 87 if( $operation eq "QUIT" ) { 88 # Immediate controlled shutdown 89 exit( 0 ); 90 } 91 92 if( $operation eq "EVAL" ) { 93 my $code = shift @args; 94 95 my $subref = eval "sub { $code }"; 96 if( $@ ) { 97 send_operation( $writefunc, "DIED", "While compiling code: $@" ); 98 next; 99 } 100 101 my @results = eval { $subref->( @args ) }; 102 if( $@ ) { 103 send_operation( $writefunc, "DIED", "While running code: $@" ); 104 next; 105 } 106 107 send_operation( $writefunc, "RETURNED", @results ); 108 next; 109 } 110 111 if( $operation eq "STORE" ) { 112 my ( $name, $code ) = @args; 113 114 my $subref = eval "sub { $code }"; 115 if( $@ ) { 116 send_operation( $writefunc, "DIED", "While compiling code: $@" ); 117 next; 118 } 119 120 $stored_procedures{$name} = $subref; 121 send_operation( $writefunc, "OK" ); 122 next; 123 } 124 125 if( $operation eq "CALL" ) { 126 my $name = shift @args; 127 128 my $subref = $stored_procedures{$name}; 129 if( !defined $subref ) { 130 send_operation( $writefunc, "DIED", "No such stored procedure '$name'" ); 131 next; 132 } 133 134 my @results = eval { $subref->( @args ) }; 135 if( $@ ) { 136 send_operation( $writefunc, "DIED", "While running code: $@" ); 137 next; 138 } 139 140 send_operation( $writefunc, "RETURNED", @results ); 141 next; 142 } 143 144 send_operation( $writefunc, "DIED", "Unknown operation $operation" ); 145 } 146 EOP
209 sub eval 210 { 211 my $self = shift; 212 my ( $code, @args ) = @_; 213 214 send_operation( $self->{writefunc}, "EVAL", $code, @args ); 215 216 my ( $ret, @retargs ) = read_operation( $self->{readfunc} ); 217 218 # If the caller didn't want an array and we received more than one result 219 # from the far end; we'll just have to throw it away... 220 return wantarray ? @retargs : $retargs[0] if( $ret eq "RETURNED" ); 221 222 die "Remote host threw an exception:\n$retargs[0]" if( $ret eq "DIED" ); 223 224 die "Unknown return result $ret\n"; 225 } 226 227 sub store 228 { 229 my $self = shift; 230 my ( $name, $code ) = @_; 231 232 send_operation( $self->{writefunc}, "STORE", $name, $code ); 233 234 my ( $ret, @retargs ) = read_operation( $self->{readfunc} ); 235 236 return if( $ret eq "OK" ); 237 238 die "Remote host threw an exception:\n$retargs[0]" if( $ret eq "DIED" ); 239 240 die "Unknown return result $ret\n"; 241 } 242 243 sub bind 244 { 245 my $self = shift; 246 my ( $name, $code ) = @_; 247 248 $self->store( $name, $code ); 249 250 my $caller = (caller)[0]; 251 { 252 no strict 'refs'; 253 *{$caller."::$name"} = sub { $self->call( $name, @_ ) }; 254 } 255 } 256 257 sub call 258 { 259 my $self = shift; 260 my ( $name, @args ) = @_; 261 262 send_operation( $self->{writefunc}, "CALL", $name, @args ); 263 264 my ( $ret, @retargs ) = read_operation( $self->{readfunc} ); 265 266 # If the caller didn't want an array and we received more than one result 267 # from the far end; we'll just have to throw it away... 268 return wantarray ? @retargs : $retargs[0] if( $ret eq "RETURNED" ); 269 270 die "Remote host threw an exception:\n$retargs[0]" if( $ret eq "DIED" ); 271 272 die "Unknown return result $ret\n"; 273 } 274 275 sub DESTROY 276 { 277 my $self = shift; 278 279 send_operation( $self->{writefunc}, "QUIT" ); 280 281 waitpid $self->{pid}, 0 if defined $self->{pid}; 282 } 283 284 eval $COMMON_PERL; 285 286 1;