Ejemplo: El Módulo IPC::PerlSSH

El módulo IPC::PerlSSH constituye un excelente ejemplo del uso de open2 . Repase la sección 2.7 para ver un ejemplo de uso. A continuación vemos el código.

Creación de la Conexión

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  }

Parte Común a la Máquina Local y a la Máquina Remota

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

Parte en la Máquina Remota

 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

Familias de Manejadores

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;