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; |
7
|
|
|
|
|
|
|
|
8
|
12
|
|
|
12
|
|
408981
|
use strict; |
|
12
|
|
|
|
|
29
|
|
|
12
|
|
|
|
|
426
|
|
9
|
12
|
|
|
12
|
|
70
|
use warnings; |
|
12
|
|
|
|
|
28
|
|
|
12
|
|
|
|
|
428
|
|
10
|
|
|
|
|
|
|
|
11
|
12
|
|
|
12
|
|
61
|
use base qw( IPC::PerlSSH::Base ); |
|
12
|
|
|
|
|
17
|
|
|
12
|
|
|
|
|
6665
|
|
12
|
|
|
|
|
|
|
|
13
|
12
|
|
|
12
|
|
11891
|
use IPC::Open2; |
|
12
|
|
|
|
|
63498
|
|
|
12
|
|
|
|
|
701
|
|
14
|
|
|
|
|
|
|
|
15
|
12
|
|
|
12
|
|
207
|
use Carp; |
|
12
|
|
|
|
|
23
|
|
|
12
|
|
|
|
|
14943
|
|
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
our $VERSION = '0.16'; |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
=head1 NAME |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
C - execute remote perl code over an SSH link |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
=head1 SYNOPSIS |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
use IPC::PerlSSH; |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
my $ips = IPC::PerlSSH->new( Host => "over.there" ); |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
$ips->eval( "use POSIX qw( uname )" ); |
30
|
|
|
|
|
|
|
my @remote_uname = $ips->eval( "uname()" ); |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
# We can pass arguments |
33
|
|
|
|
|
|
|
$ips->eval( 'open FILE, ">", $_[0]; print FILE $_[1]; close FILE;', |
34
|
|
|
|
|
|
|
"foo.txt", "Hello, world!" ); |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
# We can pre-compile stored procedures |
37
|
|
|
|
|
|
|
$ips->store( "get_file", 'local $/; |
38
|
|
|
|
|
|
|
open FILE, "<", $_[0]; |
39
|
|
|
|
|
|
|
$_ = ; |
40
|
|
|
|
|
|
|
close FILE; |
41
|
|
|
|
|
|
|
return $_;' ); |
42
|
|
|
|
|
|
|
foreach my $file ( @files ) { |
43
|
|
|
|
|
|
|
my $content = $ips->call( "get_file", $file ); |
44
|
|
|
|
|
|
|
... |
45
|
|
|
|
|
|
|
} |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
# We can use existing libraries for remote stored procedures |
48
|
|
|
|
|
|
|
$ips->use_library( "FS", qw( readfile ) ); |
49
|
|
|
|
|
|
|
foreach my $file ( @files ) { |
50
|
|
|
|
|
|
|
my $content = $ips->call( "readfile", $file ); |
51
|
|
|
|
|
|
|
... |
52
|
|
|
|
|
|
|
} |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
=head1 DESCRIPTION |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
This module provides an object class that provides a mechanism to execute perl |
57
|
|
|
|
|
|
|
code in a remote instance of perl running on another host, communicated via an |
58
|
|
|
|
|
|
|
SSH link or similar connection. Where it differs from most other IPC modules |
59
|
|
|
|
|
|
|
is that no special software is required on the remote end, other than the |
60
|
|
|
|
|
|
|
ability to run perl. In particular, it is not required that the |
61
|
|
|
|
|
|
|
C module is installed there. Nor are any special administrative |
62
|
|
|
|
|
|
|
rights required; any account that has shell access and can execute the perl |
63
|
|
|
|
|
|
|
binary on the remote host can use this module. |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
=head2 Argument Passing |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
The arguments to, and return values from, remote code are always transferred |
68
|
|
|
|
|
|
|
as lists of strings. This has the following effects on various types of |
69
|
|
|
|
|
|
|
values: |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
=over 8 |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
=item * |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
String values are passed as they stand. |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
=item * |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
Booleans and integers will become stringified, but will work as expected once |
80
|
|
|
|
|
|
|
they reach the other side of the connection. |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
=item * |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
Floating-point numbers will get converted to a decimal notation, which may |
85
|
|
|
|
|
|
|
lose precision. |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
=item * |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
A single array of strings, or a single hash of string values, can be passed |
90
|
|
|
|
|
|
|
by-value as a list, possibly after positional arguments: |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
$ips->store( 'foo', 'my ( $arg, @list ) = @_; ...' ); |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
$ips->store( 'bar', 'my %opts = @_; ...' ); |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
=item * |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
No reference value, including IO handles, can be passed; instead it will be |
99
|
|
|
|
|
|
|
stringified. |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
=back |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
To pass or return a more complex structure, consider using a module such as |
104
|
|
|
|
|
|
|
L, which can serialise the structure into a plain string, to be |
105
|
|
|
|
|
|
|
deserialised on the remote end. Be aware however, that C was only |
106
|
|
|
|
|
|
|
added to core in perl 5.7.3, so if the remote perl is older, it may not be |
107
|
|
|
|
|
|
|
available. |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
To work with remote IO handles, see the L module. |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
=cut |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
=head1 CONSTRUCTORS |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
=cut |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
=head2 $ips = IPC::PerlSSH->new( Host => $host, ... ) |
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
Returns a new instance of a C object connected to the specified |
120
|
|
|
|
|
|
|
host. The following arguments can be specified: |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
=over 8 |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
=item Host => STRING |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
Connect to a named host. |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
=item Port => INT |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
Optionally specify a non-default port. |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
=item Perl => STRING |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
Optionally pass in the path to the perl binary in the remote host. |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
=item User => STRING |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
Optionally pass in an alternative username |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
=item SshPath => STRING |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
Optionally specify a different path to the F binary |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
=item SshOptions => ARRAY |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
Optionally specify any other options to pass to the F binary, in an |
147
|
|
|
|
|
|
|
C reference |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
=back |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
=head2 $ips = IPC::PerlSSH->new( Command => \@command, ... ) |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
Returns a new instance of a C object which uses the STDIN/STDOUT |
154
|
|
|
|
|
|
|
streams of a command it executes, as the streams to communicate with the |
155
|
|
|
|
|
|
|
remote F. |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
=over 8 |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
=item Command => ARRAY |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
Specifies the command to execute |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
=item Command => STRING |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
Shorthand form for executing a single simple path |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
=back |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
The C key can be used to create an C running perl |
170
|
|
|
|
|
|
|
directly on the local machine, for example; so that the "remote" perl is in |
171
|
|
|
|
|
|
|
fact running locally, but still in its own process. |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
my $ips = IPC::PerlSSH->new( Command => $^X ); |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
=head2 $ips = IPC::PerlSSH->new( Readh => $rd, Writeh => $wr ) |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
Returns a new instance of a C object using a given pair of |
178
|
|
|
|
|
|
|
filehandles to read from and write to the remote F process. It is |
179
|
|
|
|
|
|
|
allowable for both filehandles to be the same - for example using a socket. |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
=head2 $ips = IPC::PerlSSH->new( Readfunc => \&read, Writefunc => \&write ) |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
Returns a new instance of a C object using a given pair of |
184
|
|
|
|
|
|
|
functions as read and write operators. |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
Usually this form won't be used in practice; it largely exists to assist the |
187
|
|
|
|
|
|
|
test scripts. But since it works, it is included in the interface in case the |
188
|
|
|
|
|
|
|
earlier alternatives are not suitable. |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
The functions are called as |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
$len = $Readfunc->( my $buffer, $maxlen ); |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
$len = $Writewrite->( $buffer ); |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
In each case, the returned value should be the number of bytes read or |
197
|
|
|
|
|
|
|
written. |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
=cut |
200
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
sub new |
202
|
|
|
|
|
|
|
{ |
203
|
12
|
|
|
12
|
1
|
8544
|
my $class = shift; |
204
|
12
|
|
|
|
|
71
|
my %opts = @_; |
205
|
|
|
|
|
|
|
|
206
|
12
|
|
|
|
|
97
|
my $self = bless { |
207
|
|
|
|
|
|
|
readbuff => "", |
208
|
|
|
|
|
|
|
stored => {}, |
209
|
|
|
|
|
|
|
}, $class; |
210
|
|
|
|
|
|
|
|
211
|
12
|
|
|
|
|
69
|
my ( $readfunc, $writefunc ) = ( delete $opts{Readfunc}, delete $opts{Writefunc} ); |
212
|
|
|
|
|
|
|
|
213
|
12
|
|
|
|
|
30
|
my $pid = delete $opts{Pid}; |
214
|
|
|
|
|
|
|
|
215
|
12
|
100
|
66
|
|
|
117
|
if( !defined $readfunc || !defined $writefunc ) { |
216
|
11
|
|
|
|
|
41
|
my ( $readh, $writeh ) = ( delete $opts{Readh}, delete $opts{Writeh} ); |
217
|
|
|
|
|
|
|
|
218
|
11
|
100
|
66
|
|
|
71
|
if( !defined $readh || !defined $writeh ) { |
219
|
10
|
|
|
|
|
137
|
my @command = $self->build_command_from( \%opts ); |
220
|
10
|
|
|
|
|
69
|
$pid = open2( $readh, $writeh, @command ); |
221
|
|
|
|
|
|
|
} |
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
$readfunc = sub { |
224
|
76
|
|
|
76
|
|
194996
|
sysread( $readh, $_[0], $_[1] ); |
225
|
11
|
|
|
|
|
78259
|
}; |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
$writefunc = sub { |
228
|
83
|
|
|
83
|
|
4739
|
syswrite( $writeh, $_[0] ); |
229
|
11
|
|
|
|
|
149
|
}; |
230
|
|
|
|
|
|
|
} |
231
|
|
|
|
|
|
|
|
232
|
12
|
50
|
|
|
|
159
|
keys %opts and |
233
|
|
|
|
|
|
|
croak "Unexpected ->new keys - " . join ", ", sort keys %opts; |
234
|
|
|
|
|
|
|
|
235
|
12
|
|
|
|
|
239
|
$self->{pid} = $pid; |
236
|
12
|
|
|
|
|
172
|
$self->{readfunc} = $readfunc; |
237
|
12
|
|
|
|
|
56
|
$self->{writefunc} = $writefunc; |
238
|
|
|
|
|
|
|
|
239
|
12
|
|
|
|
|
749
|
$self->send_firmware; |
240
|
|
|
|
|
|
|
|
241
|
12
|
|
|
|
|
188
|
return $self; |
242
|
|
|
|
|
|
|
} |
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
sub write |
245
|
|
|
|
|
|
|
{ |
246
|
89
|
|
|
89
|
0
|
163
|
my $self = shift; |
247
|
89
|
|
|
|
|
183
|
my ( $data ) = @_; |
248
|
|
|
|
|
|
|
|
249
|
89
|
|
|
|
|
348
|
$self->{writefunc}->( $data ); |
250
|
|
|
|
|
|
|
} |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
sub read_message |
253
|
|
|
|
|
|
|
{ |
254
|
77
|
|
|
77
|
0
|
121
|
my $self = shift; |
255
|
|
|
|
|
|
|
|
256
|
77
|
|
|
|
|
97
|
my ( $message, @args ); |
257
|
|
|
|
|
|
|
|
258
|
77
|
|
|
|
|
222
|
while( !defined $message ) { |
259
|
81
|
|
|
|
|
153
|
my $b; |
260
|
81
|
100
|
|
|
|
282
|
$self->{readfunc}->( $b, 8192 ) or return ( "CLOSED" ); |
261
|
80
|
|
|
|
|
1057
|
$self->{readbuff} .= $b; |
262
|
80
|
|
|
|
|
574
|
( $message, @args ) = $self->parse_message( $self->{readbuff} ); |
263
|
|
|
|
|
|
|
} |
264
|
|
|
|
|
|
|
|
265
|
76
|
|
|
|
|
3368
|
return ( $message, @args ); |
266
|
|
|
|
|
|
|
} |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
=head1 METHODS |
269
|
|
|
|
|
|
|
|
270
|
|
|
|
|
|
|
=cut |
271
|
|
|
|
|
|
|
|
272
|
|
|
|
|
|
|
=head2 @result = $ips->eval( $code, @args ) |
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
This method evaluates code in the remote host, passing arguments and returning |
275
|
|
|
|
|
|
|
the result. |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
The code should be passed in a string, and is evaluated using a string |
278
|
|
|
|
|
|
|
C in the remote host, in list context. If this method is called in |
279
|
|
|
|
|
|
|
scalar context, then only the first element of the returned list is returned. |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
If the remote code threw an exception, then this function propagates it as a |
282
|
|
|
|
|
|
|
plain string. If the remote process exits before responding, this will be |
283
|
|
|
|
|
|
|
propagated as an exception. |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
=cut |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
sub eval |
288
|
|
|
|
|
|
|
{ |
289
|
18
|
|
|
18
|
1
|
25144
|
my $self = shift; |
290
|
18
|
|
|
|
|
1006
|
my ( $code, @args ) = @_; |
291
|
|
|
|
|
|
|
|
292
|
18
|
|
|
|
|
262
|
$self->write_message( "EVAL", $code, @args ); |
293
|
|
|
|
|
|
|
|
294
|
18
|
|
|
|
|
203
|
my ( $ret, @retargs ) = $self->read_message; |
295
|
|
|
|
|
|
|
|
296
|
18
|
100
|
|
|
|
364
|
if( $ret eq "RETURNED" ) { |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
297
|
|
|
|
|
|
|
# If the caller didn't want an array and we received more than one result |
298
|
|
|
|
|
|
|
# from the far end; we'll just have to throw it away... |
299
|
17
|
100
|
|
|
|
3231
|
return wantarray ? @retargs : $retargs[0]; |
300
|
|
|
|
|
|
|
} |
301
|
|
|
|
|
|
|
elsif( $ret eq "DIED" ) { |
302
|
0
|
|
|
|
|
0
|
my ( $message ) = @retargs; |
303
|
0
|
0
|
|
|
|
0
|
if( $message =~ m/^While compiling code:.* at \(eval \d+\) line (\d+)/ ) { |
304
|
0
|
|
|
|
|
0
|
$message .= " ==> " . (split m/\n/, $code)[$1 - 1] . "\n"; |
305
|
|
|
|
|
|
|
} |
306
|
0
|
|
|
|
|
0
|
die "Remote host threw an exception:\n$message"; |
307
|
|
|
|
|
|
|
} |
308
|
|
|
|
|
|
|
elsif( $ret eq "CLOSED" ) { |
309
|
1
|
|
|
|
|
21
|
die "Remote connection closed\n"; |
310
|
|
|
|
|
|
|
} |
311
|
|
|
|
|
|
|
else { |
312
|
0
|
|
|
|
|
0
|
die "Unknown return result $ret\n"; |
313
|
|
|
|
|
|
|
} |
314
|
|
|
|
|
|
|
} |
315
|
|
|
|
|
|
|
|
316
|
|
|
|
|
|
|
=head2 $ips->store( $name, $code ) |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
=head2 $ips->store( %funcs ) |
319
|
|
|
|
|
|
|
|
320
|
|
|
|
|
|
|
This method sends code to the remote host to store in named procedure(s) which |
321
|
|
|
|
|
|
|
can be executed later. The code should be passed in strings. |
322
|
|
|
|
|
|
|
|
323
|
|
|
|
|
|
|
While the code is not executed, it will still be compiled into CODE references |
324
|
|
|
|
|
|
|
in the remote host. Any compile errors that occur will be throw as exceptions |
325
|
|
|
|
|
|
|
by this method. |
326
|
|
|
|
|
|
|
|
327
|
|
|
|
|
|
|
Multiple functions may be passed in a hash, to reduce the number of network |
328
|
|
|
|
|
|
|
roundtrips, which may help latency. |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
=cut |
331
|
|
|
|
|
|
|
|
332
|
|
|
|
|
|
|
sub store |
333
|
|
|
|
|
|
|
{ |
334
|
7
|
|
|
7
|
1
|
3784
|
my $self = shift; |
335
|
7
|
|
|
|
|
36
|
my %funcs = @_; |
336
|
|
|
|
|
|
|
|
337
|
7
|
|
|
|
|
32
|
foreach my $name ( keys %funcs ) { |
338
|
7
|
100
|
|
|
|
36
|
$self->_has_stored_code( $name ) and croak "Already have a stored function called '$name'"; |
339
|
|
|
|
|
|
|
} |
340
|
|
|
|
|
|
|
|
341
|
5
|
|
|
|
|
31
|
$self->write_message( "STORE", %funcs ); |
342
|
|
|
|
|
|
|
|
343
|
5
|
|
|
|
|
24
|
my ( $ret, @retargs ) = $self->read_message; |
344
|
|
|
|
|
|
|
|
345
|
5
|
50
|
|
|
|
24
|
if( $ret eq "OK" ) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
346
|
5
|
|
|
|
|
26
|
$self->{stored}{$_} = 1 for keys %funcs; |
347
|
5
|
|
|
|
|
19
|
return; |
348
|
|
|
|
|
|
|
} |
349
|
|
|
|
|
|
|
elsif( $ret eq "DIED" ) { |
350
|
0
|
|
|
|
|
0
|
my ( $message ) = @retargs; |
351
|
0
|
0
|
|
|
|
0
|
if( $message =~ m/^While compiling code for (\S+):.* at \(eval \d+\) line (\d+)/ ) { |
352
|
0
|
|
|
|
|
0
|
my $code = $funcs{$1}; |
353
|
0
|
|
|
|
|
0
|
$message .= " ==> " . (split m/\n/, $code)[$2 - 1] . "\n"; |
354
|
|
|
|
|
|
|
} |
355
|
0
|
|
|
|
|
0
|
die "Remote host threw an exception:\n$message"; |
356
|
|
|
|
|
|
|
} |
357
|
|
|
|
|
|
|
elsif( $ret eq "CLOSED" ) { |
358
|
0
|
|
|
|
|
0
|
die "Remote connection closed\n"; |
359
|
|
|
|
|
|
|
} |
360
|
|
|
|
|
|
|
else { |
361
|
0
|
|
|
|
|
0
|
die "Unknown return result $ret\n"; |
362
|
|
|
|
|
|
|
} |
363
|
|
|
|
|
|
|
} |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
sub _has_stored_code |
366
|
|
|
|
|
|
|
{ |
367
|
131
|
|
|
131
|
|
311
|
my $self = shift; |
368
|
131
|
|
|
|
|
202
|
my ( $name ) = @_; |
369
|
131
|
|
|
|
|
1475
|
return exists $self->{stored}{$name}; |
370
|
|
|
|
|
|
|
} |
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
=head2 $ips->bind( $name, $code ) |
373
|
|
|
|
|
|
|
|
374
|
|
|
|
|
|
|
This method is identical to the C method, except that the remote |
375
|
|
|
|
|
|
|
function will be available as a plain function within the local perl |
376
|
|
|
|
|
|
|
program, as a function of the given name in the caller's package. |
377
|
|
|
|
|
|
|
|
378
|
|
|
|
|
|
|
=cut |
379
|
|
|
|
|
|
|
|
380
|
|
|
|
|
|
|
sub bind |
381
|
|
|
|
|
|
|
{ |
382
|
2
|
|
|
2
|
1
|
2375
|
my $self = shift; |
383
|
2
|
|
|
|
|
9
|
my ( $name, $code ) = @_; |
384
|
|
|
|
|
|
|
|
385
|
2
|
|
|
|
|
13
|
$self->store( $name, $code ); |
386
|
|
|
|
|
|
|
|
387
|
2
|
|
|
|
|
8
|
my $caller = (caller)[0]; |
388
|
|
|
|
|
|
|
{ |
389
|
12
|
|
|
12
|
|
89
|
no strict 'refs'; |
|
12
|
|
|
|
|
26
|
|
|
12
|
|
|
|
|
6730
|
|
|
2
|
|
|
|
|
4
|
|
390
|
2
|
|
|
2
|
|
22
|
*{$caller."::$name"} = sub { $self->call( $name, @_ ) }; |
|
2
|
|
|
|
|
23
|
|
|
2
|
|
|
|
|
13
|
|
391
|
|
|
|
|
|
|
} |
392
|
|
|
|
|
|
|
} |
393
|
|
|
|
|
|
|
|
394
|
|
|
|
|
|
|
=head2 @result = $ips->call( $name, @args ) |
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
This method invokes a remote method that has earlier been defined using the |
397
|
|
|
|
|
|
|
C or C methods. The arguments are passed and the result is |
398
|
|
|
|
|
|
|
returned in the same way as with the C method. |
399
|
|
|
|
|
|
|
|
400
|
|
|
|
|
|
|
If an exception occurs during execution, it is propagated and thrown by this |
401
|
|
|
|
|
|
|
method. If the remote process exits before responding, this will be propagated |
402
|
|
|
|
|
|
|
as an exception. |
403
|
|
|
|
|
|
|
|
404
|
|
|
|
|
|
|
=cut |
405
|
|
|
|
|
|
|
|
406
|
|
|
|
|
|
|
sub call |
407
|
|
|
|
|
|
|
{ |
408
|
48
|
|
|
48
|
1
|
72971
|
my $self = shift; |
409
|
48
|
|
|
|
|
171
|
my ( $name, @args ) = @_; |
410
|
|
|
|
|
|
|
|
411
|
48
|
50
|
|
|
|
147
|
$self->_has_stored_code( $name ) or croak "Do not have a stored function called '$name'"; |
412
|
|
|
|
|
|
|
|
413
|
48
|
|
|
|
|
327
|
$self->write_message( "CALL", $name, @args ); |
414
|
|
|
|
|
|
|
|
415
|
48
|
|
|
|
|
162
|
my ( $ret, @retargs ) = $self->read_message; |
416
|
|
|
|
|
|
|
|
417
|
48
|
50
|
|
|
|
151
|
if( $ret eq "RETURNED" ) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
418
|
|
|
|
|
|
|
# If the caller didn't want an array and we received more than one result |
419
|
|
|
|
|
|
|
# from the far end; we'll just have to throw it away... |
420
|
48
|
100
|
|
|
|
863
|
return wantarray ? @retargs : $retargs[0]; |
421
|
|
|
|
|
|
|
} |
422
|
|
|
|
|
|
|
elsif( $ret eq "DIED" ) { |
423
|
0
|
|
|
|
|
0
|
die "Remote host threw an exception:\n$retargs[0]"; |
424
|
|
|
|
|
|
|
} |
425
|
|
|
|
|
|
|
elsif( $ret eq "CLOSED" ) { |
426
|
0
|
|
|
|
|
0
|
die "Remote connection closed\n"; |
427
|
|
|
|
|
|
|
} |
428
|
|
|
|
|
|
|
else { |
429
|
0
|
|
|
|
|
0
|
die "Unknown return result $ret\n"; |
430
|
|
|
|
|
|
|
} |
431
|
|
|
|
|
|
|
} |
432
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
=head2 $ips->use_library( $library, @funcs ) |
434
|
|
|
|
|
|
|
|
435
|
|
|
|
|
|
|
This method loads a library of code from a module, and stores them to the |
436
|
|
|
|
|
|
|
remote perl by calling C on each one. The C<$library> name may be a |
437
|
|
|
|
|
|
|
full class name, or a name within the C space. |
438
|
|
|
|
|
|
|
|
439
|
|
|
|
|
|
|
If the C<@funcs> list is non-empty, then only those named functions are stored |
440
|
|
|
|
|
|
|
(analogous to the C |
441
|
|
|
|
|
|
|
libraries that define many functions, only a few of which are actually used. |
442
|
|
|
|
|
|
|
|
443
|
|
|
|
|
|
|
For more information, see L. |
444
|
|
|
|
|
|
|
|
445
|
|
|
|
|
|
|
=cut |
446
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
sub use_library |
448
|
|
|
|
|
|
|
{ |
449
|
9
|
|
|
9
|
1
|
4598
|
my $self = shift; |
450
|
|
|
|
|
|
|
|
451
|
9
|
|
|
|
|
133
|
my ( $package, $funcs ) = $self->load_library_pkg( @_ ); |
452
|
|
|
|
|
|
|
|
453
|
6
|
100
|
|
|
|
50
|
$self->{stored_pkg}{$package} and delete $funcs->{_init}; |
454
|
|
|
|
|
|
|
|
455
|
6
|
|
|
|
|
89
|
$self->write_message( "STOREPKG", $package, %$funcs ); |
456
|
|
|
|
|
|
|
|
457
|
6
|
|
|
|
|
37
|
my ( $ret, @retargs ) = $self->read_message; |
458
|
|
|
|
|
|
|
|
459
|
6
|
50
|
|
|
|
37
|
if( $ret eq "OK" ) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
460
|
6
|
|
|
|
|
339
|
$self->{stored_pkg}{$package} = 1; |
461
|
6
|
|
|
|
|
227
|
$self->{stored}{$_} = 1 for keys %$funcs; |
462
|
6
|
|
|
|
|
170
|
return; |
463
|
|
|
|
|
|
|
} |
464
|
|
|
|
|
|
|
elsif( $ret eq "DIED" ) { |
465
|
0
|
|
|
|
|
0
|
die "Remote host threw an exception:\n$retargs[0]"; |
466
|
|
|
|
|
|
|
} |
467
|
|
|
|
|
|
|
elsif( $ret eq "CLOSED" ) { |
468
|
0
|
|
|
|
|
0
|
die "Remote connection closed\n"; |
469
|
|
|
|
|
|
|
} |
470
|
|
|
|
|
|
|
else { |
471
|
0
|
|
|
|
|
0
|
die "Unknown return result $ret\n"; |
472
|
|
|
|
|
|
|
} |
473
|
|
|
|
|
|
|
} |
474
|
|
|
|
|
|
|
|
475
|
|
|
|
|
|
|
sub DESTROY |
476
|
|
|
|
|
|
|
{ |
477
|
10
|
|
|
10
|
|
17207
|
my $self = shift; |
478
|
|
|
|
|
|
|
|
479
|
10
|
|
|
|
|
41
|
undef $self->{readfunc}; |
480
|
10
|
|
|
|
|
271
|
undef $self->{writefunc}; |
481
|
|
|
|
|
|
|
# This will clean up the closures, and hence close the filehandles that are |
482
|
|
|
|
|
|
|
# referenced by them. The remote perl will then shut down, and we can wait |
483
|
|
|
|
|
|
|
# for the child process to exit |
484
|
|
|
|
|
|
|
|
485
|
10
|
100
|
|
|
|
15173
|
waitpid $self->{pid}, 0 if defined $self->{pid}; |
486
|
|
|
|
|
|
|
} |
487
|
|
|
|
|
|
|
|
488
|
|
|
|
|
|
|
=head1 AUTHOR |
489
|
|
|
|
|
|
|
|
490
|
|
|
|
|
|
|
Paul Evans |
491
|
|
|
|
|
|
|
|
492
|
|
|
|
|
|
|
=cut |
493
|
|
|
|
|
|
|
|
494
|
|
|
|
|
|
|
0x55AA; |