#!/usr/bin/perl -w
# vim: ts=2 sw=2 expandtab
# Tests alarms.
use strict;
use lib qw(./mylib ../mylib);
use Test::More tests => 37;
sub POE::Kernel::ASSERT_DEFAULT () { 1 }
BEGIN {
package
POE::Kernel;
use constant TRACE_DEFAULT => exists($INC{'Devel/Cover.pm'});
}
use constant WAIT => 0.5;
BEGIN { use_ok("POE") }
# Test the ID-based alarm API. Start several test paths. Each path
# exercises
# We need this because queue_peek_alarms was deprecated
BEGIN {
package # split to avoid CPAN indexer
POE::Kernel;
sub queue_peek_alarms {
my $self = shift;
my $session = $self->get_active_session;
my $alarm_count = $self->_data_ev_get_count_to($session);
my $my_alarm = sub {
return 0 unless $_[0]->[EV_TYPE] & ET_ALARM;
return 0 unless $_[0]->[EV_SESSION] == $session;
return 1;
};
return( map { $_->[ITEM_PAYLOAD]->[EV_NAME] }
$self->[KR_QUEUE]->peek_items($my_alarm, $alarm_count)
);
}
}
sub test_start {
my ($kernel, $heap) = @_[KERNEL, HEAP];
# Path #1: single alarm; make sure it rings.
$heap->{test}->{path_one} = 0;
$kernel->alarm( path_one => time() + WAIT, 1.1 );
# Path #2: two alarms; make sure only the second one rings.
$heap->{test}->{path_two} = 0;
$kernel->alarm( path_two => time() + WAIT, 2.1 );
$kernel->alarm( path_two => time() + WAIT, 2.2 );
# Path #3: two alarms; make sure they both ring in order.
$heap->{test}->{path_three} = 0;
$kernel->alarm_add( path_three => time() + WAIT, 3.1 );
$kernel->alarm_add( path_three => time() + WAIT, 3.2 );
# Path #4: interleaved alarm and alarm_add; only the last two should
# ring, in order.
$heap->{test}->{path_four} = 0;
$kernel->alarm( path_four => time() + WAIT, 4.1 );
$kernel->alarm_add( path_four => time() + WAIT, 4.2 );
$kernel->alarm( path_four => time() + WAIT, 4.3 );
$kernel->alarm_add( path_four => time() + WAIT, 4.4 );
# Path #5: an alarm that is squelched; nothing should ring.
$heap->{test}->{path_five} = 1;
$kernel->alarm( path_five => time() + WAIT, 5.1 );
$kernel->alarm( 'path_five' );
# Path #6: single delay; make sure it rings.
$heap->{test}->{path_six} = 0;
$kernel->delay( path_six => WAIT, 6.1 );
# Path #7: two delays; make sure only the second one rings.
$heap->{test}->{path_seven} = 0;
$kernel->delay( path_seven => WAIT, 7.1 );
$kernel->delay( path_seven => WAIT, 7.2 );
# Path #8: two delays; make sure they both ring in order.
$heap->{test}->{path_eight} = 0;
$kernel->delay_add( path_eight => WAIT, 8.1 );
$kernel->delay_add( path_eight => WAIT, 8.2 );
# Path #9: interleaved delay and delay_add; only the last two should
# ring, in order.
$heap->{test}->{path_nine} = 0;
$kernel->alarm( path_nine => WAIT, 9.1 );
$kernel->alarm_add( path_nine => WAIT, 9.2 );
$kernel->alarm( path_nine => WAIT, 9.3 );
$kernel->alarm_add( path_nine => WAIT, 9.4 );
# Path #10: a delay that is squelched; nothing should ring.
$heap->{test}->{path_ten} = 1;
$kernel->delay( path_ten => WAIT, 10.1 );
$kernel->alarm( 'path_ten' );
# Path #11: ensure alarms are enqueued in time order.
# To test duplicates on a small queue.
my $id_25_3 = $kernel->alarm_set( path_eleven_025_3 => 25 );
my $id_25_2 = $kernel->alarm_set( path_eleven_025_2 => 25 );
my $id_25_1 = $kernel->alarm_set( path_eleven_025_1 => 25 );
# To test micro-updates on a small queue.
$kernel->alarm_adjust( $id_25_1 => -0.01 ); # negative
$kernel->alarm_adjust( $id_25_3 => 0.01 ); # positive
# Fill the alarm queue to engage the "big queue" binary insert.
my @eleven_fill;
for (my $count=0; $count<600; $count++) {
my $time = int(rand(300));
redo unless $time; # Event doesn't like setting alarms for 0 time.
push @eleven_fill, $time;
$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.
my $id_206 = $kernel->alarm_set( path_eleven_206 => 205 );
my $id_205 = $kernel->alarm_set( path_eleven_205 => 205 );
my $id_204 = $kernel->alarm_set( path_eleven_204 => 205 );
# To test micro-updates on a big queue.
$kernel->alarm_adjust( $id_204 => -0.01 ); # negative
$kernel->alarm_adjust( $id_206 => 0.01 ); # positive
# Now clear the filler states.
for (my $count=0; $count<600; $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_[0-9_]+$/,
$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();
}
sub test_stop {
my $heap = $_[HEAP];
is($heap->{test}->{path_one}, 1, "single alarm rang ok");
is($heap->{test}->{path_two}, 1, "second alarm superseded first");
is($heap->{test}->{path_three}, 11, "two alarms rang in proper order");
is($heap->{test}->{path_four}, 11, "mixed alarm APIs rang properly");
is($heap->{test}->{path_five}, 1, "stopped alarm should not ring");
is($heap->{test}->{path_six}, 1, "single delay rang ok");
is($heap->{test}->{path_seven}, 1, "second delay superseded first");
is($heap->{test}->{path_eight}, 11, "two delays rang in proper order");
is($heap->{test}->{path_nine}, 11, "mixed delay APIs rang properly");
is($heap->{test}->{path_ten}, 1, "stopped delay should not ring");
# Here's where we check the overall run time. Increased to 15s for
# extremely slow, overtaxed machines like my XP system running under
# Virtual PC.
cmp_ok(time() - $heap->{start_time}, '<=', 15, "tests ran reasonably fast");
# And test alarm order.
is_deeply(
$heap->{alarms_eleven},
[
qw(
path_eleven_025_1
path_eleven_025_2
path_eleven_025_3
path_eleven_050
path_eleven_075
path_eleven_100
path_eleven_125
path_eleven_150
path_eleven_175
path_eleven_200
path_eleven_204
path_eleven_205
path_eleven_206
path_eleven_225
path_eleven_250
path_eleven_275
path_eleven_300
path_eleven_325
path_eleven_350
)
],
"alarms rang in order"
);
}
sub test_path_one {
my ($heap, $test_id) = @_[HEAP, ARG0];
if ($test_id == 1.1) {
$heap->{test}->{path_one} += 1;
}
else {
$heap->{test}->{path_one} += 1000;
}
}
sub test_path_two {
my ($heap, $test_id) = @_[HEAP, ARG0];
if ($test_id == 2.2) {
$heap->{test}->{path_two} += 1;
}
else {
$heap->{test}->{path_two} += 1000;
}
}
sub test_path_three {
my ($heap, $test_id) = @_[HEAP, ARG0];
if (($test_id == 3.1) and ($heap->{test}->{path_three} == 0)) {
$heap->{test}->{path_three} += 1;
}
elsif (($test_id == 3.2) and ($heap->{test}->{path_three} == 1)) {
$heap->{test}->{path_three} += 10;
}
else {
$heap->{test}->{path_three} += 1000;
}
}
sub test_path_four {
my ($heap, $test_id) = @_[HEAP, ARG0];
if (($test_id == 4.3) and ($heap->{test}->{path_four} == 0)) {
$heap->{test}->{path_four} += 1;
}
elsif (($test_id == 4.4) and ($heap->{test}->{path_four} == 1)) {
$heap->{test}->{path_four} += 10;
}
else {
$heap->{test}->{path_four} += 1000;
}
}
sub test_path_five {
my ($heap, $test_id) = @_[HEAP, ARG0];
$heap->{test}->{path_five} += 1;
}
sub test_path_six {
my ($heap, $test_id) = @_[HEAP, ARG0];
if ($test_id == 6.1) {
$heap->{test}->{path_six} += 1;
}
else {
$heap->{test}->{path_six} += 1000;
}
}
sub test_path_seven {
my ($heap, $test_id) = @_[HEAP, ARG0];
if ($test_id == 7.2) {
$heap->{test}->{path_seven} += 1;
}
else {
$heap->{test}->{path_seven} += 1000;
}
}
sub test_path_eight {
my ($heap, $test_id) = @_[HEAP, ARG0];
if (($test_id == 8.1) and ($heap->{test}->{path_eight} == 0)) {
$heap->{test}->{path_eight} += 1;
}
elsif (($test_id == 8.2) and ($heap->{test}->{path_eight} == 1)) {
$heap->{test}->{path_eight} += 10;
}
else {
$heap->{test}->{path_eight} += 1000;
}
}
sub test_path_nine {
my ($heap, $test_id) = @_[HEAP, ARG0];
if (($test_id == 9.3) and ($heap->{test}->{path_nine} == 0)) {
$heap->{test}->{path_nine} += 1;
}
elsif (($test_id == 9.4) and ($heap->{test}->{path_nine} == 1)) {
$heap->{test}->{path_nine} += 10;
}
else {
$heap->{test}->{path_nine} += 1000;
}
}
sub test_path_ten {
my ($heap, $test_id) = @_[HEAP, ARG0];
$heap->{test}->{path_ten} += 1;
}
### Spawn a session to test the ID-based alarm API added in June 2001.
POE::Session->create(
inline_states => {
_start => sub {
my ($kernel, $heap) = @_[KERNEL, HEAP];
$heap->{test_13} = $kernel->alarm_set( test_13 => 1 => 13 );
my $test_14 = $kernel->alarm_set( test_14 => 1 => 14 );
my @test_array = $kernel->alarm_remove( $test_14 );
is($test_array[0], 'test_14', "alarm 14 remove: name is correct");
is($test_array[1], 1, "alarm 14 remove: time is correct");
is_deeply($test_array[2], [ 14 ], "alarm 14 remove: data is correct");
# Have time stand still so we can test against it.
# Heisenberg strikes again!
my $now = time;
my $test_15 = $kernel->delay_set( test_15 => WAIT, 15 );
my $test_scalar = $kernel->alarm_remove( $test_15 );
is($test_scalar->[0], 'test_15', "alarm 15 remove: name is correct");
ok(
( $test_scalar->[1] <= $now + 3 and
$test_scalar->[1] >= $now
), "alarm 15 remove: time is correct"
);
is_deeply($test_scalar->[2], [ 15 ], "alarm 15 remove: data is correct");
},
# This one is dispatched.
test_13 => sub {
my $kernel = $_[KERNEL];
is($_[ARG0], 13, "alarm 13: received proper data");
# Set a couple alarms, then clear them all.
$kernel->delay( test_16 => WAIT );
$kernel->delay( test_17 => WAIT );
$kernel->alarm_remove_all();
# Test alarm adjusting on little queues.
my $alarm_id = $kernel->alarm_set( test_18 => 50 => 18 );
# One alarm.
my $new_time = $kernel->alarm_adjust( $alarm_id => -1 );
is($new_time, 49, "alarm 18: adjusted backward correctly");
$new_time = $kernel->alarm_adjust( $alarm_id => 1 );
is($new_time, 50, "alarm 18: adjusted forward correctly");
# Two alarms.
$alarm_id = $kernel->alarm_set( test_19 => 52 => 19 );
$new_time = $kernel->alarm_adjust( $alarm_id => -4 );
is($new_time, 48, "alarm 19: adjusted backward correctly");
$new_time = $kernel->alarm_adjust( $alarm_id => 4 );
is($new_time, 52, "alarm 19: adjusted forward correctly");
# Three alarms.
$alarm_id = $kernel->alarm_set( test_20 => 49 => 20 );
$new_time = $kernel->alarm_adjust( $alarm_id => 2 );
is($new_time, 51, "alarm 20: adjusted forward once correctly");
$new_time = $kernel->alarm_adjust( $alarm_id => 2 );
is($new_time, 53, "alarm 20: adjusted forward twice correctly");
$new_time = $kernel->alarm_adjust( $alarm_id => -2 );
is($new_time, 51, "alarm 20: adjusted backward correctly");
# Test alarm adjusting on big queues.
my @alarm_filler;
for (1..100) {
push( @alarm_filler, $kernel->alarm_set( filler => $_) );
}
# Moving inside the alarm range.
$alarm_id = $kernel->alarm_set( test_21 => 50 => 21 );
$new_time = $kernel->alarm_adjust( $alarm_id => -10 );
is($new_time, 40, "alarm 21: adjusted backward correctly");
$new_time = $kernel->alarm_adjust( $alarm_id => 20 );
is($new_time, 60, "alarm 21: adjusted forward correctly");
# Moving outside (to the beginning) of the alarm range.
$new_time = $kernel->alarm_adjust( $alarm_id => -100 );
is($new_time, -40, "alarm 21: adjusted first correctly");
# Moving outside (to the end) of the alarm range.
$alarm_id = $kernel->alarm_set( test_22 => 50 => 22 );
$new_time = $kernel->alarm_adjust( $alarm_id => 100 );
is($new_time, 150, "alarm 22: adjusted last correctly");
# Remove the filler events.
foreach (@alarm_filler) {
$kernel->alarm_remove( $_ );
}
},
# These have been removed. They should not be dispatched.
test_14 => sub { fail("alarm 14 should have been removed"); },
test_15 => sub { fail("alarm 15 should have been removed"); },
test_16 => sub { fail("alarm 16 should have been removed"); },
test_17 => sub { fail("alarm 17 should have been removed"); },
# These should be dispatched in a certain order.
_default => sub {
my ($kernel, $heap) = @_[KERNEL, HEAP];
# Save the test's argument on the heap. Check during _stop.
push( @{$heap->{tests}}, $_[ARG1]->[0] ) if $_[ARG0] =~ /test_\d+/;
# Handle the signal.
$kernel->sig_handled();
},
_stop => sub {
my $heap = $_[HEAP];
is(@{$heap->{tests}}, 5, "the right number of alarms were dispatched");
is($heap->{tests}->[0], 21, "alarm 21 was dispatched first");
is($heap->{tests}->[1], 18, "alarm 18 was dispatched second");
is($heap->{tests}->[2], 20, "alarm 20 was dispatched third");
is($heap->{tests}->[3], 19, "alarm 19 was dispatched fourth");
is($heap->{tests}->[4], 22, "alarm 22 was dispatched fifth");
},
}
);
# Run the old tests here.
POE::Session->create(
inline_states => {
_start => \&test_start,
_stop => \&test_stop,
path_one => \&test_path_one,
path_two => \&test_path_two,
path_three => \&test_path_three,
path_four => \&test_path_four,
path_five => \&test_path_five,
path_six => \&test_path_six,
path_seven => \&test_path_seven,
path_eight => \&test_path_eight,
path_nine => \&test_path_nine,
path_ten => \&test_path_ten,
}
);
# Ye olde main loop and exit.
POE::Kernel->run();
1;