Acme-Sort-Sleep

 view release on metacpan or  search on metacpan

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

#  You may distribute under the terms of either the GNU General Public License
#  or the Artistic License (the same terms as Perl itself)
#
#  (C) Paul Evans, 2009-2015 -- leonerd@leonerd.org.uk

package IO::Async::LoopTests;

use strict;
use warnings;

use Exporter 'import';
our @EXPORT = qw(
   run_tests
);

use Test::More;
use Test::Fatal;
use Test::Refcount;

use IO::Async::Test qw();

use IO::Async::OS;

use IO::File;
use Fcntl qw( SEEK_SET );
use POSIX qw( SIGTERM );
use Socket qw( sockaddr_family AF_UNIX );
use Time::HiRes qw( time );

our $VERSION = '0.70';

# Abstract Units of Time
use constant AUT => $ENV{TEST_QUICK_TIMERS} ? 0.1 : 1;

# The loop under test. We keep it in a single lexical here, so we can use
# is_oneref tests in the individual test suite functions
my $loop;
END { undef $loop }

=head1 NAME

C<IO::Async::LoopTests> - acceptance testing for L<IO::Async::Loop> subclasses

=head1 SYNOPSIS

 use IO::Async::LoopTests;
 run_tests( 'IO::Async::Loop::Shiney', 'io' );

=head1 DESCRIPTION

This module contains a collection of test functions for running acceptance
tests on L<IO::Async::Loop> subclasses. It is provided as a facility for
authors of such subclasses to ensure that the code conforms to the Loop API
required by L<IO::Async>.

=head1 TIMING

Certain tests require the use of timers or timed delays. Normally these are
counted in units of seconds. By setting the environment variable
C<TEST_QUICK_TIMERS> to some true value, these timers run 10 times quicker,
being measured in units of 0.1 seconds instead. This value may be useful when
running the tests interactively, to avoid them taking too long. The slower
timers are preferred on automated smoke-testing machines, to help guard
against false negatives reported simply because of scheduling delays or high
system load while testing.

 TEST_QUICK_TIMERS=1 ./Build test

=cut

=head1 FUNCTIONS

=cut

=head2 run_tests

   run_tests( $class, @tests )

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(&)

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

      ) for @handles;

      $loop->loop_once( 0.1 );

      is( $callcount, 1, 'write_ready on crosslinked handles can cancel each other' );
   }

   # Check that error conditions that aren't true read/write-ability are still
   # invoked
   {
      my ( $S1, $S2 ) = IO::Async::OS->socketpair( 'inet', 'dgram' ) or die "Cannot create AF_INET/SOCK_DGRAM connected pair - $!";
      $_->blocking( 0 ) for $S1, $S2;
      $S2->close;

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

      $S1->syswrite( "Boo!" );

      $loop->loop_once( 0.1 );

      is( $readready, 1, 'exceptional socket invokes on_read_ready' );

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

   # Check that regular files still report read/writereadiness
   {
      my $F = IO::File->new_tmpfile or die "Cannot create temporary file - $!";

      $F->print( "Here's some content\n" );
      $F->seek( 0, SEEK_SET );

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

      $loop->loop_once( 0.1 );

      is( $readready,  1, 'regular file is readready' );
      is( $writeready, 1, 'regular file is writeready' );

      $loop->unwatch_io(
         handle => $F,
         on_read_ready  => 1,
         on_write_ready => 1,
      );
   }
}

=head2 timer

Tests the Loop's ability to handle timer events

=cut

