Update releaser managers
[perl.git] / t / op / getppid.t
1 #!./perl
2
3 # Test that getppid() follows UNIX semantics: when the parent process
4 # dies, the child is reparented to the init process
5 # The init process is usually 1, but doesn't have to be, and there's no
6 # standard way to find out what it is, so the only portable way to go it so
7 # attempt 2 reparentings and see if the PID both orphaned grandchildren get is
8 # the same. (and not ours)
9 #
10 # NOTE: Docker and Linux containers set parent to 0 on orphaned tests.
11 # We have to adjust to this below.
12
13 BEGIN {
14     chdir 't' if -d 't';
15     require './test.pl';
16     set_up_inc( qw(../lib) );
17 }
18
19 use strict;
20
21 skip_all_without_config(qw(d_pipe d_fork d_waitpid d_getppid));
22 plan (8);
23
24 # No, we don't want any zombies. kill 0, $ppid spots zombies :-(
25 $SIG{CHLD} = 'IGNORE';
26
27 sub fork_and_retrieve {
28     my $which = shift;
29     pipe my ($r, $w) or die "pipe: $!\n";
30     my $pid = fork; defined $pid or die "fork: $!\n";
31
32     if ($pid) {
33         # parent
34         close $w or die "close: $!\n";
35         $_ = <$r>;
36         chomp;
37         die "Garbled output '$_'"
38             unless my ($how, $first, $second) = /^([a-z]+),(\d+),(\d+)\z/;
39         cmp_ok ($first, '>=', 1, "Parent of $which grandchild");
40
41     my $message = "grandchild waited until '$how'";
42     my $min_getppid_result = is_linux_container() ? 0 : 1;
43         cmp_ok ($second, '>=', $min_getppid_result, "New parent of orphaned $which grandchild")
44             ? note ($message) : diag ($message);
45
46         SKIP: {
47             skip("Orphan processes are not reparented on QNX", 1)
48                 if $^O eq 'nto';
49             isnt($first, $second,
50                  "Orphaned $which grandchild got a new parent");
51         }
52         return $second;
53     }
54     else {
55         # child
56         # Prevent test.pl from thinking that we failed to run any tests.
57         $::NO_ENDING = 1;
58         close $r or die "close: $!\n";
59
60         pipe my ($r2, $w2) or die "pipe: $!\n";
61         pipe my ($r3, $w3) or die "pipe: $!\n";
62         my $pid2 = fork; defined $pid2 or die "fork: $!\n";
63         if ($pid2) {
64             close $w or die "close: $!\n";
65             close $w2 or die "close: $!\n";
66             close $r3 or die "close: $!\n";
67             # Wait for our child to signal that it's read our PID:
68             <$r2>;
69             # Implicit close of $w3:
70             exit 0;
71         }
72         else {
73             # grandchild
74             close $r2 or die "close: $!\n";
75             close $w3 or die "close: $!\n";
76             my $ppid1 = getppid();
77             # kill 0 isn't portable:
78             my $can_kill0 = eval {
79                 kill 0, $ppid1;
80             };
81             my $how = $can_kill0 ? 'undead' : 'sleep';
82
83             # Tell immediate parent to exit:
84             close $w2 or die "close: $!\n";
85             # Wait for it to (start to) exit:
86             <$r3>;
87             # Which sadly isn't enough to be sure that it has exited - often we
88             # get switched in during its shutdown, after $w3 closes but before
89             # it exits and we get reparented.
90             if ($can_kill0) {
91                 # use kill 0 where possible. Try 10 times, then give up:
92                 for (0..9) {
93                     my $got = kill 0, $ppid1;
94                     die "kill: $!" unless defined $got;
95                     if (!$got) {
96                         $how = 'kill';
97                         last;
98                     }
99                     sleep 1;
100                 }
101             } else {
102                 # Fudge it by waiting a bit more:
103                 sleep 2;
104             }
105             my $ppid2 = getppid();
106             print $w "$how,$ppid1,$ppid2\n";
107         }
108         exit 0;
109     }
110 }
111
112 my $first = fork_and_retrieve("first");
113 my $second = fork_and_retrieve("second");
114 SKIP: {
115     skip ("Orphan processes are not reparented on QNX", 1) if $^O eq 'nto';
116     is ($first, $second, "Both orphaned grandchildren get the same new parent");
117 }
118 isnt ($first, $$, "And that new parent isn't this process");
119