1#!./perl
2#
3# Test inheriting file descriptors across exec (close-on-exec).
4#
5# perlvar describes $^F aka $SYSTEM_FD_MAX as follows:
6#
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().
15#
16# This documented close-on-exec behaviour is typically implemented in
17# various places (e.g. pp_sys.c) with code something like:
18#
19#  #if defined(HAS_FCNTL) && defined(F_SETFD)
20#      fcntl(fd, F_SETFD, fd > PL_maxsysfd);  /* ensure close-on-exec */
21#  #endif
22#
23# This behaviour, therefore, is only currently implemented for platforms
24# where:
25#
26#  a) HAS_FCNTL and F_SETFD are both defined
27#  b) Integer fds are native OS handles
28#
29# ... which is typically just the Unix-like platforms.
30#
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).
34
35BEGIN {
36    chdir 't' if -d 't';
37    @INC = '../lib';
38    require './test.pl';
39    skip_all_without_config('d_fcntl');
40}
41
42use strict;
43
44$|=1;
45
46# When in doubt, skip.
47skip_all($^O)
48    if $^O eq 'VMS' or $^O eq 'MSWin32' or $^O eq 'amigaos';
49
50sub make_tmp_file {
51    my ($fname, $fcontents) = @_;
52    local *FHTMP;
53    open   FHTMP, ">$fname"  or die "open  '$fname': $!";
54    print  FHTMP $fcontents  or die "print '$fname': $!";
55    close  FHTMP             or die "close '$fname': $!";
56}
57
58my $Perl = which_perl();
59my $quote = "'";
60
61my $tmperr             = tempfile();
62my $tmpfile1           = tempfile();
63my $tmpfile2           = tempfile();
64my $tmpfile1_contents  = "tmpfile1 line 1\ntmpfile1 line 2\n";
65my $tmpfile2_contents  = "tmpfile2 line 1\ntmpfile2 line 2\n";
66make_tmp_file($tmpfile1, $tmpfile1_contents);
67make_tmp_file($tmpfile2, $tmpfile2_contents);
68
69# $Child_prog is the program run by the child that inherits the fd.
70# Note: avoid using ' or " in $Child_prog since it is run with -e
71my $Child_prog = <<'CHILD_PROG';
72my $fd = shift;
73print qq{childfd=$fd\n};
74open INHERIT, qq{<&=$fd} or die qq{open $fd: $!};
75my $line = <INHERIT>;
76close INHERIT or die qq{close $fd: $!};
77print $line
78CHILD_PROG
79$Child_prog =~ tr/\n//d;
80
81plan(tests => 22);
82
83sub test_not_inherited {
84    my $expected_fd = shift;
85    ok( -f $tmpfile2, "tmpfile '$tmpfile2' exists" );
86    my $cmd = qq{$Perl -e $quote$Child_prog$quote $expected_fd};
87    # Expect 'Bad file descriptor' or similar to be written to STDERR.
88    local *SAVERR; open SAVERR, ">&STDERR";  # save original STDERR
89    open STDERR, ">$tmperr" or die "open '$tmperr': $!";
90    my $out = `$cmd`;
91    my $rc  = $? >> 8;
92    open STDERR, ">&SAVERR" or die "error: restore STDERR: $!";
93    close SAVERR or die "error: close SAVERR: $!";
94    # XXX: it seems one cannot rely on a non-zero return code,
95    # at least not on Tru64.
96    # cmp_ok( $rc, '!=', 0,
97    #     "child return code=$rc (non-zero means cannot inherit fd=$expected_fd)" );
98    cmp_ok( $out =~ tr/\n//, '==', 1,
99        "child stdout: has 1 newline (rc=$rc, should be non-zero)" );
100    is( $out, "childfd=$expected_fd\n", 'child stdout: fd' );
101}
102
103sub test_inherited {
104    my $expected_fd = shift;
105    ok( -f $tmpfile1, "tmpfile '$tmpfile1' exists" );
106    my $cmd = qq{$Perl -e $quote$Child_prog$quote $expected_fd};
107    my $out = `$cmd`;
108    my $rc  = $? >> 8;
109    cmp_ok( $rc, '==', 0,
110        "child return code=$rc (zero means inherited fd=$expected_fd ok)" );
111    my @lines = split(/^/, $out);
112    cmp_ok( $out =~ tr/\n//, '==', 2, 'child stdout: has 2 newlines' );
113    cmp_ok( scalar(@lines),  '==', 2, 'child stdout: split into 2 lines' );
114    is( $lines[0], "childfd=$expected_fd\n", 'child stdout: fd' );
115    is( $lines[1], "tmpfile1 line 1\n",      'child stdout: line 1' );
116}
117
118$^F == 2 or print STDERR "# warning: \$^F is $^F (not 2)\n";
119
120# Should not be able to inherit > $^F in the default case.
121open FHPARENT2, "<$tmpfile2" or die "open '$tmpfile2': $!";
122my $parentfd2 = fileno FHPARENT2;
123defined $parentfd2 or die "fileno: $!";
124cmp_ok( $parentfd2, '>', $^F, "parent open fd=$parentfd2 (\$^F=$^F)" );
125test_not_inherited($parentfd2);
126close FHPARENT2 or die "close '$tmpfile2': $!";
127
128# Should be able to inherit $^F after setting to $parentfd2
129# Need to set $^F before open because close-on-exec set at time of open.
130$^F = $parentfd2;
131open FHPARENT1, "<$tmpfile1" or die "open '$tmpfile1': $!";
132my $parentfd1 = fileno FHPARENT1;
133defined $parentfd1 or die "fileno: $!";
134cmp_ok( $parentfd1, '<=', $^F, "parent open fd=$parentfd1 (\$^F=$^F)" );
135test_inherited($parentfd1);
136close FHPARENT1 or die "close '$tmpfile1': $!";
137
138# ... and test that you cannot inherit fd = $^F+n.
139open FHPARENT1, "<$tmpfile1" or die "open '$tmpfile1': $!";
140open FHPARENT2, "<$tmpfile2" or die "open '$tmpfile2': $!";
141$parentfd2 = fileno FHPARENT2;
142defined $parentfd2 or die "fileno: $!";
143cmp_ok( $parentfd2, '>', $^F, "parent open fd=$parentfd2 (\$^F=$^F)" );
144test_not_inherited($parentfd2);
145close FHPARENT2 or die "close '$tmpfile2': $!";
146close FHPARENT1 or die "close '$tmpfile1': $!";
147
148# ... and now you can inherit after incrementing.
149$^F = $parentfd2;
150open FHPARENT2, "<$tmpfile2" or die "open '$tmpfile2': $!";
151open FHPARENT1, "<$tmpfile1" or die "open '$tmpfile1': $!";
152$parentfd1 = fileno FHPARENT1;
153defined $parentfd1 or die "fileno: $!";
154cmp_ok( $parentfd1, '<=', $^F, "parent open fd=$parentfd1 (\$^F=$^F)" );
155test_inherited($parentfd1);
156close FHPARENT1 or die "close '$tmpfile1': $!";
157close FHPARENT2 or die "close '$tmpfile2': $!";
158