xref: /openbsd/gnu/usr.bin/perl/t/op/getppid.t (revision 5af055cd) 
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
10BEGIN {
11    chdir 't' if -d 't';
12    @INC = qw(../lib);
13}
14
15use strict;
16
17BEGIN {
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
26sub 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
109my $first = fork_and_retrieve("first");
110my $second = fork_and_retrieve("second");
111SKIP: {
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}
115isnt ($first, $$, "And that new parent isn't this process");
116