Permalink
Browse files

Add agorman's test for run_all() called twice, and fix the problem.

Agorman (irc.perl.org #reflex) discovered that run_all() called more
than once asplodes ugly-like.  He provided a nice test case, which
I've added to Reflex's tests.  It uses Reflex::POE::Wheel::Run, and
that might need to be removed to make the test more portable.
  • Loading branch information...
rcaputo committed Sep 9, 2010
1 parent 02cbace commit 1b7423a2c48f6137ed8c01c3fe94f293a967f164
@@ -85,7 +85,7 @@ sub valid_params {
# Also handle signals.
observes sigchild_watcher => (
- isa => 'Reflex::PID|Undef',
+ isa => 'Maybe[Reflex::PID]',
role => 'sigchld',
);
View
@@ -34,108 +34,115 @@ POE::Kernel->run();
my %session_object_count;
-my $singleton_session_id = POE::Session->create(
- inline_states => {
- # Make the session conveniently accessible.
- # Although we're using the $singleton_session_id, so why bother?
-
- _start => sub {
- # No-op to satisfy assertions.
- undef;
- },
- _stop => sub {
- # No-op to satisfy assertions.
- undef;
- },
+my $singleton_session_id;
- ### Timer manipulators and callbacks.
+sub _create_singleton_session {
+ $singleton_session_id = POE::Session->create(
+ inline_states => {
+ # Make the session conveniently accessible.
+ # Although we're using the $singleton_session_id, so why bother?
- timer_due => sub {
- my $envelope = $_[ARG0];
- my ($cb_object, $cb_method) = @$envelope;
- $cb_object->$cb_method({});
- },
+ _start => sub {
+ # No-op to satisfy assertions.
+ undef;
+ },
+ _stop => sub {
+ # No-op to satisfy assertions.
+ undef;
+ },
- ### I/O manipulators and callbacks.
+ ### Timer manipulators and callbacks.
- select_ready => sub {
- my ($handle, $envelope, $mode) = @_[ARG0, ARG2];
- my ($cb_object, $cb_method) = @$envelope;
- $cb_object->$cb_method({ handle => $handle });
- },
+ timer_due => sub {
+ my $envelope = $_[ARG0];
+ my ($cb_object, $cb_method) = @$envelope;
+ $cb_object->$cb_method({});
+ },
- ### Signals.
+ ### I/O manipulators and callbacks.
- signal_happened => sub {
- my $signal_class = pop @_;
- $signal_class->deliver(@_[ARG0..$#_]);
- },
+ select_ready => sub {
+ my ($handle, $envelope, $mode) = @_[ARG0, ARG2];
+ my ($cb_object, $cb_method) = @$envelope;
+ $cb_object->$cb_method({ handle => $handle });
+ },
- ### Cross-session emit() is converted into these events.
+ ### Signals.
- deliver_callback => sub {
- my ($callback, $args) = @_[ARG0, ARG1];
- $callback->deliver($args);
- },
+ signal_happened => sub {
+ my $signal_class = pop @_;
+ $signal_class->deliver(@_[ARG0..$#_]);
+ },
- # call_gate() uses this to call methods in the right session.
+ ### Cross-session emit() is converted into these events.
- call_gate_method => sub {
- my ($object, $method, @args) = @_[ARG0..$#_];
- return $object->$method(@args);
- },
+ deliver_callback => sub {
+ my ($callback, $args) = @_[ARG0, ARG1];
+ $callback->deliver($args);
+ },
- call_gate_coderef => sub {
- my ($coderef, @args) = @_[ARG0..$#_];
- return $coderef->(@args);
- },
+ # call_gate() uses this to call methods in the right session.
- # Catch dynamic events.
+ call_gate_method => sub {
+ my ($object, $method, @args) = @_[ARG0..$#_];
+ return $object->$method(@args);
+ },
- _default => sub {
- my ($event, $args) = @_[ARG0, ARG1];
+ call_gate_coderef => sub {
+ my ($coderef, @args) = @_[ARG0..$#_];
+ return $coderef->(@args);
+ },
- return $event->deliver($args) if (
- "$event" =~ /^Reflex::POE::Event(?:::|=)/
- );
+ # Catch dynamic events.
- return if Reflex::POE::Session->deliver($_[SENDER]->ID, $event, $args);
+ _default => sub {
+ my ($event, $args) = @_[ARG0, ARG1];
- # Unhandled event.
- # TODO - Should anything special be done in this case?
- },
+ return $event->deliver($args) if (
+ "$event" =~ /^Reflex::POE::Event(?:::|=)/
+ );
- ### Support POE::Wheel classes.
+ return if Reflex::POE::Session->deliver($_[SENDER]->ID, $event, $args);
- # Deliver to wheels based on the wheel ID. Different wheels pass
- # their IDs in different ARGn offsets, so we need a few of these.
- wheel_event_0 => sub {
- $_[CALLER_FILE] =~ m{/([^/.]+)\.pm};
- "Reflex::POE::Wheel:\:$1"->deliver(0, @_[ARG0..$#_]);
- },
- wheel_event_1 => sub {
- $_[CALLER_FILE] =~ m{/([^/.]+)\.pm};
- "Reflex::POE::Wheel:\:$1"->deliver(1, @_[ARG0..$#_]);
- },
- wheel_event_2 => sub {
- $_[CALLER_FILE] =~ m{/([^/.]+)\.pm};
- "Reflex::POE::Wheel:\:$1"->deliver(2, @_[ARG0..$#_]);
- },
- wheel_event_3 => sub {
- $_[CALLER_FILE] =~ m{/([^/.]+)\.pm};
- "Reflex::POE::Wheel:\:$1"->deliver(3, @_[ARG0..$#_]);
- },
- wheel_event_4 => sub {
- $_[CALLER_FILE] =~ m{/([^/.]+)\.pm};
- "Reflex::POE::Wheel:\:$1"->deliver(4, @_[ARG0..$#_]);
+ # Unhandled event.
+ # TODO - Should anything special be done in this case?
+ },
+
+ ### Support POE::Wheel classes.
+
+ # Deliver to wheels based on the wheel ID. Different wheels pass
+ # their IDs in different ARGn offsets, so we need a few of these.
+ wheel_event_0 => sub {
+ $_[CALLER_FILE] =~ m{/([^/.]+)\.pm};
+ "Reflex::POE::Wheel:\:$1"->deliver(0, @_[ARG0..$#_]);
+ },
+ wheel_event_1 => sub {
+ $_[CALLER_FILE] =~ m{/([^/.]+)\.pm};
+ "Reflex::POE::Wheel:\:$1"->deliver(1, @_[ARG0..$#_]);
+ },
+ wheel_event_2 => sub {
+ $_[CALLER_FILE] =~ m{/([^/.]+)\.pm};
+ "Reflex::POE::Wheel:\:$1"->deliver(2, @_[ARG0..$#_]);
+ },
+ wheel_event_3 => sub {
+ $_[CALLER_FILE] =~ m{/([^/.]+)\.pm};
+ "Reflex::POE::Wheel:\:$1"->deliver(3, @_[ARG0..$#_]);
+ },
+ wheel_event_4 => sub {
+ $_[CALLER_FILE] =~ m{/([^/.]+)\.pm};
+ "Reflex::POE::Wheel:\:$1"->deliver(4, @_[ARG0..$#_]);
+ },
},
- },
-)->ID();
+ )->ID();
+}
has session_id => (
isa => 'Str',
is => 'ro',
- default => $singleton_session_id,
+ default => sub {
+ _create_singleton_session() unless defined $singleton_session_id;
+ $singleton_session_id;
+ },
);
# What's watching me.
@@ -547,6 +554,7 @@ sub call_gate {
$POE::Kernel::poe_kernel->call(
$self->session_id(), "call_gate_method", $self, $method, @_[2..$#_]
);
+
return 0;
}
@@ -575,6 +583,7 @@ sub run_within_session {
sub run_all {
POE::Kernel->run();
+ $singleton_session_id = undef;
}
sub next {
File renamed without changes.
File renamed without changes.
File renamed without changes.
File renamed without changes.
File renamed without changes.
File renamed without changes.
File renamed without changes.
File renamed without changes.
View
@@ -0,0 +1,90 @@
+{
+ package Runner;
+ use Moose;
+ extends 'Reflex::Base';
+ use Reflex::POE::Wheel::Run;
+ use Reflex::Callbacks qw(cb_role);
+
+ use constant VERBOSE => 0;
+
+ has count => (
+ is => 'rw',
+ isa => 'ScalarRef',
+ );
+
+ has wheel => (
+ isa => 'Reflex::POE::Wheel::Run|Undef',
+ is => 'rw',
+ );
+
+ has end => (
+ isa => 'Int',
+ is => 'ro',
+ );
+
+ sub BUILD {
+ my $self = shift;
+
+ $self->wheel(
+ Reflex::POE::Wheel::Run->new(
+ Program => "$^X -wle 'print qq[pid(\$\$) moo(\$_)] for 1..".$self->end."; exit'",
+ cb_role($self, "child"),
+ )
+ );
+ }
+
+ sub on_child_stdin {
+ VERBOSE and Test::More::diag("stdin flushed");
+ }
+
+ sub on_child_stdout {
+ my ($self, $args) = @_;
+ VERBOSE and Test::More::diag("stdout: $args->{output}");
+ ${$self->count()}++;
+ }
+
+ sub on_child_stderr {
+ my ($self, $args) = @_;
+ VERBOSE and Test::More::diag("stderr: $args->{output}");
+ }
+
+ sub on_child_error {
+ my ($self, $args) = @_;
+ return if $args->{operation} eq "read";
+ VERBOSE and Test::More::diag(
+ "$args->{operation} error $args->{errnum}: $args->{errstr}"
+ );
+ }
+
+ sub on_child_close {
+ my ($self, $args) = @_;
+ VERBOSE and Test::More::diag("child closed all output");
+ }
+
+ sub on_child_signal {
+ my ($self, $args) = @_;
+ VERBOSE and Test::More::diag("child $args->{pid} exited: $args->{exit}");
+ $self->wheel(undef);
+ }
+}
+
+# Main.
+
+use Test::More tests => 2;
+
+{
+ my ($end, $count) = (1, 0);
+ my $runner = Runner->new(end => 1, count => \$count);
+ Reflex->run_all();
+ is($end, $count, "first run ran to completion");
+}
+
+{
+ my ($end, $count) = (10, 0);
+ my $runner2 = Runner->new(end => 10, count => \$count);
+ Reflex->run_all();
+ Reflex->run_all();
+ is($end, $count, "second run ran to completion");
+}
+
+exit;

0 comments on commit 1b7423a

Please sign in to comment.