lib/POE/Test/Loops/k_alarms.pm

#!/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;
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)