This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
sigsystem.t depends on fork().
[perl5.git] / t / op / sigsystem.t
CommitLineData
c56bc161
LT
1#!perl -w
2
3BEGIN {
4 require './test.pl';
d3da9911 5 skip_all_if_miniperl();
62f78998 6 skip_all_without_config(qw(d_fork));
c56bc161
LT
7}
8
9use strict;
10use constant TRUE => ($^X, '-e', 'exit 0');
11use Data::Dumper;
12
13plan tests => 4;
14
15SKIP: {
d3da9911 16 skip 'Platform doesn\'t support SIGCHLD', 4 if not exists $SIG{CHLD};
c56bc161
LT
17 require POSIX;
18 require Time::HiRes;
19
20 my $pid = fork // die "Can't fork: $!";
21 unless ($pid) {
22 note("Child PID: $$");
23 Time::HiRes::sleep(0.250);
24 POSIX::_exit(0);
25 }
26
27 test_system('without reaper');
28
29 my @pids;
30 $SIG{CHLD} = sub {
31 while ((my $child = waitpid(-1, POSIX::WNOHANG())) > 0) {
32 note "Reaped: $child";
33 push @pids, $child;
34 }
35 };
36
37 test_system('with reaper');
38
39 note("Waiting briefly for SIGCHLD...");
40 Time::HiRes::sleep(0.500);
41
42 ok(@pids == 1, 'Reaped only one process');
43 ok($pids[0] == $pid, "Reaped the right process.") or diag(Dumper(\@pids));
44}
45
46sub test_system {
47 my $subtest = shift;
48
49 my $expected_zeroes = 10;
50 my $got_zeroes = 0;
51
52 # This test is looking for a race between system()'s waitpid() and a
53 # signal handler. Looping a few times increases the chances of
54 # catching the error.
55
56 for (1..$expected_zeroes) {
57 $got_zeroes++ unless system(TRUE);
58 }
59
60 is(
61 $got_zeroes, $expected_zeroes,
62 "system() $subtest succeeded $got_zeroes times out of $expected_zeroes"
63 );
64}
65