view release on metacpan or  search on metacpan

local/lib/perl5/IO/Async/LoopTests.pm  view on Meta::CPAN

Runs a test or collection of tests against the loop subclass given. The class
being tested is loaded by this function; the containing script does not need
to C<require> or C<use> it first.

This function runs C<Test::More::plan> to output its expected test count; the
containing script should not do this.

=cut

sub run_tests
{
   my ( $testclass, @tests ) = @_;

   my $count = 0;
   $count += __PACKAGE__->can( "count_tests_$_" )->() + 4 for @tests;

   plan tests => $count;

   ( my $file = "$testclass.pm" ) =~ s{::}{/}g;

   eval { require $file };
   if( $@ ) {
      BAIL_OUT( "Unable to load $testclass - $@" );
   }

   foreach my $test ( @tests ) {
      $loop = $testclass->new;

      isa_ok( $loop, $testclass, '$loop' );

      is( IO::Async::Loop->new, $loop, 'magic constructor yields $loop' );

      # Kill the reference in $ONE_TRUE_LOOP so as not to upset the refcounts
      # and to ensure we get a new one each time
      undef $IO::Async::Loop::ONE_TRUE_LOOP;

      is_oneref( $loop, '$loop has refcount 1' );

      __PACKAGE__->can( "run_tests_$test" )->();

      is_oneref( $loop, '$loop has refcount 1 finally' );
   }
}

sub wait_for(&)
{
   # Bounce via here so we don't upset refcount tests by having loop
   # permanently set in IO::Async::Test
   IO::Async::Test::testing_loop( $loop );

   # Override prototype - I know what I'm doing
   &IO::Async::Test::wait_for( @_ );

   IO::Async::Test::testing_loop( undef );
}

sub time_between(&$$$)
{
   my ( $code, $lower, $upper, $name ) = @_;

   my $start = time;
   $code->();
   my $took = ( time - $start ) / AUT;

   cmp_ok( $took, '>=', $lower, "$name took at least $lower seconds" ) if defined $lower;
   cmp_ok( $took, '<=', $upper * 3, "$name took no more than $upper seconds" ) if defined $upper;
   if( $took > $upper and $took <= $upper * 3 ) {
      diag( "$name took longer than $upper seconds - this may just be an indication of a busy testing machine rather than a bug" );
   }
}

=head1 TEST SUITES

The following test suite names exist, to be passed as a name in the C<@tests>
argument to C<run_tests>:

=cut

=head2 io

Tests the Loop's ability to watch filehandles for IO readiness

=cut

use constant count_tests_io => 18;
sub run_tests_io
{
   {
      my ( $S1, $S2 ) = IO::Async::OS->socketpair or die "Cannot create socket pair - $!";
      $_->blocking( 0 ) for $S1, $S2;

      my $readready  = 0;
      my $writeready = 0;
      $loop->watch_io(
         handle => $S1,
         on_read_ready => sub { $readready = 1 },
      );

      is_oneref( $loop, '$loop has refcount 1 after watch_io on_read_ready' );
      is( $readready, 0, '$readready still 0 before ->loop_once' );

      $loop->loop_once( 0.1 );

      is( $readready, 0, '$readready when idle' );

      $S2->syswrite( "data\n" );

      # We should still wait a little while even thought we expect to be ready
      # immediately, because talking to ourself with 0 poll timeout is a race
      # condition - we can still race with the kernel.

      $loop->loop_once( 0.1 );

      is( $readready, 1, '$readready after loop_once' );

      # Ready $S1 to clear the data
      $S1->getline; # ignore return

      $loop->unwatch_io(
         handle => $S1,
         on_read_ready => 1,
      );

local/lib/perl5/IO/Async/LoopTests.pm  view on Meta::CPAN

   my $cancelled_fired = 0;
   my $id = $loop->watch_time( after => 1 * AUT, code => sub { $cancelled_fired = 1 } );
   $loop->unwatch_time( $id );
   undef $id;

   $loop->loop_once( 2 * AUT );

   ok( !$cancelled_fired, 'unwatched watch_time does not fire' );

   $loop->watch_time( after => -1, code => sub { $done = 1 } );

   $done = 0;

   time_between {
      $loop->loop_once while !$done;
   } 0, 0.1, 'loop_once while waiting for negative interval timer';

   {
      my $done;

      my $id;
      $id = $loop->watch_time( after => 1 * AUT, code => sub {
         $loop->unwatch_time( $id ); undef $id;
      });

      $loop->watch_time( after => 1.1 * AUT, code => sub {
         $done++;
      });

      wait_for { $done };

      is( $done, 1, 'Other timers still fire after self-cancelling one' );
   }

   # Legacy enqueue/requeue/cancel API
   $done = 0;

   $loop->enqueue_timer( delay => 2 * AUT, code => sub { $done = 1; } );

   is_oneref( $loop, '$loop has refcount 1 after enqueue_timer' );

   time_between {
      my $now = time;
      $loop->loop_once( 5 * AUT );

      # poll might have returned just a little early, such that the TimerQueue
      # doesn't think anything is ready yet. We need to handle that case.
      while( !$done ) {
         die "It should have been ready by now" if( time - $now > 5 * AUT );
         $loop->loop_once( 0.1 * AUT );
      }
   } 1.5, 2.5, 'loop_once(5) while waiting for timer';

   SKIP: {
      skip "Unable to handle sub-second timers accurately", 3 unless $loop->_CAN_SUBSECOND_ACCURATELY;

      # Check that short delays are achievable in one ->loop_once call
      foreach my $delay ( 0.001, 0.01, 0.1 ) {
         my $done;
         my $count = 0;
         my $start = time;

         $loop->enqueue_timer( delay => $delay, code => sub { $done++ } );

         while( !$done ) {
            $loop->loop_once( 1 );
            $count++;
            last if time - $start > 5; # bailout
         }

         is( $count, 1, "One ->loop_once(1) sufficient for a single $delay second timer" );
      }
   }

   $cancelled_fired = 0;
   $id = $loop->enqueue_timer( delay => 1 * AUT, code => sub { $cancelled_fired = 1 } );
   $loop->cancel_timer( $id );
   undef $id;

   $loop->loop_once( 2 * AUT );

   ok( !$cancelled_fired, 'cancelled timer does not fire' );

   $id = $loop->enqueue_timer( delay => 1 * AUT, code => sub { $done = 2; } );
   $id = $loop->requeue_timer( $id, delay => 2 * AUT );

   $done = 0;

   time_between {
      $loop->loop_once( 1 * AUT );

      is( $done, 0, '$done still 0 so far' );

      my $now = time;
      $loop->loop_once( 5 * AUT );

      # poll might have returned just a little early, such that the TimerQueue
      # doesn't think anything is ready yet. We need to handle that case.
      while( !$done ) {
         die "It should have been ready by now" if( time - $now > 5 * AUT );
         $loop->loop_once( 0.1 * AUT );
      }
   } 1.5, 2.5, 'requeued timer of delay 2';

   is( $done, 2, '$done is 2 after requeued timer' );
}

=head2 signal

Tests the Loop's ability to watch POSIX signals

=cut

use constant count_tests_signal => 14;
sub run_tests_signal
{
   unless( IO::Async::OS->HAVE_SIGNALS ) {
      SKIP: { skip "This OS does not have signals", 14; }
      return;
   }

   my $caught = 0;

   $loop->watch_signal( TERM => sub { $caught++ } );

   is_oneref( $loop, '$loop has refcount 1 after watch_signal' );

   $loop->loop_once( 0.1 );