view release on metacpan or  search on metacpan

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

=cut

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

   ( 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' );
   }

   done_testing;
}

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 ) = @_;

   Test2::API::context_do {
      my $ctx = shift;;

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

      $ctx->ok( $took >= $lower,     "$name took at least $lower seconds" ) if defined $lower;
      $ctx->ok( $took <= $upper * 3, "$name took no more than $upper seconds" ) if defined $upper;
      if( $took > $upper and $took <= $upper * 3 ) {
         $ctx->note( "$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

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

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