view release on metacpan or  search on metacpan

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

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

      kill SIGTERM, $kid;

      undef $exitcode;
      wait_for { defined $exitcode };

      is( ($exitcode & 0x7f), SIGTERM, 'WTERMSIG($exitcode) after SIGTERM' );
   }

   my %kids;

   $loop->watch_child( 0 => sub { my ( $kid ) = @_; delete $kids{$kid} } );

   %kids = map { run_in_child { exit 0 } => 1 } 1 .. 3;

   is( scalar keys %kids, 3, 'Waiting for 3 child processes' );

   wait_for { !keys %kids };
   ok( !keys %kids, 'All child processes reclaimed' );
}

=head2 control

Tests that the C<run>, C<stop>, C<loop_once> and C<loop_forever> methods
behave correctly

=cut

use constant count_tests_control => 8;
sub run_tests_control
{
   time_between { $loop->loop_once( 0 ) } 0, 0.1, 'loop_once(0) when idle';

   time_between { $loop->loop_once( 2 * AUT ) } 1.5, 2.5, 'loop_once(2) when idle';

   $loop->watch_time( after => 0.1, code => sub { $loop->stop( result => "here" ) } );

   local $SIG{ALRM} = sub { die "Test timed out before ->stop" };
   alarm( 1 );

   my @result = $loop->run;

   alarm( 0 );

   is_deeply( \@result, [ result => "here" ], '->stop arguments returned by ->run' );

   $loop->watch_time( after => 0.1, code => sub { $loop->stop( result => "here" ) } );

   my $result = $loop->run;

   is( $result, "result", 'First ->stop argument returned by ->run in scalar context' );

   $loop->watch_time( after => 0.1, code => sub {
      $loop->watch_time( after => 0.1, code => sub { $loop->stop( "inner" ) } );
      my @result = $loop->run;
      $loop->stop( @result, "outer" );
   } );

   @result = $loop->run;

   is_deeply( \@result, [ "inner", "outer" ], '->run can be nested properly' );

   $loop->watch_time( after => 0.1, code => sub { $loop->loop_stop } );

   local $SIG{ALRM} = sub { die "Test timed out before ->loop_stop" };
   alarm( 1 );

   $loop->loop_forever;

   alarm( 0 );

   ok( 1, '$loop->loop_forever interruptable by ->loop_stop' );
}