3 # Test inheriting file descriptors across exec (close-on-exec).
5 # perlvar describes $^F aka $SYSTEM_FD_MAX as follows:
7 # The maximum system file descriptor, ordinarily 2. System file
8 # descriptors are passed to exec()ed processes, while higher file
9 # descriptors are not. Also, during an open(), system file descriptors
10 # are preserved even if the open() fails. (Ordinary file descriptors
11 # are closed before the open() is attempted.) The close-on-exec
12 # status of a file descriptor will be decided according to the value of
13 # C<$^F> when the corresponding file, pipe, or socket was opened, not
14 # the time of the exec().
16 # This documented close-on-exec behaviour is typically implemented in
17 # various places (e.g. pp_sys.c) with code something like:
19 # #if defined(HAS_FCNTL) && defined(F_SETFD)
20 # fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
23 # This behaviour, therefore, is only currently implemented for platforms
26 # a) HAS_FCNTL and F_SETFD are both defined
27 # b) Integer fds are native OS handles
29 # ... which is typically just the Unix-like platforms.
31 # Notice that though integer fds are supported by the C runtime library
32 # on Windows, they are not native OS handles, and so are not inherited
33 # across an exec (though native Windows file handles are).
39 skip_all_without_config('d_fcntl');
46 my $Is_VMS = $^O eq 'VMS';
47 my $Is_Win32 = $^O eq 'MSWin32';
49 # When in doubt, skip.
50 skip_all("VMS") if $Is_VMS;
51 skip_all("Win32") if $Is_Win32;
54 my ($fname, $fcontents) = @_;
56 open FHTMP, ">$fname" or die "open '$fname': $!";
57 print FHTMP $fcontents or die "print '$fname': $!";
58 close FHTMP or die "close '$fname': $!";
61 my $Perl = which_perl();
62 my $quote = $Is_VMS || $Is_Win32 ? '"' : "'";
64 my $tmperr = tempfile();
65 my $tmpfile1 = tempfile();
66 my $tmpfile2 = tempfile();
67 my $tmpfile1_contents = "tmpfile1 line 1\ntmpfile1 line 2\n";
68 my $tmpfile2_contents = "tmpfile2 line 1\ntmpfile2 line 2\n";
69 make_tmp_file($tmpfile1, $tmpfile1_contents);
70 make_tmp_file($tmpfile2, $tmpfile2_contents);
72 # $Child_prog is the program run by the child that inherits the fd.
73 # Note: avoid using ' or " in $Child_prog since it is run with -e
74 my $Child_prog = <<'CHILD_PROG';
76 print qq{childfd=$fd\n};
77 open INHERIT, qq{<&=$fd} or die qq{open $fd: $!};
79 close INHERIT or die qq{close $fd: $!};
82 $Child_prog =~ tr/\n//d;
86 sub test_not_inherited {
87 my $expected_fd = shift;
88 ok( -f $tmpfile2, "tmpfile '$tmpfile2' exists" );
89 my $cmd = qq{$Perl -e $quote$Child_prog$quote $expected_fd};
90 # Expect 'Bad file descriptor' or similar to be written to STDERR.
91 local *SAVERR; open SAVERR, ">&STDERR"; # save original STDERR
92 open STDERR, ">$tmperr" or die "open '$tmperr': $!";
95 open STDERR, ">&SAVERR" or die "error: restore STDERR: $!";
96 close SAVERR or die "error: close SAVERR: $!";
97 # XXX: it seems one cannot rely on a non-zero return code,
98 # at least not on Tru64.
99 # cmp_ok( $rc, '!=', 0,
100 # "child return code=$rc (non-zero means cannot inherit fd=$expected_fd)" );
101 cmp_ok( $out =~ tr/\n//, '==', 1,
102 "child stdout: has 1 newline (rc=$rc, should be non-zero)" );
103 is( $out, "childfd=$expected_fd\n", 'child stdout: fd' );
107 my $expected_fd = shift;
108 ok( -f $tmpfile1, "tmpfile '$tmpfile1' exists" );
109 my $cmd = qq{$Perl -e $quote$Child_prog$quote $expected_fd};
112 cmp_ok( $rc, '==', 0,
113 "child return code=$rc (zero means inherited fd=$expected_fd ok)" );
114 my @lines = split(/^/, $out);
115 cmp_ok( $out =~ tr/\n//, '==', 2, 'child stdout: has 2 newlines' );
116 cmp_ok( scalar(@lines), '==', 2, 'child stdout: split into 2 lines' );
117 is( $lines[0], "childfd=$expected_fd\n", 'child stdout: fd' );
118 is( $lines[1], "tmpfile1 line 1\n", 'child stdout: line 1' );
121 $^F == 2 or print STDERR "# warning: \$^F is $^F (not 2)\n";
123 # Should not be able to inherit > $^F in the default case.
124 open FHPARENT2, "<$tmpfile2" or die "open '$tmpfile2': $!";
125 my $parentfd2 = fileno FHPARENT2;
126 defined $parentfd2 or die "fileno: $!";
127 cmp_ok( $parentfd2, '>', $^F, "parent open fd=$parentfd2 (\$^F=$^F)" );
128 test_not_inherited($parentfd2);
129 close FHPARENT2 or die "close '$tmpfile2': $!";
131 # Should be able to inherit $^F after setting to $parentfd2
132 # Need to set $^F before open because close-on-exec set at time of open.
134 open FHPARENT1, "<$tmpfile1" or die "open '$tmpfile1': $!";
135 my $parentfd1 = fileno FHPARENT1;
136 defined $parentfd1 or die "fileno: $!";
137 cmp_ok( $parentfd1, '<=', $^F, "parent open fd=$parentfd1 (\$^F=$^F)" );
138 test_inherited($parentfd1);
139 close FHPARENT1 or die "close '$tmpfile1': $!";
141 # ... and test that you cannot inherit fd = $^F+n.
142 open FHPARENT1, "<$tmpfile1" or die "open '$tmpfile1': $!";
143 open FHPARENT2, "<$tmpfile2" or die "open '$tmpfile2': $!";
144 $parentfd2 = fileno FHPARENT2;
145 defined $parentfd2 or die "fileno: $!";
146 cmp_ok( $parentfd2, '>', $^F, "parent open fd=$parentfd2 (\$^F=$^F)" );
147 test_not_inherited($parentfd2);
148 close FHPARENT2 or die "close '$tmpfile2': $!";
149 close FHPARENT1 or die "close '$tmpfile1': $!";
151 # ... and now you can inherit after incrementing.
153 open FHPARENT2, "<$tmpfile2" or die "open '$tmpfile2': $!";
154 open FHPARENT1, "<$tmpfile1" or die "open '$tmpfile1': $!";
155 $parentfd1 = fileno FHPARENT1;
156 defined $parentfd1 or die "fileno: $!";
157 cmp_ok( $parentfd1, '<=', $^F, "parent open fd=$parentfd1 (\$^F=$^F)" );
158 test_inherited($parentfd1);
159 close FHPARENT1 or die "close '$tmpfile1': $!";
160 close FHPARENT2 or die "close '$tmpfile2': $!";