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
1 #!perl -w
2
3 BEGIN {
4       require './test.pl';
5       skip_all_if_miniperl();
6       skip_all_without_config(qw(d_fork));
7 }
8
9 use strict;
10 use constant TRUE => ($^X, '-e', 'exit 0');
11 use Data::Dumper;
12
13 plan tests => 4;
14
15 SKIP: {
16     skip 'Platform doesn\'t support SIGCHLD', 4 if not exists $SIG{CHLD};
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
46 sub 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