From 1db9198437cf035082037c14585d77b846e3af62 Mon Sep 17 00:00:00 2001 From: Rocco Caputo Date: Mon, 29 May 2000 02:43:04 -0400 Subject: [PATCH] lots of testing changes and additions --- Changes | 100 +++++++++- MANIFEST | 4 + README | 19 ++ lib/POE.pm | 2 +- lib/POE/Kernel.pm | 329 ++++++++++++++------------------- lib/POE/Preprocessor.pm | 33 ++-- lib/POE/Session.pm | 19 +- lib/POE/Wheel/ReadWrite.pm | 20 +- lib/POE/Wheel/SocketFactory.pm | 8 +- mylib/Devel/Trace.pm | 130 +++++++++++++ mylib/TestSetup.pm | 109 ++++++++++- mylib/coverage.perl | 147 +++++++++++++++ tests/00_coverage.t | 59 ++++++ tests/01_sessions.t | 98 +++++++++- tests/02_alarms.t | 89 ++++++++- tests/03_aliases.t | 71 +++++-- tests/04_selects.t | 5 +- tests/05_macros.t | 4 +- tests/06_tk.t | 12 +- tests/07_event.t | 35 +++- tests/08_errors.t | 153 +++++++++++++++ tests/09_wheels_unix.t | 231 +++++++++++++++++++++++ tests/10_wheels_tcp.t | 188 +++++++++++++++++++ tests/11_signals_poe.t | 92 +++++++++ 24 files changed, 1681 insertions(+), 276 deletions(-) create mode 100644 mylib/Devel/Trace.pm create mode 100644 mylib/coverage.perl create mode 100644 tests/00_coverage.t create mode 100644 tests/08_errors.t create mode 100644 tests/09_wheels_unix.t create mode 100644 tests/10_wheels_tcp.t create mode 100644 tests/11_signals_poe.t diff --git a/Changes b/Changes index 0570f8c7f..0babc62fd 100644 --- a/Changes +++ b/Changes @@ -18,7 +18,6 @@ subversions are available from . | | Next | -| Clean up the mess made while adding Event and Tk support. | Event doesn't seem very fast; am I using it incorrectly? | | Before 0.11 @@ -34,6 +33,95 @@ subversions are available from . `----------------- +0.1006 2000.??.?? (!!!) +----------------------- + +Expanded t/02_alarms.t to test the big-queue binary search and insert +code. Previous tests didn't expand the alarm queue past the maximum +threshhold for linear insertion. + +Macro-ized some of the redundant bits between the Tk and Event code. + +Normalized the names of some functions; added leading underscores here +and there. + +Added test coverage information to the README. + +Added t/09_wheels_unix.t to test Wheel::ReadWrite and +Wheel::SocketFactory against UNIX domain sockets. This will fail +terribly wherever UNIX sockets aren't supported; I should skip it on +platforms where people complain about its failure. + +Added t/10_wheels_tcp.t to test Wheel::ReadWrite and +Wheel::SocketFactory against INET/TCP sockets. + +Added t/11_signals_poe.t to test POE's stock signal handlers. These +are Perl's own signal handlers, and all the caveats apply. + +Added Exporter; TestSetup exports its functions now. TestSetup use +syntax changed, so I added &test_setup to set things up instead of +&import. + +Added &ok, ¬_ok and &results to buffer and report on the results of +tests that occur in indeterminate orders. + +Added TestSetup functions stderr_pause() and stderr_resume() to turn +STDERR off and back on when testing code known to show diagsonstics. + +Added ID resolution tests to t/03_aliases.t. + +Added the kernel's ID to its ID-to-session lookup table, so that +$kernel->ID_id_to_session($kernel->ID) would return $kernel. It's +silly but complete now. + +Added t/08_errors.t to test error conditions, something that the other +tests never covered. + +Added lib/Devel/Trace.pm. This is a custom debugging module (used +with -d:Trace) that collects information about runnable Perl +statements and the ones actually called. It's only used for reporting +on test coverage during development and isn't installed. + +Added lib/coverage.perl. This program runs t/*.t with -d:Trace to +collect coverage statistics; then it gathers up the results and writes +a report. + +Added t/00_coverage.t to load every "released" module so that the test +coverage report can learn the set of all testable modules. + +Philip Gwyn pointed out that waitpid() returns 0 on some platforms to +indicate outstanding child processes that haven't yet exited. I was +treating 0 as a valid PID. The waitpid() return value checks are +fixed now. + +Fletch found all sorts of badness in POE::Kernel's fork() method and +related polling loop. It boiled down to bad assumptions about +$SIG{CHLD} = 'IGNORE' and a stupid use of keys() without scalar(). + +(!!!) Revised the Changes for 0.0906, dated 2000.02.20 to note an +interface change in Wheel::ReadWrite's put() method. This Changes +change isn't a compatibility issue, but the original change is. + +POE::Preprocessor adds "# line" directives so that macro expansions +don't break line numbers in warnings and errors. Unfortunately, this +badly breaks -d modules, such as the debugger and various profilers. +So now POE::Preprocessor omits "# line" directives when -d is used. +This'll let you see everything being run, at the expense of correct +line numbers. + +Added a rudimentary signals test to t/01_sessions.t, which uses POE's +own event loop. + +Added a rudimentary signals test to t/07_event.t, which uses Event's +event loop. + +Will not add a signals test to t/06_tk.t. Tk does not have its own +signal watchers, so this would only test POE's. + +Made minor revisions to the tiny and relatively new POE::Preprocessor +documentation. + + 0.1005 2000.05.23 ----------------- @@ -348,12 +436,12 @@ removed. Updated documentation for POE::Kernel::alarm() -0.0906 2000.02.20 ------------------ +0.0906 2000.02.20 (!!!) +----------------------- -Revised Wheel::ReadWrite->put() to return true if the high watermark -is reached; false if it hasn't been. ReadWrite->put() may return true -without a corresponding high or low watermark event. +(!!!) Revised Wheel::ReadWrite->put() to return true if the high +watermark is reached; false if it hasn't been. ReadWrite->put() may +return true without a corresponding high or low watermark event. Changed samples/watermarks.perl to use ReadWrite->put()'s return value, as well as the high and low mark states. Commented the program diff --git a/MANIFEST b/MANIFEST index 77d28f92a..f48feb4e7 100644 --- a/MANIFEST +++ b/MANIFEST @@ -64,3 +64,7 @@ t/04_selects.t t/05_macros.t t/06_tk.t t/07_event.t +t/08_errors.t +t/09_wheels_unix.t +t/10_wheels_tcp.t +t/11_signals_poe.t diff --git a/README b/README index 6f31f35df..cfb7be643 100644 --- a/README +++ b/README @@ -3,12 +3,18 @@ $Id$ The bulk of this README's information has migrated to the POE manpage. +------------------------------ +Compatibility Between Versions +------------------------------ As POE moves closer towards the Common Sense axis, it sometimes diverges away from the Backwards Compatible axis. If this version is being installed over a previous one, please check the Changes file to see what it might break. Interface changes usually are documented. +------------------ +Basic Installation +------------------ POE may be installed through the CPAN shell in the usual CPAN shell manner. It typically is: @@ -20,6 +26,9 @@ It involves a little more work if you have an older CPAN shell: perl -MCPAN -e shell install POE +------------------- +Manual Installation +------------------- POE can also be installed manually. The latest CPAN version can be found at or in @@ -48,6 +57,16 @@ Finally you can install it: make install +------------------------- +Test Results and Coverage +------------------------- + +POE's development after 0.1005 consists of a big push to test +everything. To further this effort, the author wrote a test coverage +reporting program; then he discovered Devel::Coverage. Oh well! +Anyway, here's the test coverage summary for this version: + +... don't forget to put them here ... Good luck, and thank you for reading! diff --git a/lib/POE.pm b/lib/POE.pm index 2444db28e..dc61286b2 100644 --- a/lib/POE.pm +++ b/lib/POE.pm @@ -904,6 +904,7 @@ progress report: POE::Kernel rewritten 2000.05.19 POE::Session rewritten 2000.05.21 POE::Wheel rewritten 2000.05.22 + POE::Preprocessor revised 2000.05.23 POE::Component queued POE::Component::Server::TCP queued @@ -914,7 +915,6 @@ progress report: POE::Filter::Line queued POE::Filter::Reference queued POE::Filter::Stream queued - POE::Preprocessor queued POE::Wheel::FollowTail queued POE::Wheel::ListenAccept queued POE::Wheel::ReadWrite queued diff --git a/lib/POE/Kernel.pm b/lib/POE/Kernel.pm index 9b5a00263..70ed1e3d2 100644 --- a/lib/POE/Kernel.pm +++ b/lib/POE/Kernel.pm @@ -174,6 +174,77 @@ macro test_for_idle_poe_kernel { } } +macro post_plain_signal (,) { + $poe_kernel->_enqueue_state( , $poe_kernel, + EN_SIGNAL, ET_SIGNAL, + [ ], + time(), __FILE__, __LINE__ + ); +} + +macro post_child_signal(,,) { + # Determine if the child process is really exiting and not just + # stopping for some other reason. This is per Perl Cookbook recipe + # 16.19. + if (WIFEXITED()) { + $poe_kernel->_enqueue_state( , $poe_kernel, + EN_SIGNAL, ET_SIGNAL, + [ 'CHLD', , ], + time(), __FILE__, __LINE__ + ); + } +} + +macro dispatch_one_from_fifo { + if ( @{ $self->[KR_STATES] } ) { + + # Pull an event off the queue. + + my $event = shift @{ $self->[KR_STATES] }; + {% ses_refcount_dec2 $event->[ST_SESSION], SS_EVCOUNT %} + + # Dispatch it, and see if that was the last thing the session + # needed to do. + + $self->_dispatch_state(@$event); + {% collect_garbage $event->[ST_SESSION] %} + } +} + +macro dispatch_due_alarms { + my $now = time(); + while ( @{ $self->[KR_ALARMS] } and + ($self->[KR_ALARMS]->[0]->[ST_TIME] <= $now) + ) { + + # Pull an alarm off the queue. + + my $event = shift @{ $self->[KR_ALARMS] }; + {% ses_refcount_dec2 $event->[ST_SESSION], SS_ALCOUNT %} + + # Dispatch it, and see if that was the last thing the session + # needed to do. + + $self->_dispatch_state(@$event); + {% collect_garbage $event->[ST_SESSION] %} + } +} + +macro dispatch_ready_selects { + my @selects = + values %{ $self->[KR_HANDLES]->{$handle}->[HND_SESSIONS]->[$vector] }; + + foreach my $select (@selects) { + $self->_dispatch_state + ( $select->[HSS_SESSION], $select->[HSS_SESSION], + $select->[HSS_STATE], ET_SELECT, + [ $select->[HSS_HANDLE] ], + time(), __FILE__, __LINE__, undef + ); + {% collect_garbage $select->[HSS_SESSION] %} + } +} + # MACROS END <-- search tag for editing #------------------------------------------------------------------------------ @@ -428,113 +499,72 @@ const FIFO_DISPATCH_TIME 0.01 my %_terminal_signals = ( QUIT => 1, INT => 1, KILL => 1, TERM => 1, HUP => 1, IDLE => 1 ); -# This is the generic signal handler. It posts the signal notice to -# the POE kernel, which propagates it to every session. +### POE's signal handlers. These are just plain old Perl. -sub _signal_handler_generic { +sub _poe_signal_handler_generic { if (defined $_[0]) { - $poe_kernel->_enqueue_state( $poe_kernel, $poe_kernel, - EN_SIGNAL, ET_SIGNAL, - [ $_[0] ], - time(), __FILE__, __LINE__ - ); - $SIG{$_[0]} = \&_signal_handler_generic; + {% post_plain_signal $poe_kernel, $_[0] %} + $SIG{$_[0]} = \&_poe_signal_handler_generic; } else { warn "POE::Kernel::_signal_handler_generic detected an undefined signal"; } } -# This is Event's generic signal handler. -sub _event_signal_handler_generic { - my $event = shift; - $poe_kernel->_enqueue_state( $poe_kernel, $poe_kernel, - EN_SIGNAL, ET_SIGNAL, - [ $event->w->signal ], - time(), __FILE__, __LINE__ - ); -} - # SIGPIPE is handled a little differently. It tends to be # synchronous, so it's posted at the current active session. We can # do this better by generating a pseudo SIGPIPE whenever a driver # returns EPIPE, but that requires people to use Wheel::ReadWrite on # similar dilligence. -sub _signal_handler_pipe { +sub _poe_signal_handler_pipe { if (defined $_[0]) { - $poe_kernel->_enqueue_state( $poe_kernel->[KR_ACTIVE_SESSION], $poe_kernel, - EN_SIGNAL, ET_SIGNAL, - [ $_[0] ], - time(), __FILE__, __LINE__ - ); - $SIG{$_[0]} = \&_signal_handler_pipe; + {% post_plain_signal $poe_kernel->[KR_ACTIVE_SESSION], $_[0] %} + $SIG{$_[0]} = \&_poe_signal_handler_pipe; } else { warn "POE::Kernel::_signal_handler_pipe detected an undefined signal"; } } -# This is Event's pipe handler. It's probably not valid, since Event -# delays signals even longer than operating systems do. Pipe signals -# should be depreciated in favor of EPIPE anyway. -sub _event_signal_handler_pipe { - my $event = shift; - $poe_kernel->_enqueue_state( $poe_kernel->[KR_ACTIVE_SESSION], $poe_kernel, - EN_SIGNAL, ET_SIGNAL, - [ $event->w->signal ], - time(), __FILE__, __LINE__ - ); -} - # SIGCH?LD are normalized to SIGCHLD and include the child process' # PID and return code. -sub _signal_handler_child { +sub _poe_signal_handler_child { if (defined $_[0]) { # Reap until there are no more children. - - while ( ( my $pid = waitpid(-1, WNOHANG) ) >= 0 ) { - - # Determine if the child process is really exiting and not just - # stopping for some other reason. This is per Perl Cookbook - # recipe 16.19. - if (WIFEXITED($?)) { - $poe_kernel->_enqueue_state( $poe_kernel, $poe_kernel, - EN_SIGNAL, ET_SIGNAL, - [ 'CHLD', $pid, $? ], - time(), __FILE__, __LINE__ - ); - } + while ( ( my $pid = waitpid(-1, WNOHANG) ) > 0 ) { + {% post_child_signal $poe_kernel, $pid, $? %} } - $SIG{$_[0]} = \&_signal_handler_child; + $SIG{$_[0]} = \&_poe_signal_handler_child; } else { warn "POE::Kernel::_signal_handler_child detected an undefined signal"; } } -# Event's SIGCH?LD handler. +### Event's signal handlers. + +sub _event_signal_handler_generic { + {% post_plain_signal $poe_kernel, $_[0]->w->signal %} +} + +sub _event_signal_handler_pipe { + {% post_plain_signal $poe_kernel->[KR_ACTIVE_SESSION], $_[0]->w->signal %} +} + sub _event_signal_handler_child { my $event = shift; - # Reap until there are no more children. + # Reap until there are no more children. This uses one of Event's + # own scripts for an example. I only mention it because I'm scared + # of wait(2). for (my $reap=0; $reap < $event->count; $reap++) { my $pid = wait; last if $pid < 0; - - # Determine if the child process is really exiting and not just - # stopping for some other reason. This is per Perl Cookbook - # recipe 16.19. - if (WIFEXITED($?)) { - $poe_kernel->_enqueue_state( $poe_kernel, $poe_kernel, - EN_SIGNAL, ET_SIGNAL, - [ 'CHLD', $pid, $? ], - time(), __FILE__, __LINE__ - ); - } + {% post_child_signal $poe_kernel, $pid, $? %} } } @@ -542,6 +572,7 @@ sub _event_signal_handler_child { # Register or remove signals. # Public interface for adding or removing signal handlers. + sub sig { my ($self, $signal, $state) = @_; if (defined $state) { @@ -619,16 +650,19 @@ sub new { undef, # KR_WATCHER_IDLE ], $type; + # If POE uses Event to drive its queues, then one-time initialize + # watchers for idle and timed events. + if ( POE_HAS_EVENT ) { $self->[KR_WATCHER_TIMER] = Event->timer - ( cb => \&event_alarm_callback, + ( cb => \&_event_alarm_callback, after => 0, parked => 1, ); $self->[KR_WATCHER_IDLE ] = Event->idle - ( cb => \&event_fifo_callback, + ( cb => \&_event_fifo_callback, repeat => 1, min => 0, max => 0, @@ -642,6 +676,7 @@ sub new { $self->[KR_ID] = ( (uname)[1] . '-' . unpack 'H*', pack 'N*', time, $$ ); + $self->[KR_SESSION_IDS]->{$self->[KR_ID]} = $self; # Initialize the vectors as vectors. vec($self->[KR_VECTORS]->[VEC_RD], 0, 1) = 0; @@ -712,7 +747,7 @@ sub new { # Otherwise register a regular Perl signal handler. else { - $SIG{$signal} = \&_signal_handler_child; + $SIG{$signal} = \&_poe_signal_handler_child; } } } @@ -727,7 +762,7 @@ sub new { # Otherwise register a plain Perl signal handler. else { - $SIG{$signal} = \&_signal_handler_pipe; + $SIG{$signal} = \&_poe_signal_handler_pipe; } } else { @@ -743,7 +778,7 @@ sub new { # Otherwise register a plain signal handler. else { - $SIG{$signal} = \&_signal_handler_generic; + $SIG{$signal} = \&_poe_signal_handler_generic; } } @@ -1445,22 +1480,10 @@ sub run { # of code from POE::Kernel::run(). Make this function's guts a macro # later, and use it in both places. -sub tk_fifo_callback { +sub _tk_fifo_callback { my $self = $poe_kernel; - if ( @{ $self->[KR_STATES] } ) { - - # Pull an event off the queue. - - my $event = shift @{ $self->[KR_STATES] }; - {% ses_refcount_dec2 $event->[ST_SESSION], SS_EVCOUNT %} - - # Dispatch it, and see if that was the last thing the session - # needed to do. - - $self->_dispatch_state(@$event); - {% collect_garbage $event->[ST_SESSION] %} - } + {% dispatch_one_from_fifo %} # Perpetuate the dispatch loop as long as there are states enqueued. @@ -1480,41 +1503,25 @@ sub tk_fifo_callback { ( 0, sub { $self->[KR_WATCHER_IDLE] = - $poe_tk_main_window->afterIdle( \&tk_fifo_callback ) + $poe_tk_main_window->afterIdle( \&_tk_fifo_callback ) unless defined $self->[KR_WATCHER_IDLE]; } ); } # Make sure the kernel can still run. - {% test_for_idle_poe_kernel %} + else { + {% test_for_idle_poe_kernel %} + } } # Tk timer callback to dispatch alarm states. Same caveats about # macro-izing this code. -sub tk_alarm_callback { +sub _tk_alarm_callback { my $self = $poe_kernel; - # Dispatch whatever alarms are due. - - my $now = time(); - while ( @{ $self->[KR_ALARMS] } and - ($self->[KR_ALARMS]->[0]->[ST_TIME] <= $now) - ) { - - # Pull an alarm off the queue. - - my $event = shift @{ $self->[KR_ALARMS] }; - {% ses_refcount_dec2 $event->[ST_SESSION], SS_ALCOUNT %} - - # Dispatch it, and see if that was the last thing the session - # needed to do. - - $self->_dispatch_state(@$event); - {% collect_garbage $event->[ST_SESSION] %} - - } + {% dispatch_due_alarms %} # Register the next timed callback if there are alarms left. @@ -1530,34 +1537,23 @@ sub tk_alarm_callback { $self->[KR_WATCHER_TIMER] = $poe_tk_main_window->after( $next_time * 1000, - \&tk_alarm_callback + \&_tk_alarm_callback ); } # Make sure the kernel can still run. - {% test_for_idle_poe_kernel %} + else { + {% test_for_idle_poe_kernel %} + } } # Tk filehandle callback to dispatch selects. -sub tk_select_callback { +sub _tk_select_callback { my $self = $poe_kernel; my ($handle, $vector) = @_; - my @selects = - values %{ $self->[KR_HANDLES]->{$handle}->[HND_SESSIONS]->[$vector] }; - - foreach my $select (@selects) { - $self->_dispatch_state - ( $select->[HSS_SESSION], $select->[HSS_SESSION], - $select->[HSS_STATE], ET_SELECT, - [ $select->[HSS_HANDLE] ], - time(), __FILE__, __LINE__, undef - ); - {% collect_garbage $select->[HSS_SESSION] %} - } - - # Make sure the kernel can still run. + {% dispatch_ready_selects %} {% test_for_idle_poe_kernel %} } @@ -1569,23 +1565,10 @@ sub tk_select_callback { # macro later, and use it here, in POE::Kernel::run() and other FIFO # callbacks. -sub event_fifo_callback { +sub _event_fifo_callback { my $self = $poe_kernel; - if ( @{ $self->[KR_STATES] } ) { - - # Pull an event off the queue. - - my $event = shift @{ $self->[KR_STATES] }; - {% ses_refcount_dec2 $event->[ST_SESSION], SS_EVCOUNT %} - - # Dispatch it, and see if that was the last thing the session - # needed to do. - - $self->_dispatch_state(@$event); - {% collect_garbage $event->[ST_SESSION] %} - - } + {% dispatch_one_from_fifo %} # Stop the idle watcher if there are no more state transitions in # the Kernel's FIFO. @@ -1601,27 +1584,10 @@ sub event_fifo_callback { # Event timer callback to dispatch alarm states. Same caveats about # macro-izing this code. -sub event_alarm_callback { +sub _event_alarm_callback { my $self = $poe_kernel; - # Dispatch whatever alarms are due. - - my $now = time(); - while ( @{ $self->[KR_ALARMS] } and - ($self->[KR_ALARMS]->[0]->[ST_TIME] <= $now) - ) { - - # Pull an alarm off the queue. - - my $event = shift @{ $self->[KR_ALARMS] }; - {% ses_refcount_dec2 $event->[ST_SESSION], SS_ALCOUNT %} - - # Dispatch it, and see if that was the last thing the session - # needed to do. - - $self->_dispatch_state(@$event); - {% collect_garbage $event->[ST_SESSION] %} - } + {% dispatch_due_alarms %} # Register the next timed callback if there are alarms left. @@ -1629,15 +1595,16 @@ sub event_alarm_callback { $self->[KR_WATCHER_TIMER]->at( $self->[KR_ALARMS]->[0]->[ST_TIME] ); $self->[KR_WATCHER_TIMER]->start(); } + + # Make sure the kernel can still run. else { - # Make sure the kernel can still run. {% test_for_idle_poe_kernel %} } } # Event filehandle callback to dispatch selects. -sub event_select_callback { +sub _event_select_callback { my $self = $poe_kernel; my $event = shift; @@ -1654,20 +1621,7 @@ sub event_select_callback { ) ); - my @selects = - values %{ $self->[KR_HANDLES]->{$handle}->[HND_SESSIONS]->[$vector] }; - - foreach my $select (@selects) { - $self->_dispatch_state - ( $select->[HSS_SESSION], $select->[HSS_SESSION], - $select->[HSS_STATE], ET_SELECT, - [ $select->[HSS_HANDLE] ], - time(), __FILE__, __LINE__, undef - ); - {% collect_garbage $select->[HSS_SESSION] %} - } - - # Make sure the kernel can still run. + {% dispatch_ready_selects %} {% test_for_idle_poe_kernel %} } @@ -1697,7 +1651,7 @@ sub _invoke_state { # Non-blocking wait for a child process. If one was reaped, # dispatch a SIGCHLD to the session who called fork. - while ( ( my $pid = waitpid(-1, WNOHANG) ) >= 0 ) { + while ( ( my $pid = waitpid(-1, WNOHANG) ) > 0 ) { # Determine if the child process is really exiting and not just # stopping for some other reason. This is perl Perl Cookbook @@ -1731,7 +1685,7 @@ sub _invoke_state { # If there still are processes waiting, post another EN_SCPOLL for # later. - if (keys %{$self->[KR_PROCESSES]}) { + if (scalar keys %{$self->[KR_PROCESSES]}) { $self->_enqueue_state( $self, $self, EN_SCPOLL, ET_SCPOLL, [], @@ -1883,15 +1837,15 @@ sub _enqueue_state { {% ses_refcount_inc2 $session, SS_EVCOUNT %} # If using Tk and the FIFO queue now has only one event, then - # register a Tk idle callback to begin the dispatch loop. + # register a Tk idle callback to resume the dispatch loop. if ( POE_HAS_TK ) { $self->[KR_WATCHER_IDLE] = - $poe_tk_main_window->afterIdle( \&tk_fifo_callback ); + $poe_tk_main_window->afterIdle( \&_tk_fifo_callback ); } # If using Event and the FIFO queue now has only one event, then - # start the Event idle watcher to begin the dispatch loop. + # start the Event idle watcher to resume the dispatch loop. if ( POE_HAS_EVENT ) { $self->[KR_WATCHER_IDLE]->again(); @@ -2012,7 +1966,7 @@ sub _enqueue_alarm { $next_time = 0 if $next_time < 0; $self->[KR_WATCHER_TIMER] = $poe_tk_main_window->after( $next_time * 1000, - \&tk_alarm_callback + \&_tk_alarm_callback ); } @@ -2303,7 +2257,7 @@ sub _internal_select { # checked a few lines up). ( ( $select_index == VEC_RD ) ? 'readable' : 'writable' ), - [ \&tk_select_callback, $handle, $select_index ], + [ \&_tk_select_callback, $handle, $select_index ], ); } @@ -2322,7 +2276,7 @@ sub _internal_select { : 'e' ) ), - cb => \&event_select_callback, + cb => \&_event_select_callback, ); } } @@ -2559,7 +2513,7 @@ sub select_resume_write { $poe_tk_main_window->fileevent ( $handle, 'writable', - [ \&tk_select_callback, $handle, VEC_WR ], + [ \&_tk_select_callback, $handle, VEC_WR ], ); } @@ -2729,9 +2683,10 @@ sub refcount_decrement { sub fork { my ($self) = @_; - # Disable the real signal handler. How to warn? - $SIG{CHLD} = 'IGNORE' if exists $SIG{CHLD}; - $SIG{CLD} = 'IGNORE' if exists $SIG{CLD}; + # Disable the real signal handler. How to warn the user this has + # occurred? + $SIG{CHLD} = 'DEFAULT' if exists $SIG{CHLD}; + $SIG{CLD} = 'DEFAULT' if exists $SIG{CLD}; my $new_pid = fork(); @@ -2758,7 +2713,7 @@ sub fork { # Went from 0 to 1 child processes; start a poll loop. This uses # a very raw, basic form of POE::Kernel::delay. - if (keys(%{$self->[KR_PROCESSES]}) == 1) { + if (scalar(keys(%{$self->[KR_PROCESSES]})) == 1) { $self->_enqueue_state( $self, $self, EN_SCPOLL, ET_SCPOLL, [], diff --git a/lib/POE/Preprocessor.pm b/lib/POE/Preprocessor.pm index 8857389be..9c86f4d47 100644 --- a/lib/POE/Preprocessor.pm +++ b/lib/POE/Preprocessor.pm @@ -169,13 +169,10 @@ sub import { else { $macro_line++; - # Unindent the macro text by one level. -><- This - # assumes the author's indenting style, two spaces, - # which is bad. - s/^\s\s//; - $macros{$macro_name}->[MAC_CODE] .= - "# line $macro_line \"macro $macro_name\"\n$_"; + "# line $macro_line \"macro $macro_name\"\n" + unless $^P; + $macros{$macro_name}->[MAC_CODE] .= $_; } # Either way, the code must not go on. @@ -187,11 +184,10 @@ sub import { # definitions in the same area. They also eliminate the # need to check for things in semantically nil lines. - # Ignore comments. - return $status if /^\s*\#/; - - # Ignore blank lines. - return $status if /^\s*$/; + # Ignore comments and blank lines. + if ( /^\s*\#/ or /^\s*$/ ) { + return $status; + } # This return works around a bug where __END__ and __DATA__ # cause perl 5.005_61 through 5.6.0 to blow up with memory @@ -249,7 +245,6 @@ sub import { $macros{$macro_name}->[MAC_CODE] = ''; $_ = "\n"; - return $status; } @@ -284,8 +279,9 @@ sub import { 1 while ($substitution =~ s/$mac_param/$use_param/g); } - $_ = $left . $substitution . $right . - "# line " . ($line_number+1) . " \"$file_name\"\n"; + $_ = $left . $substitution . $right; + $_ .= "# line " . ($line_number+1) . " \"$file_name\"\n" + unless $^P; DEBUG and warn "$_`-----\n"; } @@ -368,7 +364,8 @@ Iaijutsu and altered slightly to jive with Perl's native syntax. Constants are defined this way: - const CONSTANT_NAME 'constant value' + const CONSTANT_NAME 'constant value' + const ANOTHER_CONSTANT 23 Enumerations can begin with 0: @@ -376,7 +373,7 @@ Enumerations can begin with 0: Or some other number: - enum 10 TENTH ELEVENTH TWELVTH + enum 10 TENTH ELEVENTH TWELFTH Or continue where the previous one left off, which is necessary because an enumeration can't span lines: @@ -405,6 +402,10 @@ Substitution is done in two phases: macros first, then constants. It would be nicer (and more dangerous) if the phases looped around and around until no more substitutions occurred. +=item * + +Optimum matches aren't, but they're better than nothing. + =back =head1 AUTHOR & COPYRIGHT diff --git a/lib/POE/Session.pm b/lib/POE/Session.pm index 5f03a4a00..4073ec87a 100644 --- a/lib/POE/Session.pm +++ b/lib/POE/Session.pm @@ -1394,14 +1394,14 @@ their name/value pairs. =item postback EVENT_NAME, PARAMETER_LIST -Create an anonymous coderef that external watchers can call to post -FIFO events to the current session. +Creates an anonymous coderef which, when called, posts EVENT_NAME back +to the session. Postbacks will keep sessions alive until they're +destroyed. -The coderefs it creates will post EVENT_NAME to the session whose -postback() method was invoked. The corresponding state's -@_[ARG0..$#_] will contain the contents of PARAMETER_LIST plus -whatever parameters were passed to the coderef at the time it was -called. +The EVENT_NAME event will include two parameters. $_[ARG0] will +contain a reference to the PARAMETER_LIST passed to postback(). +$_[ARG1] will hold a reference to the parameters given to the coderef +when it's called. This example creates a Tk button that posts an "ev_counters_begin" event at a session whenever it's pressed. @@ -1412,9 +1412,12 @@ event at a session whenever it's pressed. )->pack; It can also be used to post events from Event watchers' callbacks. +This one posts back "ev_flavor" with $_[ARG0] holding [ 'vanilla' ] +and $_[ARG1] containing a reference to whatever parameters +Event->flawor gives its callback. Event->flavor - ( cb => $session->postback( 'ev_flavor' ), + ( cb => $session->postback( 'ev_flavor', 'vanilla' ), desc => 'post ev_flavor when Event->flavor occurs', ); diff --git a/lib/POE/Wheel/ReadWrite.pm b/lib/POE/Wheel/ReadWrite.pm index 96fcaeac0..dae253939 100644 --- a/lib/POE/Wheel/ReadWrite.pm +++ b/lib/POE/Wheel/ReadWrite.pm @@ -7,16 +7,16 @@ use Carp; use POE; # Offsets into $self. -sub HANDLE_INPUT () { 0 } -sub HANDLE_OUTPUT () { 1 } -sub FILTER_INPUT () { 2 } -sub FILTER_OUTPUT () { 3 } -sub DRIVER_BOTH () { 4 } -sub EVENT_INPUT () { 5 } -sub EVENT_ERROR () { 6 } -sub EVENT_FLUSHED () { 7 } -sub WATERMARK_MARK_HIGH () { 8 } -sub WATERMARK_MARK_LOW () { 9 } +sub HANDLE_INPUT () { 0 } +sub HANDLE_OUTPUT () { 1 } +sub FILTER_INPUT () { 2 } +sub FILTER_OUTPUT () { 3 } +sub DRIVER_BOTH () { 4 } +sub EVENT_INPUT () { 5 } +sub EVENT_ERROR () { 6 } +sub EVENT_FLUSHED () { 7 } +sub WATERMARK_MARK_HIGH () { 8 } +sub WATERMARK_MARK_LOW () { 9 } sub WATERMARK_EVENT_HIGH () { 10 } sub WATERMARK_EVENT_LOW () { 11 } sub WATERMARK_STATE () { 12 } diff --git a/lib/POE/Wheel/SocketFactory.pm b/lib/POE/Wheel/SocketFactory.pm index 37a03f04d..131e26e6a 100644 --- a/lib/POE/Wheel/SocketFactory.pm +++ b/lib/POE/Wheel/SocketFactory.pm @@ -39,15 +39,15 @@ sub SVROP_NOTHING () { 'nothing' } my %supported_protocol = ( DOM_UNIX, { none => SVROP_LISTENS }, - DOM_INET, { tcp => SVROP_LISTENS, - udp => SVROP_NOTHING, + DOM_INET, { tcp => SVROP_LISTENS, + udp => SVROP_NOTHING, }, ); my %default_socket_type = ( DOM_UNIX, { none => SOCK_STREAM }, - DOM_INET, { tcp => SOCK_STREAM, - udp => SOCK_DGRAM, + DOM_INET, { tcp => SOCK_STREAM, + udp => SOCK_DGRAM, }, ); diff --git a/mylib/Devel/Trace.pm b/mylib/Devel/Trace.pm new file mode 100644 index 000000000..9033c1b26 --- /dev/null +++ b/mylib/Devel/Trace.pm @@ -0,0 +1,130 @@ +# $Id$ + +# This is a `perl -d` debugger module that simply traces execution. +# It's optional, and it may not even work. + +use strict; +package Trace; # satisfies 'use' + +package DB; + +sub CALL_COUNT () { 0 } +sub SUB_NAME () { 1 } +sub SOURCE_CODE () { 2 } + +my %statistics; + +BEGIN { + unlink "$0.coverage"; + open STATS, ">$0.coverage" or die "can't write $0.coverage: $!"; +} + +sub DB { + my ($package, $file, $line) = caller; + + # Skip lines that aren't in the POE namespace. Skip lines ending + # with "]", which are evals. + return unless $file =~ /POE/ and $file !~ /\]$/; + + # Gather a statistic for this line. + $statistics{$file}->{$line} = [ 0, '(uninitialized)', '(uninitialized)' ] + unless exists $statistics{$file}->{$line}; + $statistics{$file}->{$line}->[CALL_COUNT]++; +} + +# After all's said and done, say what's done. + +END { + + # Gather breakable lines for every file visited. This is done at + # the end since doing it at the beginning means some lines aren't + # visible. + + foreach my $file (keys %statistics) { + my $sub_name = '(unknown)'; + for (my $line=1; $line<@{$::{"_<$file"}}; $line++) { + + if ($::{"_<$file"}->[$line] =~ /^sub\s+(\S+)/) { + $sub_name = $1; + } + + if (exists $statistics{$file}->{$line}) { + $statistics{$file}->{$line}->[SUB_NAME] = $sub_name; + } + else { + # Here there be magic. + local $^W = 0; + if ($::{"_<$file"}->[$line]+0) { + my $source = $::{"_<$file"}->[$line]; + chomp $source; + $statistics{$file}->{$line} = [ 0, $sub_name, $source ]; + } + } + + if ($::{"_<$file"}->[$line] =~ /^\}/) { + $sub_name = '(unknown)'; + } + } + } + + foreach my $file (sort keys %statistics) { + foreach my $line (sort keys %{$statistics{$file}}) { + print( STATS "$file\t$line\t", + $statistics{$file}->{$line}->[CALL_COUNT], "\t", + $statistics{$file}->{$line}->[SUB_NAME], "\t", + $statistics{$file}->{$line}->[SOURCE_CODE], "\n" + ); + } + } + close STATS; +} + +1; +__END__ + +END { + my $ueber_total = 0; + my $ueber_called = 0; + + printf( STATS "%-30.30s = %5s / %5s = %7s\n", + 'File', 'Ran', 'Total', 'Covered' + ); + + foreach my $file (sort keys %statistics) { + my $total = 0; + my $called = 0; + foreach my $line (values %{$statistics{$file}}) { + $total++; + $called++ if $line->[CALL_COUNT]; + } + next unless $total; + $ueber_total += $total; + $ueber_called += $called; + printf( STATS "%-30.30s = %5d / %5d = %6.2f%%\n", + $file, $called, $total, ($called / $total) * 100 + ); + } + + if ($ueber_total) { + printf( STATS "%-30.30s = %5d / %5d = %6.2f%%\n", + 'All Told', $ueber_called, $ueber_total, + ($ueber_called / $ueber_total) * 100 + ); + } + + foreach my $file (sort keys %statistics) { + print STATS "\n*** Uncalled Lines tn $file\n\n"; + foreach my $line (sort { $a <=> $b } keys %{$statistics{$file}}) { + my $call_rec = $statistics{$file}->{$line}; + next if $call_rec->[CALL_COUNT]; + my ($sub, $code) = ($call_rec->[SUB_NAME], $::{"_<$file"}->[$line]); + $code =~ s/\n+$//; + printf STATS "%5d: %-20.20s %-50.50s\n", $line, $sub, $code; + } + } + + close STATS; +} + +############################################################################### +1; diff --git a/mylib/TestSetup.pm b/mylib/TestSetup.pm index bcbf4b2e6..4e70942ed 100644 --- a/mylib/TestSetup.pm +++ b/mylib/TestSetup.pm @@ -3,14 +3,26 @@ package TestSetup; -sub import { - my $something_poorly_documented = shift; +use strict; + +use Exporter; +@TestSetup::ISA = qw(Exporter); +@TestSetup::EXPORT = qw( &test_setup + &stderr_pause &stderr_resume + &ok ¬_ok &ok_if &ok_unless &results + ); + +my $test_count; +my @test_results; + +sub test_setup { + $test_count = shift; + $ENV{PERL_DL_NONLAZY} = 0 if ($^O eq 'freebsd'); select(STDOUT); $|=1; - my $count = shift; - if ($count) { - print "1..$count\n"; + if ($test_count) { + print "1..$test_count\n"; } else { my $reason = join(' ', @_); @@ -18,6 +30,93 @@ sub import { print "1..0 # skipped: $reason\n"; exit 0; } + + for (my $test = 1; $test <= $test_count; $test++) { + $test_results[$test] = undef; + } +} + +# Opened twice to avoid a warning. +open STDERR_HOLD, '>&STDERR' or die "cannot save STDERR: $!"; +open STDERR_HOLD, '>&STDERR' or die "cannot save STDERR: $!"; + +sub stderr_pause { + close STDERR; +} + +sub stderr_resume { + open STDERR, '>&STDERR_HOLD' or print "cannot restore STDERR: $!"; +} + +sub _display_result { + my $test = shift; + if (defined $test_results[$test]) { + print $test_results[$test], "\n"; + } + else { + print "not ok $test # no test result\n"; + } +} + +sub results { + for (my $test = 1; $test < @test_results; $test++) { + &_display_result($test); + } +} + +sub ok { + my $test_number = shift; + + if (defined $test_results[$test_number]) { + $test_results[$test_number] = "not ok $test_number # duplicate outcome"; + } + elsif ($test_number > $test_count) { + $test_results[$test_number] = "not ok $test_number # above $test_count"; + } + else { + $test_results[$test_number] = "ok $test_number"; + } +} + +sub not_ok { + my ($test_number, $reason) = @_; + + if (defined $test_results[$test_number]) { + $test_results[$test_number] = "not ok $test_number # duplicate outcome"; + } + elsif ($test_number > $test_count) { + $test_results[$test_number] = "not ok $test_number # above $test_count"; + } + else { + $test_results[$test_number] = "not ok $test_number" . + ( (defined $reason and length $reason) + ? " # $reason" + : '' + ); + } +} + +sub ok_if { + my ($test_number, $value, $reason) = @_; + + if ($value) { + &ok($test_number); + } + else { + ¬_ok($test_number, $reason); + } +} + +sub ok_unless { + my ($test_number, $value, $reason) = @_; + + unless ($value) { + &ok($test_number); + } + else { + ¬_ok($test_number, $reason); + } } 1; + diff --git a/mylib/coverage.perl b/mylib/coverage.perl new file mode 100644 index 000000000..77db6f679 --- /dev/null +++ b/mylib/coverage.perl @@ -0,0 +1,147 @@ +#!/usr/bin/perl -w +# $Id$ + +# Runs t/*.t with the custom Devel::Trace to check for source +# coverage. + +use strict; +use lib qw( . .. ../lib ); + +my %statistics; +sub CALL_COUNT () { 0 } +sub SUB_NAME () { 1 } +sub SOURCE_CODE () { 2 } + +# Find the tests. + +my $test_directory = + ( (-d './t') + ? './t' + : ( (-d '../t') + ? '../t' + : die "can't find the test directory at ./t or ../t" + ) + ); + +opendir T, $test_directory or die "can't open directory $test_directory: $!"; +my @test_files = map { $test_directory . '/' . $_ } grep /\.t$/, readdir T; +closedir T; + +# Run each test with coverage statistics. + +foreach my $test_file (@test_files) { + unlink "$test_file.coverage"; + + # System returns 0 on success. + my $result = system '/usr/bin/perl', '-Ilib', '-I..', '-d:Trace', $test_file; + if ($result) { + warn "can't profile $test_file: ($result) $!"; + next; + } +} + +# Combine coverage statistics across all files. + +foreach my $test_file (@test_files) { + my $results_file = $test_file . '.coverage'; + + unless (-f $results_file) { + warn "can't find expected file: $results_file"; + next; + } + + unless (open R, "<$results_file") { + warn "couldn't open $results_file for reading: $!"; + next; + } + + while () { + chomp; + my ($file, $line, $count, $sub, $source) = split /\t/; + + if (exists $statistics{$file}->{$line}) { + $statistics{$file}->{$line}->[CALL_COUNT] += $count; + if ($statistics{$file}->{$line}->[SOURCE_CODE] ne $source) { + $statistics{$file}->{$line}->[SOURCE_CODE] = '(varies)'; + } + } + else { + $statistics{$file}->{$line} = [ $count, $sub, $source ]; + } + } + + close R; + + # unlink $results_file; +} + +# Summary first. + +open REPORT, '>coverage.report' or die "can't open coverage.report: $!"; + +print REPORT "***\n*** Coverage Summary\n***\n\n"; + +printf( REPORT + "%-35.35s = %5s / %5s = %7s\n", + 'Source File', 'Ran', 'Total', 'Covered' + ); + +my $ueber_total = 0; +my $ueber_called = 0; +foreach my $file (sort keys %statistics) { + my $file_total = 0; + my $file_called = 0; + my $lines = $statistics{$file}; + my @uncalled; + + foreach my $line (sort { $a <=> $b } keys %$lines) { + $file_total++; + if ($lines->{$line}->[CALL_COUNT]) { + $file_called++; + } + else { + push @uncalled, $line; + } + } + + $ueber_total += $file_total; + $ueber_called += $file_called; + + # Division by 0 is generally frowned upon. + $file_total = 1 unless $file_total; + + printf( REPORT + "%-35.35s = %5d / %5d = %6.2f%%\n", + $file, $file_called, $file_total, ($file_called / $file_total) * 100 + ); +} + +# Division by 0 is generally frowned upon. +$ueber_total = 1 unless $ueber_total; + +printf( REPORT + "%-35.35s = %5d / %5d = %6.2f%%\n", 'All Told', + $ueber_called, $ueber_total, ($ueber_called / $ueber_total) * 100 + ); + +# Now detail. + +foreach my $file (sort keys %statistics) { + my $lines = $statistics{$file}; + my $this_sub = ''; + foreach my $line (sort { $a <=> $b } keys %$lines) { + unless ($lines->{$line}->[CALL_COUNT]) { + if ($this_sub ne $lines->{$line}->[SUB_NAME]) { + $this_sub = $lines->{$line}->[SUB_NAME]; + print REPORT "\n*** Uninstrumented lines in $file sub $this_sub:\n\n"; + } + printf REPORT "%5d : %-70.70s\n", $line, $lines->{$line}->[SOURCE_CODE]; + } + } +} + +close REPORT; + +print "\nA coverage report has been written to coverage.report.\n"; + +exit; diff --git a/tests/00_coverage.t b/tests/00_coverage.t new file mode 100644 index 000000000..fddb64626 --- /dev/null +++ b/tests/00_coverage.t @@ -0,0 +1,59 @@ +#!/usr/bin/perl -w +# $Id$ + +# This test merely loads as many modules as possible so that the +# coverage tester will see them. It's performs a similar function as +# the FreeBSD LINT kernel configuration. + +use strict; +use lib qw(./lib ../lib); +use TestSetup; +&test_setup(11); + +sub load_optional_module { + my ($test_number, $module) = @_; + eval "use $module"; + my $reason = $@; + $reason =~ s/[\x0a\x0d]+/ \/ /g; + $reason =~ tr[ ][ ]s; + print( "ok $test_number", + ( (length $reason) ? " # skipped: $reason" : '' ), + "\n" + ); +} + +sub load_required_module { + my ($test_number, $module) = @_; + eval "use $module"; + my $reason = $@; + $reason =~ s/[\x0a\x0d]+/ \/ /g; + $reason =~ tr[ ][ ]s; + if (length $reason) { + print "not ok $test_number # $reason\n"; + } + else { + print "ok $test_number\n"; + } +} + +# Required modules first. + +&load_required_module( 1, 'POE'); # includes POE::Kernel and POE::Session +&load_required_module( 2, 'POE::Filter::Line'); +&load_required_module( 3, 'POE::Filter::Stream'); +&load_required_module( 4, 'POE::Wheel::ReadWrite'); +&load_required_module( 5, 'POE::Wheel::SocketFactory'); + +# Optional modules now. + +&load_optional_module( 6, 'POE::Component::Server::TCP'); +&load_optional_module( 7, 'POE::Filter::HTTPD'); +&load_optional_module( 8, 'POE::Filter::Reference'); +&load_optional_module( 9, 'POE::Wheel::FollowTail'); +&load_optional_module(10, 'POE::Wheel::ListenAccept'); + +# And one to grow on. + +print "ok 11\n"; + +exit; diff --git a/tests/01_sessions.t b/tests/01_sessions.t index 5da6f96a5..a6329e36c 100644 --- a/tests/01_sessions.t +++ b/tests/01_sessions.t @@ -5,17 +5,18 @@ use strict; use lib qw(./lib ../lib); -use TestSetup qw(13); +use TestSetup; +&test_setup(15); # Turn on all asserts. sub POE::Kernel::ASSERT_DEFAULT () { 1 } - use POE; ### Test parameters. -my $machine_count = 10; -my $event_count = 10; +my $machine_count = 10; +my $event_count = 10; +my $signals_caught = 0; ### Status registers for each state machine instance. @@ -24,8 +25,9 @@ my @completions; ### Define a simple state machine. sub task_start { - my ($kernel, $heap, $id) = @_[KERNEL, HEAP, ARG0]; + my ($kernel, $session, $heap, $id) = @_[KERNEL, SESSION, HEAP, ARG0]; $heap->{count} = 0; + $kernel->yield( count => $id ); } @@ -60,6 +62,39 @@ sub task_stop { print "ok 1\n"; +# Spawn a quick state machine to test signals. This is a classic +# example of inline states being just that: inline anonymous coderefs. +# It makes quick hacks quicker! +POE::Session->create + ( inline_states => + { _start => + sub { + $_[HEAP]->{kills_to_go} = $event_count; + $_[KERNEL]->sig( USR1 => 'sigusr1_target' ); + $_[KERNEL]->delay( fire_sigusr1 => 0.5 ); + }, + _stop => + sub { + }, + fire_sigusr1 => + sub { + if ($_[HEAP]->{kills_to_go}--) { + $_[KERNEL]->delay( fire_sigusr1 => 0.5 ); + kill 'USR1', $$; + } + # One last timer so the session lingers long enough to catch + # the final signal. + else { + $_[KERNEL]->delay( nonexistent_state => 0.5 ); + } + }, + sigusr1_target => + sub { + $signals_caught++ if $_[ARG0] eq 'USR1'; + }, + } + ); + # Spawn ten state machines. for (my $i=0; $i<$machine_count; $i++) { @@ -90,6 +125,51 @@ for (my $i=0; $i<$machine_count; $i++) { print "ok 2\n"; +# A simple service session. It returns an ever increasing count. + +POE::Session->create + ( inline_states => + { _start => + sub { + $_[KERNEL]->alias_set( 'server' ); + $_[HEAP]->{response} = 0; + }, + query => + sub { + $_[ARG0]->( ++$_[HEAP]->{response} ); + }, + }, + ); + +# A simple client session. It requests five counts and then stops. +# Its magic is that it passes a postback for the response. + +my $postback_test = 1; + +POE::Session->create + ( inline_states => + { _start => + sub { + $_[KERNEL]->yield( 'query' ); + $_[HEAP]->{cookie} = 0; + }, + query => + sub { + $_[KERNEL]->post( server => + query => + $_[SESSION]->postback( response => + ++$_[HEAP]->{cookie} + ) + ); + }, + response => + sub { + $postback_test = 0 if $_[ARG0]->[0] != $_[ARG1]->[0]; + $_[KERNEL]->yield( 'query' ) if $_[HEAP]->{cookie} < 5; + }, + } + ); + # Now run them 'til they complete. $poe_kernel->run(); @@ -99,6 +179,14 @@ for (my $i=0; $i<$machine_count; $i++) { print 'ok ', $i+3, "\n"; } +# Were all the signals caught? +print 'not ' unless $signals_caught == $event_count; print "ok 13\n"; +# Did the postbacks work? +print 'not ' unless $postback_test; +print "ok 14\n"; + +print "ok 15\n"; + exit; diff --git a/tests/02_alarms.t b/tests/02_alarms.t index 2992682a3..349566a31 100644 --- a/tests/02_alarms.t +++ b/tests/02_alarms.t @@ -5,11 +5,12 @@ use strict; use lib qw(./lib ../lib); -use TestSetup qw(13); +use TestSetup; + +&test_setup(14); # Turn on all asserts. sub POE::Kernel::ASSERT_DEFAULT () { 1 } - use POE; ### Test parameters. @@ -21,6 +22,7 @@ my $event_count = 10; my @status; + ### Define a simple state machine. sub test_start { @@ -53,7 +55,6 @@ sub test_start { $kernel->alarm( path_five => time() + 2, 5.1 ); $kernel->alarm( 'path_five' ); - # Path #6: single delay; make sure it rings. $heap->{test}->{path_six} = 0; $kernel->delay( path_six => 2, 6.1 ); @@ -81,9 +82,60 @@ sub test_start { $kernel->delay( path_ten => 2, 10.1 ); $kernel->alarm( 'path_ten' ); - # And a final test: Since the alarms are being waited for in - # parallel, the program should take close to 2 seconds to run. Mark - # the start time for this test. + # Path #11: ensure alarms are enqueued in time order. + + # Fill the alarm queue to engage the "big queue" binary insert. + my @eleven_fill; + for (my $count=0; $count<100; $count++) { + push @eleven_fill, int(rand(100)); + $kernel->alarm( "path_eleven_fill_$count", $eleven_fill[-1] ); + } + + # Now to really test the insertion code. + $kernel->alarm( path_eleven_100 => 100 ); + $kernel->alarm( path_eleven_200 => 200 ); + $kernel->alarm( path_eleven_300 => 300 ); + + $kernel->alarm( path_eleven_050 => 50 ); + $kernel->alarm( path_eleven_150 => 150 ); + $kernel->alarm( path_eleven_250 => 250 ); + $kernel->alarm( path_eleven_350 => 350 ); + + $kernel->alarm( path_eleven_075 => 75 ); + $kernel->alarm( path_eleven_175 => 175 ); + $kernel->alarm( path_eleven_275 => 275 ); + + $kernel->alarm( path_eleven_325 => 325 ); + $kernel->alarm( path_eleven_225 => 225 ); + $kernel->alarm( path_eleven_125 => 125 ); + + # To test duplicates. + $kernel->alarm( path_eleven_201 => 200 ); + $kernel->alarm( path_eleven_202 => 200 ); + $kernel->alarm( path_eleven_203 => 200 ); + + # Now clear the filler states. + for (my $count=0; $count<100; $count++) { + if ($count & 1) { + $kernel->alarm( "path_eleven_fill_$count" ); + } + else { + $kernel->alarm( "path_eleven_fill_$count" ); + } + } + + # Now acquire the test alarms. + my @alarms_eleven = grep /^path_eleven_\d+$/, $kernel->queue_peek_alarms(); + $heap->{alarms_eleven} = \@alarms_eleven; + + # Now clear the test alarms since we're just testing the queue + # order. + foreach (@alarms_eleven) { + $kernel->alarm( $_ ); + } + + # All the paths are occurring in parallel so they should complete in + # about 2 seconds. Start a timer to make sure. $heap->{start_time} = time(); } @@ -121,8 +173,29 @@ sub test_stop { print "ok 11\n"; # Here's where we check the overall run time. - print 'not' if (time() - $heap->{start_time} > 3); + print 'not ' if (time() - $heap->{start_time} > 3); print "ok 12\n"; + + # And test alarm order. + print 'not ' + unless ( $heap->{alarms_eleven}->[ 0] eq 'path_eleven_050' and + $heap->{alarms_eleven}->[ 1] eq 'path_eleven_075' and + $heap->{alarms_eleven}->[ 2] eq 'path_eleven_100' and + $heap->{alarms_eleven}->[ 3] eq 'path_eleven_125' and + $heap->{alarms_eleven}->[ 4] eq 'path_eleven_150' and + $heap->{alarms_eleven}->[ 5] eq 'path_eleven_175' and + $heap->{alarms_eleven}->[ 6] eq 'path_eleven_200' and + $heap->{alarms_eleven}->[ 7] eq 'path_eleven_201' and + $heap->{alarms_eleven}->[ 8] eq 'path_eleven_202' and + $heap->{alarms_eleven}->[ 9] eq 'path_eleven_203' and + $heap->{alarms_eleven}->[10] eq 'path_eleven_225' and + $heap->{alarms_eleven}->[11] eq 'path_eleven_250' and + $heap->{alarms_eleven}->[12] eq 'path_eleven_275' and + $heap->{alarms_eleven}->[13] eq 'path_eleven_300' and + $heap->{alarms_eleven}->[14] eq 'path_eleven_325' and + $heap->{alarms_eleven}->[15] eq 'path_eleven_350' + ); + print "ok 13\n"; } sub test_path_one { @@ -265,6 +338,6 @@ $poe_kernel->run(); # Now make sure they've run. -print "ok 13\n"; +print "ok 14\n"; exit; diff --git a/tests/03_aliases.t b/tests/03_aliases.t index 6eb26a7ce..5b3f2df64 100644 --- a/tests/03_aliases.t +++ b/tests/03_aliases.t @@ -5,7 +5,10 @@ use strict; use lib qw(./lib ../lib); -use TestSetup qw(10); +use TestSetup; +&test_setup(18); + +use POSIX qw (:errno_h); # Turn on all asserts. sub POE::Kernel::ASSERT_DEFAULT () { 1 } @@ -21,32 +24,51 @@ sub machine_start { $heap->{idle_count} = $heap->{zombie_count} = 0; # Set an alias. - $kernel->alias_set( 'new name' ); + print "not " if $kernel->alias_set( 'new name' ); + print "ok 2\n"; + + # Set it again. + print "not " if $kernel->alias_set( 'new name' ); + print "ok 3\n"; # Resolve weak, stringified session reference. $resolved_session = $kernel->alias_resolve( "$session" ); print "not " unless $resolved_session eq $session; - print "ok 2\n"; + print "ok 4\n"; # Resolve against session ID. $resolved_session = $kernel->alias_resolve( $session->ID ); print "not " unless $resolved_session eq $session; - print "ok 3\n"; + print "ok 5\n"; # Resolve against alias. $resolved_session = $kernel->alias_resolve( 'new name' ); print "not " unless $resolved_session eq $session; - print "ok 4\n"; + print "ok 6\n"; # Resolve against blessed session reference. $resolved_session = $kernel->alias_resolve( $session ); print "not " unless $resolved_session eq $session; - print "ok 5\n"; + print "ok 7\n"; # Resolve against something that doesn't exist. $resolved_session = $kernel->alias_resolve( 'nonexistent' ); print "not " if defined $resolved_session; - print "ok 6\n"; + print "ok 8\n"; + + # Resolve IDs to and from Sessions. + my $id = $session->ID; + print "not " unless $kernel->ID_id_to_session($id) == $session; + print "ok 9\n"; + + print "not " unless $kernel->ID_session_to_id($session) == $id; + print "ok 10\n"; + + print "not " unless $kernel->ID_id_to_session($kernel->ID) == $kernel; + print "ok 11\n"; + + print "not " unless $kernel->ID_session_to_id($kernel) eq $kernel->ID; + print "ok 12\n"; } # Catch SIGIDLE and SIGZOMBIE. @@ -74,10 +96,10 @@ sub machine_stop { my $heap = $_[HEAP]; print "not " unless $heap->{idle_count} == 1; - print "ok 8\n"; + print "ok 16\n"; print "not " unless $heap->{zombie_count} == 1; - print "ok 9\n"; + print "ok 17\n"; } ### Main loop. @@ -88,18 +110,41 @@ print "ok 1\n"; POE::Session->create ( inline_states => - { _start => \&machine_start, + { _start => \&machine_start, _signal => \&machine_signal, - _stop => \&machine_stop + _stop => \&machine_stop }, ); -print "ok 7\n"; +# Spawn a second machine to test for alias removal. + +print "ok 13\n"; + +my $sigidle_test = 1; +my $sigzombie_test = 1; + +POE::Session->create + ( inline_states => + { _start => + sub { + $_[KERNEL]->alias_set( 'a_sample_alias' ); + print "not " if $_[KERNEL]->alias_remove( 'a_sample_alias' ); + print "ok 14\n"; + }, + _signal => + sub { + $sigidle_test = 0 if $_[0] eq 'IDLE'; + $sigzombie_test = 0 if $_[0] eq 'ZOMBIE'; + }, + } + ); + +print "ok 15\n"; # Now run the kernel until there's nothing left to do. $poe_kernel->run(); -print "ok 10\n"; +print "ok 18\n"; exit; diff --git a/tests/04_selects.t b/tests/04_selects.t index ee426ed35..0c836f33d 100644 --- a/tests/04_selects.t +++ b/tests/04_selects.t @@ -5,12 +5,13 @@ use strict; use lib qw(./lib ../lib); -use TestSetup qw(23); +use TestSetup; +&test_setup(23); # Turn on all asserts. sub POE::Kernel::ASSERT_DEFAULT () { 1 } - use POE; + use Socket; use Symbol qw(gensym); diff --git a/tests/05_macros.t b/tests/05_macros.t index d3ab53150..d2cd30b60 100644 --- a/tests/05_macros.t +++ b/tests/05_macros.t @@ -5,7 +5,9 @@ use strict; use lib qw(./lib ../lib); -use TestSetup qw(13); +use TestSetup; +&test_setup(13); + use POE::Preprocessor; # Did we get this far? diff --git a/tests/06_tk.t b/tests/06_tk.t index ed280ebf7..f04f7b70c 100644 --- a/tests/06_tk.t +++ b/tests/06_tk.t @@ -9,10 +9,11 @@ use lib qw(./lib ../lib); use lib '/usr/mysrc/Tk800.021/blib'; use lib '/usr/mysrc/Tk800.021/blib/lib'; use lib '/usr/mysrc/Tk800.021/blib/arch'; + use Symbol; -# Turn on all asserts. -sub POE::Kernel::ASSERT_DEFAULT () { 1 } +use TestSetup; +&test_setup(5); # Skip if Tk isn't here. BEGIN { @@ -20,15 +21,16 @@ BEGIN { defined $ENV{'DISPLAY'} and length $ENV{'DISPLAY'} ) { - eval 'use TestSetup qw(0 no DISPLAY is set)'; + &test_setup(0, 'no DISPLAY is set'); } eval 'use Tk'; unless (exists $INC{'Tk.pm'}) { - eval 'use TestSetup qw(0 the Tk module is not installed)'; + &test_setup(0, 'the Tk module is not installed'); } } -use TestSetup qw(5); +# Turn on all asserts. +sub POE::Kernel::ASSERT_DEFAULT () { 1 } use POE qw(Wheel::ReadWrite Filter::Line Driver::SysRW); # Congratulate ourselves for getting this far. diff --git a/tests/07_event.t b/tests/07_event.t index f2fced9e0..2e40b50e8 100644 --- a/tests/07_event.t +++ b/tests/07_event.t @@ -8,18 +8,20 @@ use strict; use lib qw(./lib ../lib); use Symbol; -# Turn on all asserts. -sub POE::Kernel::ASSERT_DEFAULT () { 1 } +use TestSetup; # Skip if Event isn't here. BEGIN { eval 'use Event'; unless (exists $INC{'Event.pm'}) { - eval 'use TestSetup qw(0 the Event module is not installed)'; + &test_setup(0, 'the Event module is not installed'); } } -use TestSetup qw(5); +&test_setup(6); + +# Turn on all asserts. +sub POE::Kernel::ASSERT_DEFAULT () { 1 } use POE qw(Wheel::ReadWrite Filter::Line Driver::SysRW); # Congratulate ourselves for getting this far. @@ -72,6 +74,11 @@ sub io_start { $heap->{idle_count} = 0; $kernel->yield( 'ev_idle_increment' ); + # And a signal count. + + $heap->{signal_count} = 0; + $kernel->sig( USR1 => 'ev_sig_usr1' ); + # And an independent timer loop to test it separately from pipe # writer's. @@ -100,9 +107,20 @@ sub io_idle_increment { } sub io_timer_increment { + kill 'USR1', $$; if (++$_[HEAP]->{timer_count} < 10) { $_[KERNEL]->delay( ev_timer_increment => 0.5 ); } + + # One last timer, going nowhere, to keep the session alive long + # enough to catch the last signal. + else { + $_[KERNEL]->delay( nonexistent_state => 0.5 ); + } +} + +sub io_sig_usr1 { + $_[HEAP]->{signal_count}++ if $_[ARG0] eq 'USR1'; } sub io_stop { @@ -118,6 +136,12 @@ sub io_stop { print "not " unless $heap->{timer_count}; print "ok 4\n"; + + print "not " unless $heap->{signal_count} == $heap->{timer_count}; + print "ok 5\n"; + + # Remove the signal, just to make sure that code runs. + $_[KERNEL]->sig( 'USR1' ); } # Start the I/O session. @@ -130,6 +154,7 @@ POE::Session->create ev_pipe_write => \&io_pipe_write, ev_idle_increment => \&io_idle_increment, ev_timer_increment => \&io_timer_increment, + ev_sig_usr1 => \&io_sig_usr1, }, ); @@ -139,6 +164,6 @@ $poe_kernel->run(); # Congratulate ourselves on a job completed, regardless of how well it # was done. -print "ok 5\n"; +print "ok 6\n"; exit; diff --git a/tests/08_errors.t b/tests/08_errors.t new file mode 100644 index 000000000..9402e9787 --- /dev/null +++ b/tests/08_errors.t @@ -0,0 +1,153 @@ +#!/usr/bin/perl -w +# $Id$ + +# Tests error conditions. This has to be a separate test since it +# depends on ASSERT_DEFAULT being 0. All the other tests enable it. + +use strict; +use lib qw(./lib ../lib); +use TestSetup; +&test_setup(18); + +use POSIX qw(:errno_h); +use Socket; +use POE qw( Component::Server::TCP Wheel::SocketFactory ); + +# Test that errors occur when nonexistent modules are used. +stderr_pause(); +eval 'use POE qw(NonExistent);'; +stderr_resume(); +print "not " unless defined $@ and length $@; +print "ok 1\n"; + +# Test that an error occurs when trying to instantiate POE directly. +stderr_pause(); +eval 'my $x = new POE;'; +stderr_resume(); +print "not " unless defined $@ and length $@; +print "ok 2\n"; + +### Test state machine. + +sub test_start { + my ($kernel, $session, $heap) = @_[KERNEL, SESSION, HEAP]; + + ### Aliases. + + # Test error handling for the Kernel's call() method. + $! = 0; + print "not " + if (defined $kernel->call( 1000 => 'nonexistent' ) or $! != ESRCH); + print "ok 5\n"; + + # Test error handling for the Kernel's post() method. + $! = 0; + print "not " + if (defined $kernel->post( 1000 => 'nonexistent' ) or $! != ESRCH); + print "ok 6\n"; + + # Failed alias addition. + print "not " if $kernel->alias_set( 'kernel_alias' ) != EEXIST; + print "ok 7\n"; + + # Failed alias removal. Not allowed to remove one from another + # session. + print "not " if $kernel->alias_remove( 'kernel_alias' ) != EPERM; + print "ok 8\n"; + + # Failed alias removal. Not allowed to remove one that doesn't + # exist. + print "not " if $kernel->alias_remove( 'yatta yatta yatta' ) != ESRCH; + print "ok 9\n"; + + ### IDs + + # Test failed ID->session and session->ID lookups. + $! = 0; + print "not " if defined $kernel->ID_id_to_session( 1000 ) or $! != ESRCH; + print "ok 10\n"; + + print "not " if defined $kernel->ID_session_to_id( 1000 ) or $! != ESRCH; + print "ok 11\n"; + + ### Signals. + + # Test failed signal() call. + $! = 0; + print "not " if defined $kernel->signal( 1000 => 'BOOGA' ) or $! != ESRCH; + print "ok 12\n"; +} + +# Did we get this far? + +print "ok 3\n"; + +print "not " if $poe_kernel->alias_set( 'kernel_alias' ); +print "ok 4\n"; + +POE::Session->create + ( inline_states => + { _start => \&test_start, + } + ); + +print "not " if $poe_kernel->alias_remove( 'kernel_alias' ); +print "ok 13\n"; + +print "not " unless $poe_kernel->state( woobly => sub { die } ) == ESRCH; +print "ok 14\n"; + +### TCP Server problems. + +{ my $warnings = 0; + local $SIG{__WARN__} = sub { $warnings++; }; + + stderr_pause(); + POE::Component::Server::TCP->new + ( Port => -1, + Acceptor => sub { die }, + Nonexistent => 'woobly', + ); + stderr_resume(); + + print "not " unless $warnings == 1; + print "ok 15\n"; +} + +### SocketFactory problems. + +{ my $warnings = 0; + local $SIG{__WARN__} = sub { $warnings++; }; + + stderr_pause(); + POE::Wheel::SocketFactory->new + ( SuccessState => [ ], + FailureState => [ ], + ); + stderr_resume(); + + print "not " unless $warnings == 2; + print "ok 16\n"; + + stderr_pause(); + POE::Wheel::SocketFactory->new + ( SocketDomain => AF_UNIX, + SocketProtocol => 'tcp', + SuccessState => 'okay', + FailureState => 'okay', + ); + stderr_resume(); + + print "not " unless $warnings == 3; + print "ok 17\n"; +} + +### Main loop. + +stderr_pause(); +$poe_kernel->run(); +stderr_resume(); + +print "ok 18\n"; + +exit; diff --git a/tests/09_wheels_unix.t b/tests/09_wheels_unix.t new file mode 100644 index 000000000..a3708df89 --- /dev/null +++ b/tests/09_wheels_unix.t @@ -0,0 +1,231 @@ +#!/usr/bin/perl -w +# $Id$ + +# Exercises the wheels commonly used with UNIX domain sockets. + +use strict; +use lib qw(./lib ../lib); +use TestSetup; +use Socket; + +use POE qw( Wheel::SocketFactory + Wheel::ReadWrite + Filter::Line Filter::Stream + Driver::SysRW + ); + +my $unix_server_socket = '/tmp/poe-usrv'; + +# Congratulations! We made it this far! +&test_setup(15); +&ok(1); + +############################################################################### +# A generic server session. + +sub sss_new { + my ($socket, $peer_addr, $peer_port) = @_; + POE::Session->create + ( inline_states => + { _start => \&sss_start, + _stop => \&sss_stop, + got_line => \&sss_line, + got_error => \&sss_error, + got_flush => \&sss_flush, + }, + args => [ $socket, $peer_addr, $peer_port ], + ); +} + +sub sss_start { + my ($heap, $socket, $peer_addr, $peer_port) = @_[HEAP, ARG0..ARG2]; + + delete $heap->{wheel}; + $heap->{wheel} = POE::Wheel::ReadWrite->new + ( Handle => $socket, + Driver => POE::Driver::SysRW->new(), + Filter => POE::Filter::Line->new(), + InputState => 'got_line', + ErrorState => 'got_error', + FlushedState => 'got_flush', + BlockSize => 1, + ); + + &ok_if(6, defined $heap->{wheel}); + + $heap->{flush_count} = 0; + $heap->{put_count} = 0; +} + +sub sss_line { + my ($heap, $line) = @_[HEAP, ARG0]; + + $line =~ tr/a-zA-Z/n-za-mN-ZA-M/; # rot13 + + $heap->{wheel}->put($line); + $heap->{put_count}++; +} + +sub sss_error { + my ($operation, $errnum, $errstr) = @_[ARG0..ARG2]; + + &ok_unless(8, $errnum); + + delete $_[HEAP]->{wheel}; +} + +sub sss_flush { + $_[HEAP]->{flush_count}++; +} + +sub sss_stop { + &ok_if (10, $_[HEAP]->{put_count} == $_[HEAP]->{flush_count}); +} + +############################################################################### +# A UNIX domain socket server. + +sub server_unix_start { + my $heap = $_[HEAP]; + + unlink $unix_server_socket if -e $unix_server_socket; + + $heap->{wheel} = POE::Wheel::SocketFactory->new + ( SocketDomain => AF_UNIX, + BindAddress => $unix_server_socket, + SuccessState => 'got_client', + FailureState => 'got_error', + ); + + $_[HEAP]->{client_count} = 0; + + &ok_if(2, defined $heap->{wheel}); +} + +sub server_unix_stop { + delete $_[HEAP]->{wheel}; + + &ok_if(11, $_[HEAP]->{client_count} == 1); + + unlink $unix_server_socket if -e $unix_server_socket; +} + +sub server_unix_answered { + &ok(5); + $_[HEAP]->{client_count}++; + &sss_new(@_[ARG0..ARG2]); +} + +sub server_unix_error { + warn $_[SESSION]->ID; + # catch failed creates +} + +# This arrives with 'lose' when a server session has closed. +sub server_unix_child { + if ($_[ARG0] eq 'create') { + $_[HEAP]->{child} = $_[ARG1]; + } + if ($_[ARG0] eq 'lose') { + delete $_[HEAP]->{wheel}; + &ok_if(9, $_[ARG1] == $_[HEAP]->{child}); + } +} + +############################################################################### +# A UNIX domain socket client. + +sub client_unix_start { + my $heap = $_[HEAP]; + + $heap->{wheel} = POE::Wheel::SocketFactory->new + ( SocketDomain => AF_UNIX, + RemoteAddress => $unix_server_socket, + SuccessState => 'got_server', + FailureState => 'got_error', + ); + + &ok_if(3, defined $heap->{wheel}); +} + +sub client_unix_stop { + &ok(7); +} + +sub client_unix_connected { + my ($heap, $server_socket) = @_[HEAP, ARG0]; + + delete $heap->{wheel}; + $heap->{wheel} = POE::Wheel::ReadWrite->new + ( Handle => $server_socket, + Driver => POE::Driver::SysRW->new(), + Filter => POE::Filter::Line->new(), + InputState => 'got_line', + ErrorState => 'got_error', + FlushedState => 'got_flush', + BlockSize => 1, + ); + + &ok_if(4, defined $heap->{wheel}); + + $heap->{flush_count} = 0; + $heap->{put_count} = 1; + $heap->{wheel}->put( '1: this is a test' ); + + &ok_if(14, $heap->{wheel}->get_driver_out_octets() == 19); + &ok_if(15, $heap->{wheel}->get_driver_out_messages() == 1); +} + +sub client_unix_got_line { + my ($heap, $line) = @_[HEAP, ARG0]; + + if ($line =~ s/^1: //) { + $heap->{put_count}++; + $heap->{wheel}->put( '2: ' . $line ); + } + elsif ($line =~ s/^2: //) { + &ok_if(13, $line eq 'this is a test'); + delete $heap->{wheel}; + } +} + +sub client_unix_got_error { + my ($operation, $errnum, $errstr) = @_[ARG0..ARG2]; + warn "$operation error $errnum: $errstr"; +} + +sub client_unix_got_flush { + $_[HEAP]->{flush_count}++; +} + +### Start the UNIX domain server and client. + +POE::Session->create + ( inline_states => + { _start => \&server_unix_start, + _stop => \&server_unix_stop, + _child => \&server_unix_child, + got_client => \&server_unix_answered, + got_error => \&server_unix_error, + } + ); + +POE::Session->create + ( inline_states => + { _start => \&client_unix_start, + _stop => \&client_unix_stop, + got_server => \&client_unix_connected, + got_line => \&client_unix_got_line, + got_error => \&client_unix_got_error, + got_flush => \&client_unix_got_flush + } + ); + +### main loop + +$poe_kernel->run(); + +&ok(12); +&results; + +exit; diff --git a/tests/10_wheels_tcp.t b/tests/10_wheels_tcp.t new file mode 100644 index 000000000..2457faa1d --- /dev/null +++ b/tests/10_wheels_tcp.t @@ -0,0 +1,188 @@ +#!/usr/bin/perl -w +# $Id$ + +# Exercises the wheels commonly used with TCP sockets. + +use strict; +use lib qw(./lib ../lib); +use TestSetup; +use Socket; + +use POE qw( Component::Server::TCP + Wheel::ReadWrite + Filter::Line Filter::Stream + Driver::SysRW + ); + +my $tcp_server_port = 31909; + +# Congratulations! We made it this far! +&test_setup(12); +&ok(1); + +############################################################################### +# A generic server session. + +sub sss_new { + my ($socket, $peer_addr, $peer_port) = @_; + POE::Session->create + ( inline_states => + { _start => \&sss_start, + _stop => \&sss_stop, + got_line => \&sss_line, + got_error => \&sss_error, + got_flush => \&sss_flush, + }, + args => [ $socket, $peer_addr, $peer_port ], + ); +} + +sub sss_start { + my ($heap, $socket, $peer_addr, $peer_port) = @_[HEAP, ARG0..ARG2]; + + delete $heap->{wheel}; + $heap->{wheel} = POE::Wheel::ReadWrite->new + ( Handle => $socket, + Driver => POE::Driver::SysRW->new(), + Filter => POE::Filter::Line->new(), + InputState => 'got_line', + ErrorState => 'got_error', + FlushedState => 'got_flush', + BlockSize => 1, + ); + + &ok_if(2, defined $heap->{wheel}); + + $heap->{flush_count} = 0; + $heap->{put_count} = 0; +} + +sub sss_line { + my ($heap, $line) = @_[HEAP, ARG0]; + + $line =~ tr/a-zA-Z/n-za-mN-ZA-M/; # rot13 + + $heap->{wheel}->put($line); + $heap->{put_count}++; +} + +sub sss_error { + my ($operation, $errnum, $errstr) = @_[ARG0..ARG2]; + + &ok_unless(3, $errnum); + + delete $_[HEAP]->{wheel}; +} + +sub sss_flush { + $_[HEAP]->{flush_count}++; +} + +sub sss_stop { + &ok_if (4, $_[HEAP]->{put_count} == $_[HEAP]->{flush_count}); +} + +############################################################################### +# A TCP socket client. + +sub client_tcp_start { + my $heap = $_[HEAP]; + + $heap->{wheel} = POE::Wheel::SocketFactory->new + ( RemoteAddress => '127.0.0.1', + RemotePort => $tcp_server_port, + SuccessState => 'got_server', + FailureState => 'got_error', + ); + + &ok_if(5, defined $heap->{wheel}); +} + +sub client_tcp_stop { + &ok(6); +} + +sub client_tcp_connected { + my ($heap, $server_socket) = @_[HEAP, ARG0]; + + delete $heap->{wheel}; + $heap->{wheel} = POE::Wheel::ReadWrite->new + ( Handle => $server_socket, + Driver => POE::Driver::SysRW->new(), + Filter => POE::Filter::Line->new(), + InputState => 'got_line', + ErrorState => 'got_error', + FlushedState => 'got_flush', + BlockSize => 1, + ); + + &ok_if(7, defined $heap->{wheel}); + + $heap->{flush_count} = 0; + $heap->{put_count} = 1; + $heap->{wheel}->put( '1: this is a test' ); + + &ok_if(11, $heap->{wheel}->get_driver_out_octets() == 19); + &ok_if(12, $heap->{wheel}->get_driver_out_messages() == 1); +} + +sub client_tcp_got_line { + my ($heap, $line) = @_[HEAP, ARG0]; + + if ($line =~ s/^1: //) { + $heap->{put_count}++; + $heap->{wheel}->put( '2: ' . $line ); + } + elsif ($line =~ s/^2: //) { + &ok_if(8, $line eq 'this is a test'); + delete $heap->{wheel}; + } +} + +sub client_tcp_got_error { + my ($operation, $errnum, $errstr) = @_[ARG0..ARG2]; + warn "$operation error $errnum: $errstr"; +} + +sub client_tcp_got_flush { + $_[HEAP]->{flush_count}++; +} + +############################################################################### +# Start the TCP server and client. + +POE::Component::Server::TCP->new + ( Port => $tcp_server_port, + Acceptor => sub { &sss_new(@_[ARG0..ARG2]); + # This next badness is just for testing. + my $sockname = $_[HEAP]->{listener}->getsockname(); + delete $_[HEAP]->{listener}; + + my ($port, $addr) = sockaddr_in($sockname); + $addr = inet_ntoa($addr); + &ok_if( 10, + ($addr eq '0.0.0.0') && + ($port == $tcp_server_port) + ) + }, + ); + +POE::Session->create + ( inline_states => + { _start => \&client_tcp_start, + _stop => \&client_tcp_stop, + got_server => \&client_tcp_connected, + got_line => \&client_tcp_got_line, + got_error => \&client_tcp_got_error, + got_flush => \&client_tcp_got_flush + } + ); + +### main loop + +$poe_kernel->run(); + +&ok(9); +&results; + +exit; diff --git a/tests/11_signals_poe.t b/tests/11_signals_poe.t new file mode 100644 index 000000000..33ef8246c --- /dev/null +++ b/tests/11_signals_poe.t @@ -0,0 +1,92 @@ +#!/usr/bin/perl -w +# $Id$ + +# Tests various signals using POE's stock signal handlers. These are +# plain Perl signals, so mileage may vary. + +use strict; +use lib qw(./lib ../lib); +use TestSetup; +&test_setup(2); + +use POE; + +# Use Time::HiRes, if it's available. This will get us super accurate +# sleep times so all the child processes wake up close together. The +# idea is to have CHLD signals overlap. + +eval { + require Time::HiRes; + import Time::HiRes qw(time sleep); +}; + +my $fork_count = 16; + +# Set up a signal catching session. This test uses plain fork(2) and +# POE's $SIG{CHLD} handler. + +POE::Session->create + ( inline_states => + { _start => + sub { + $_[HEAP]->{forked} = $_[HEAP]->{reaped} = 0; + $_[KERNEL]->sig( CHLD => 'catch_sigchld' ); + + my $wake_time = time() + 30; + + # Fork 16 child processes, all to exit at the same time. + for (my $child = 0; $child < $fork_count; $child++) { + my $child_pid = fork; + + if (defined $child_pid) { + if ($child_pid) { + $_[HEAP]->{forked}++; + } + else { + sleep $wake_time - time(); + exit; + } + } + else { + warn "fork error: $!"; + } + } + + if ($_[HEAP]->{forked} == $fork_count) { + print "ok 1\n"; + } + else { + print "not ok 1 # forked $_[HEAP]->{forked} out of $fork_count\n"; + } + + $_[KERNEL]->delay( time_is_up => 60 ); + }, + + _stop => + sub { + my $heap = $_[HEAP]; + if ($heap->{reaped} == $fork_count) { + print "ok 2\n"; + } + else { + print "not ok 2 # reaped $heap->{reaped} out of $fork_count\n"; + } + }, + + catch_sigchld => + sub { + $_[HEAP]->{reaped}++; + }, + + time_is_up => + sub { + # do nothing, really + }, + }, + ); + +# Run the tests. + +$poe_kernel->run(); + +exit;