Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

lots of testing changes and additions

  • Loading branch information...
commit 1db9198437cf035082037c14585d77b846e3af62 1 parent 33828a3
@rcaputo authored
View
100 Changes
@@ -18,7 +18,6 @@ subversions are available from <http://www.newts.org/~troc/poe.html>.
|
| 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 <http://www.newts.org/~troc/poe.html>.
`-----------------
+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, &not_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
View
4 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
View
19 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 <ftp://ftp.cpan.org/pub/CPAN/authors/id/R/RC/RCAPUTO/> 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!
View
2  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
View
329 lib/POE/Kernel.pm
@@ -174,6 +174,77 @@ macro test_for_idle_poe_kernel {
}
}
+macro post_plain_signal (<destination>,<signal_name>) {
+ $poe_kernel->_enqueue_state( <destination>, $poe_kernel,
+ EN_SIGNAL, ET_SIGNAL,
+ [ <signal_name> ],
+ time(), __FILE__, __LINE__
+ );
+}
+
+macro post_child_signal(<destination>,<pid>,<exit_status>) {
+ # 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(<exit_status>)) {
+ $poe_kernel->_enqueue_state( <destination>, $poe_kernel,
+ EN_SIGNAL, ET_SIGNAL,
+ [ 'CHLD', <pid>, <exit_status> ],
+ 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,
[],
View
33 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
View
19 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',
);
View
20 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 }
View
8 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,
},
);
View
130 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;
View
109 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 &not_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 {
+ &not_ok($test_number, $reason);
+ }
+}
+
+sub ok_unless {
+ my ($test_number, $value, $reason) = @_;
+
+ unless ($value) {
+ &ok($test_number);
+ }
+ else {
+ &not_ok($test_number, $reason);
+ }
}
1;
+
View
147 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 (<R>) {
+ 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;
View
59 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;
View
98 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;
View
89 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;
View
71 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;
View
5 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);
View
4 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?
View
12 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.
View
35 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;
View
153 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;
View
231 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,