Open2

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;

ME="SECTION03761080000000000000"> Prioridades

El método prio establece la prioridad de una corutina. Las corutinas con prioridad un número mayor se ejecutan con mas frecuencia que las que tienen un número más pequeño.

Nombre	Valor
PRIO_MAX	3
PRIO_HIGH	1
PRIO_NORMAL	0
PRIO_LOW	-1
PRIO_IDLE	-3
PRIO_MIN	-4

La corutina $Coro::idle tiene menos prioridad que ninguna otra.

Los cambios en la prioridad de la corutina actual tiene lugar inmediatamente. Sin embargo, los cambios efectuados en corutinas que esperan en la cola de preparados solo tiene lugar después de su siguiente planificación.

pp2@nereida:~/src/perl/coro$ cat -n priorities.pl
 1  #!/usr/bin/perl
 2  use strict;
 3  use warnings;
 4  use Coro qw{:prio cede async};
 5
 6  my $prio = shift || PRIO_NORMAL;
 7  my $c = async {
 8     print "2\n";
 9     cede; # yield back to main
10     print "4\n";
11  };
12
13  $c->prio($prio);
14
15  print "1\n";
16  cede; # yield to coroutine
17  print "3\n";
18  cede; # and again

Cuando se ejecuta el programa anterior se obtienen salidas como estas:

pp2@nereida:~/src/perl/coro$ priorities.pl 3 # PRIO_MAX
1
2
4
3
pp2@nereida:~/src/perl/coro$ priorities.pl 1 # PRIO_HIGH
1
2
4
3
pp2@nereida:~/src/perl/coro$ priorities.pl 0 # PRIO_NORMAL
1
2
3
4
pp2@nereida:~/src/perl/coro$ priorities.pl -1 # PRIO_LOW
1
2
3
pp2@nereida:~/src/perl/coro$ priorities.pl -3 # PRIO_IDLE
1
2
3
pp2@nereida:~/src/perl/coro$ priorities.pl -4 # PRIO_MIN
1
2
3
pp2@nereida:~/src/perl/coro$ priorities.pl -5 # No existe
1
2
3
pp2@nereida:~/src/perl/coro$ priorities.pl -300 # No se obtienen errores
1
2
3

El método nice

$newprio = $coroutine->nice($change)

puede ser utilizado para cambiar el valor de la prioridad de $coroutine. En este caso $change es un desplazamiento que se resta a la prioridad actual.

Mientras que cede cede el control a corutinas con prioridad igual o superior, la subrutina Coro::cede_notself cede el control a cualquier corutina, independientemente de cual sea su prioridad.

pp2@nereida:~/src/perl/coro$ cat -n prioidle.pl
     1  #!/usr/bin/perl
     2  use strict;
     3  use warnings;
     4  use Coro qw{:prio async};
     5
     6  my $prio = shift || PRIO_NORMAL;
     7  my $c = async {
     8     print "2\n";
     9     Coro::cede_notself; # yield back to main
    10     print "4\n";
    11  };
    12
    13  $c->prio($prio);
    14
    15  print "1\n";
    16  Coro::cede_notself; # yield to coroutine
    17  print "3\n";
    18  Coro::cede_notself; # and again

Al ejecutarse produce:

pp2@nereida:~/src/perl/coro$ prioidle.pl -1
1
2
3
4
pp2@nereida:~/src/perl/coro$ prioidle.pl -2
1
2
3
4
pp2@nereida:~/src/perl/coro$ prioidle.pl -3
1
2
3
4
pp2@nereida:~/src/perl/coro$ prioidle.pl -4
1
2
3
4