1#!perl -w 2 3BEGIN { 4 chdir 't' if -d 't'; 5 require './test.pl'; 6 skip_all_if_miniperl(); 7 skip_all_without_config(qw(d_fork)); 8} 9 10use strict; 11use constant TRUE => ($^X, '-e', 'exit 0'); 12use Data::Dumper; 13 14plan tests => 4; 15 16SKIP: { 17 skip 'Platform doesn\'t support SIGCHLD', 4 if not exists $SIG{CHLD}; 18 require POSIX; 19 require Time::HiRes; 20 21 my @pids; 22 $SIG{CHLD} = sub { 23 while ((my $child = waitpid(-1, POSIX::WNOHANG())) > 0) { 24 note "Reaped: $child"; 25 push @pids, $child; 26 } 27 }; 28 my $pid = fork // die "Can't fork: $!"; 29 unless ($pid) { 30 note("Child PID: $$"); 31 Time::HiRes::sleep(0.250); 32 POSIX::_exit(0); 33 } 34 35 test_system('without reaper'); 36 37 test_system('with reaper'); 38 39 note("Waiting briefly for SIGCHLD..."); 40 41 # Wait at most 50 * 0.500 = 25.0 seconds for the child process to be 42 # reaped. If the child process exits and gets reaped early, this polling 43 # loop will exit early. 44 45 for (1..50) { 46 last if @pids; 47 Time::HiRes::sleep(0.500); 48 } 49 50 ok(@pids == 1, 'Reaped only one process'); 51 ok($pids[0] == $pid, "Reaped the right process.") or diag(Dumper(\@pids)); 52} 53 54sub test_system { 55 my $subtest = shift; 56 57 my $expected_zeroes = 10; 58 my $got_zeroes = 0; 59 60 # This test is looking for a race between system()'s waitpid() and a 61 # signal handler. The system() call is expected to not interfere with the 62 # SIGCHLD signal handler. In particular, the wait() called within system() 63 # is expected to reap the child process forked by system() before the 64 # SIGCHLD signal handler is called. 65 # Looping a few times increases the chances of catching the error. 66 67 for (1..$expected_zeroes) { 68 $got_zeroes++ unless system(TRUE); 69 } 70 71 is( 72 $got_zeroes, $expected_zeroes, 73 "system() $subtest succeeded $got_zeroes times out of $expected_zeroes" 74 ); 75} 76 77