This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: the new t/run/cloexec.t failing in Solaris and Tru64
[perl5.git] / t / run / cloexec.t
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
35 BEGIN {
36     chdir 't' if -d 't';
37     @INC = '../lib';
38     use Config;
39     if (!$Config{'d_fcntl'}) {
40         print("1..0 # Skip: fcntl() is not available\n");
41         exit(0);
42     }
43     require './test.pl';
44 }
45
46 use strict;
47
48 $|=1;
49
50 my $Is_VMS      = $^O eq 'VMS';
51 my $Is_MacOS    = $^O eq 'MacOS';
52 my $Is_Win32    = $^O eq 'MSWin32';
53 my $Is_Cygwin   = $^O eq 'cygwin';
54
55 # When in doubt, skip.
56 skip_all("MacOS")    if $Is_MacOS;
57 skip_all("VMS")      if $Is_VMS;
58 skip_all("cygwin")   if $Is_Cygwin;
59 skip_all("Win32")    if $Is_Win32;
60
61 sub make_tmp_file {
62     my ($fname, $fcontents) = @_;
63     local *FHTMP;
64     open   FHTMP, ">$fname"  or die "open  '$fname': $!";
65     print  FHTMP $fcontents  or die "print '$fname': $!";
66     close  FHTMP             or die "close '$fname': $!";
67 }
68
69 my $Perl = which_perl();
70 my $quote = $Is_VMS || $Is_Win32 ? '"' : "'";
71
72 my $tmperr             = 'cloexece.tmp';
73 my $tmpfile1           = 'cloexec1.tmp';
74 my $tmpfile2           = 'cloexec2.tmp';
75 my $tmpfile1_contents  = "tmpfile1 line 1\ntmpfile1 line 2\n";
76 my $tmpfile2_contents  = "tmpfile2 line 1\ntmpfile2 line 2\n";
77 make_tmp_file($tmpfile1, $tmpfile1_contents);
78 make_tmp_file($tmpfile2, $tmpfile2_contents);
79
80 # $Child_prog is the program run by the child that inherits the fd.
81 # Note: avoid using ' or " in $Child_prog since it is run with -e
82 my $Child_prog = <<'CHILD_PROG';
83 my $fd = shift;
84 print qq{childfd=$fd\n};
85 open INHERIT, qq{<&=$fd} or die qq{open $fd: $!};
86 my $line = <INHERIT>;
87 close INHERIT or die qq{close $fd: $!};
88 print $line
89 CHILD_PROG
90 $Child_prog =~ tr/\n//d;
91
92 plan(tests => 22);
93
94 sub test_not_inherited {
95     my $expected_fd = shift;
96     ok( -f $tmpfile2, "tmpfile '$tmpfile2' exists" );
97     my $cmd = qq{$Perl -e $quote$Child_prog$quote $expected_fd};
98     # Expect 'Bad file descriptor' or similar to be written to STDERR.
99     local *SAVERR; open SAVERR, ">&STDERR";  # save original STDERR
100     open STDERR, ">$tmperr" or die "open '$tmperr': $!";
101     my $out = `$cmd`;
102     my $rc  = $? >> 8;
103     open STDERR, ">&SAVERR" or die "error: restore STDERR: $!";
104     close SAVERR or die "error: close SAVERR: $!";
105     # XXX: it seems one cannot rely on a non-zero return code,
106     # at least not on Tru64.
107     # cmp_ok( $rc, '!=', 0,
108     #     "child return code=$rc (non-zero means cannot inherit fd=$expected_fd)" );
109     cmp_ok( $out =~ tr/\n//, '==', 1,
110         "child stdout: has 1 newline (rc=$rc, should be non-zero)" );
111     is( $out, "childfd=$expected_fd\n", 'child stdout: fd' );
112 }
113
114 sub test_inherited {
115     my $expected_fd = shift;
116     ok( -f $tmpfile1, "tmpfile '$tmpfile1' exists" );
117     my $cmd = qq{$Perl -e $quote$Child_prog$quote $expected_fd};
118     my $out = `$cmd`;
119     my $rc  = $? >> 8;
120     cmp_ok( $rc, '==', 0,
121         "child return code=$rc (zero means inherited fd=$expected_fd ok)" );
122     my @lines = split(/^/, $out);
123     cmp_ok( $out =~ tr/\n//, '==', 2, 'child stdout: has 2 newlines' );
124     cmp_ok( scalar(@lines),  '==', 2, 'child stdout: split into 2 lines' );
125     is( $lines[0], "childfd=$expected_fd\n", 'child stdout: fd' );
126     is( $lines[1], "tmpfile1 line 1\n",      'child stdout: line 1' );
127 }
128
129 $^F == 2 or print STDERR "# warning: \$^F is $^F (not 2)\n";
130
131 # Should not be able to inherit > $^F in the default case.
132 open FHPARENT2, "<$tmpfile2" or die "open '$tmpfile2': $!";
133 my $parentfd2 = fileno FHPARENT2;
134 defined $parentfd2 or die "fileno: $!";
135 cmp_ok( $parentfd2, '>', $^F, "parent open fd=$parentfd2 (\$^F=$^F)" );
136 test_not_inherited($parentfd2);
137 close FHPARENT2 or die "close '$tmpfile2': $!";
138
139 # Should be able to inherit $^F after setting to $parentfd2
140 # Need to set $^F before open because close-on-exec set at time of open.
141 $^F = $parentfd2;
142 open FHPARENT1, "<$tmpfile1" or die "open '$tmpfile1': $!";
143 my $parentfd1 = fileno FHPARENT1;
144 defined $parentfd1 or die "fileno: $!";
145 cmp_ok( $parentfd1, '<=', $^F, "parent open fd=$parentfd1 (\$^F=$^F)" );
146 test_inherited($parentfd1);
147 close FHPARENT1 or die "close '$tmpfile1': $!";
148
149 # ... and test that you cannot inherit fd = $^F+1.
150 open FHPARENT1, "<$tmpfile1" or die "open '$tmpfile1': $!";
151 open FHPARENT2, "<$tmpfile2" or die "open '$tmpfile2': $!";
152 $parentfd2 = fileno FHPARENT2;
153 defined $parentfd2 or die "fileno: $!";
154 cmp_ok( $parentfd2, '>', $^F, "parent open fd=$parentfd2 (\$^F=$^F)" );
155 test_not_inherited($parentfd2);
156 close FHPARENT2 or die "close '$tmpfile2': $!";
157 close FHPARENT1 or die "close '$tmpfile1': $!";
158
159 # ... and now you can inherit after incrementing.
160 ++$^F;
161 open FHPARENT2, "<$tmpfile2" or die "open '$tmpfile2': $!";
162 open FHPARENT1, "<$tmpfile1" or die "open '$tmpfile1': $!";
163 $parentfd1 = fileno FHPARENT1;
164 defined $parentfd1 or die "fileno: $!";
165 cmp_ok( $parentfd1, '<=', $^F, "parent open fd=$parentfd1 (\$^F=$^F)" );
166 test_inherited($parentfd1);
167 close FHPARENT1 or die "close '$tmpfile1': $!";
168 close FHPARENT2 or die "close '$tmpfile2': $!";
169
170 END {
171     defined $tmperr   and unlink($tmperr);
172     defined $tmpfile1 and unlink($tmpfile1);
173     defined $tmpfile2 and unlink($tmpfile2);
174 }