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