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 13BEGIN { 14 chdir 't' if -d 't'; 15 require './test.pl'; 16 set_up_inc( qw(../lib) ); 17} 18 19use strict; 20 21skip_all_without_config(qw(d_pipe d_fork d_waitpid d_getppid)); 22plan (8); 23 24# No, we don't want any zombies. kill 0, $ppid spots zombies :-( 25$SIG{CHLD} = 'IGNORE'; 26 27sub 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 3; 104 } 105 my $ppid2 = getppid(); 106 print $w "$how,$ppid1,$ppid2\n"; 107 } 108 exit 0; 109 } 110} 111 112my $first = fork_and_retrieve("first"); 113my $second = fork_and_retrieve("second"); 114SKIP: { 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} 118isnt ($first, $$, "And that new parent isn't this process"); 119 120