use constant count_tests_timer => 21;
sub run_tests_timer
{
   my $done = 0;
   # New watch/unwatch API

   cmp_ok( abs( $loop->time - time ), "<", 0.1, '$loop->time gives the current time' );

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

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

   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 watch_time after';

   $loop->watch_time( at => time + 2 * AUT, code => sub { $done = 2; } );

   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 watch_time at';

   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 );

   is( $caught, 0, '$caught idling' );

   kill SIGTERM, $$;

   is( $caught, 0, '$caught before ->loop_once' );

   $loop->loop_once( 0.1 );

   is( $caught, 1, '$caught after ->loop_once' );

   kill SIGTERM, $$;

   is( $caught, 1, 'second raise is still deferred' );

   $loop->loop_once( 0.1 );

   is( $caught, 2, '$caught after second ->loop_once' );

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

   $loop->unwatch_signal( 'TERM' );

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

   my ( $cA, $cB );

   my $idA = $loop->attach_signal( TERM => sub { $cA = 1 } );
   my $idB = $loop->attach_signal( TERM => sub { $cB = 1 } );

   is_oneref( $loop, '$loop has refcount 1 after 2 * attach_signal' );

   kill SIGTERM, $$;

   $loop->loop_once( 0.1 );

   is( $cA, 1, '$cA after raise' );

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

   undef $cA;
   undef $cB;

   kill SIGTERM, $$;

   $loop->loop_once( 0.1 );

   is( $cA, undef, '$cA after raise' );
   is( $cB, 1,     '$cB after raise' );

   $loop->detach_signal( 'TERM', $idB );

   ok( exception { $loop->attach_signal( 'this signal name does not exist', sub {} ) },
       'Bad signal name fails' );
}

=head2 idle

Tests the Loop's support for idle handlers

=cut

use constant count_tests_idle => 11;
sub run_tests_idle
{
   my $called = 0;

   my $id = $loop->watch_idle( when => 'later', code => sub { $called = 1 } );

   ok( defined $id, 'idle watcher id is defined' );

   is( $called, 0, 'deferred sub not yet invoked' );

   time_between { $loop->loop_once( 3 * AUT ) } undef, 1.0, 'loop_once(3) with deferred sub';

   is( $called, 1, 'deferred sub called after loop_once' );

   $loop->watch_idle( when => 'later', code => sub {
      $loop->watch_idle( when => 'later', code => sub { $called = 2 } )
   } );

   $loop->loop_once( 1 );

   is( $called, 1, 'inner deferral not yet invoked' );

   $loop->loop_once( 1 );

   is( $called, 2, 'inner deferral now invoked' );

   $called = 2; # set it anyway in case previous test fails

   $id = $loop->watch_idle( when => 'later', code => sub { $called = 20 } );

   $loop->unwatch_idle( $id );

   time_between { $loop->loop_once( 1 * AUT ) } 0.5, 1.5, 'loop_once(1) with unwatched deferral';

   is( $called, 2, 'unwatched deferral not called' );

   $id = $loop->watch_idle( when => 'later', code => sub { $called = 3 } );
   my $timer_id = $loop->watch_time( after => 5, code => sub {} );

   $loop->loop_once( 1 );

   is( $called, 3, '$loop->later still invoked with enqueued timer' );

   $loop->unwatch_time( $timer_id );

   $loop->later( sub { $called = 4 } );

   $loop->loop_once( 1 );

   is( $called, 4, '$loop->later shortcut works' );
}

=head2 child

Tests the Loop's support for watching child processes by PID

=cut

sub run_in_child(&)
{
   my $kid = fork;
   defined $kid or die "Cannot fork() - $!";
   return $kid if $kid;

   shift->();
   die "Fell out of run_in_child!\n";
}

use constant count_tests_child => 7;
sub run_tests_child
{
   my $kid = run_in_child {
      exit( 3 );
   };

   my $exitcode;

   $loop->watch_child( $kid => sub { ( undef, $exitcode ) = @_; } );

   is_oneref( $loop, '$loop has refcount 1 after watch_child' );
   ok( !defined $exitcode, '$exitcode not defined before ->loop_once' );

   undef $exitcode;
   wait_for { defined $exitcode };

   ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after child exit' );
   is( ($exitcode >> 8), 3,     'WEXITSTATUS($exitcode) after child exit' );

   SKIP: {
      skip "This OS does not have signals", 1 unless IO::Async::OS->HAVE_SIGNALS;

      # We require that SIGTERM perform its default action; i.e. terminate the
      # process. Ensure this definitely happens, in case the test harness has it
      # ignored or handled elsewhere.
      local $SIG{TERM} = "DEFAULT";

      $kid = run_in_child {
         sleep( 10 );
         # Just in case the parent died already and didn't kill us
         exit( 0 );
      };

      $loop->watch_child( $kid => sub { ( undef, $exitcode ) = @_; } );