Commit | Line | Data |
---|---|---|
abf9167d DM |
1 | #!./perl |
2 | ||
3 | # If a read or write is interrupted by a signal, Perl will call the | |
4 | # signal handler and then attempt to restart the call. If the handler does | |
5 | # something nasty like close the handle or pop layers, make sure that the | |
6 | # read/write handles this gracefully (for some definition of 'graceful': | |
7 | # principally, don't segfault). | |
8 | ||
9 | BEGIN { | |
10 | chdir 't' if -d 't'; | |
785259d9 | 11 | require './test.pl'; |
624c42e2 | 12 | set_up_inc('../lib'); |
5bfb366f | 13 | skip_all_without_dynamic_extension('Fcntl'); |
abf9167d DM |
14 | } |
15 | ||
16 | use warnings; | |
17 | use strict; | |
18 | use Config; | |
19 | ||
abf9167d DM |
20 | my $piped; |
21 | eval { | |
22 | pipe my $in, my $out; | |
23 | $piped = 1; | |
24 | }; | |
25 | if (!$piped) { | |
26 | skip_all('pipe not implemented'); | |
27 | exit 0; | |
28 | } | |
29 | unless (exists $Config{'d_alarm'}) { | |
30 | skip_all('alarm not implemented'); | |
31 | exit 0; | |
32 | } | |
33 | ||
34 | # XXX for some reason the stdio layer doesn't seem to interrupt | |
35 | # write system call when the alarm triggers. This makes the tests | |
36 | # hang. | |
37 | ||
38 | if (exists $ENV{PERLIO} && $ENV{PERLIO} =~ /stdio/ ) { | |
39 | skip_all('stdio not supported for this script'); | |
40 | exit 0; | |
41 | } | |
42 | ||
f5122dbf DM |
43 | # on Win32, alarm() won't interrupt the read/write call. |
44 | # Similar issues with VMS. | |
c81114d2 CB |
45 | # On FreeBSD, writes to pipes of 8192 bytes or more use a mechanism |
46 | # that is not interruptible (see perl #85842 and #84688). | |
400666af | 47 | # "close during print" also hangs on Solaris 8 (but not 10 or 11). |
1d0853ff DM |
48 | # |
49 | # Also skip on release builds, to avoid other possibly problematic | |
50 | # platforms | |
51 | ||
f24e984e | 52 | my ($osmajmin) = $Config{osvers} =~ /^(\d+\.\d+)/; |
46ad546a | 53 | if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'cygwin' || $^O =~ /freebsd/ || $^O eq 'midnightbsd' || |
4a408539 | 54 | ($^O eq 'solaris' && $Config{osvers} eq '2.8') || $^O eq 'nto' || |
f24e984e JK |
55 | ($^O eq 'darwin' && $osmajmin < 9) || |
56 | ((int($]*1000) & 1) == 0) | |
1d0853ff DM |
57 | ) { |
58 | skip_all('various portability issues'); | |
59 | exit 0; | |
603928ea CB |
60 | } |
61 | ||
db55b517 A |
62 | |
63 | ||
abf9167d DM |
64 | my ($in, $out, $st, $sigst, $buf); |
65 | ||
66 | plan(tests => 10); | |
67 | ||
68 | ||
69 | # make two handles that will always block | |
70 | ||
71 | sub fresh_io { | |
96d7c888 | 72 | close $in if $in; close $out if $out; |
abf9167d DM |
73 | undef $in; undef $out; # use fresh handles each time |
74 | pipe $in, $out; | |
75 | $sigst = ""; | |
76 | } | |
77 | ||
78 | $SIG{PIPE} = 'IGNORE'; | |
79 | ||
80 | # close during read | |
81 | ||
82 | fresh_io; | |
83 | $SIG{ALRM} = sub { $sigst = close($in) ? "ok" : "nok" }; | |
84 | alarm(1); | |
85 | $st = read($in, $buf, 1); | |
86 | alarm(0); | |
87 | is($sigst, 'ok', 'read/close: sig handler close status'); | |
88 | ok(!$st, 'read/close: read status'); | |
89 | ok(!close($in), 'read/close: close status'); | |
90 | ||
91 | # die during read | |
92 | ||
93 | fresh_io; | |
94 | $SIG{ALRM} = sub { die }; | |
95 | alarm(1); | |
96 | $st = eval { read($in, $buf, 1) }; | |
97 | alarm(0); | |
98 | ok(!$st, 'read/die: read status'); | |
99 | ok(close($in), 'read/die: close status'); | |
100 | ||
db55b517 A |
101 | SKIP: { |
102 | skip "Tests hang on older versions of Darwin", 5 | |
103 | if $^O eq 'darwin' && $osmajmin < 16; | |
104 | ||
105 | # This used to be 1_000_000, but on Linux/ppc64 (POWER7) this kept | |
106 | # consistently failing. At exactly 0x100000 it started passing | |
107 | # again. Now we're asking the kernel what the pipe buffer is, and if | |
108 | # that fails, hoping this number is bigger than any pipe buffer. | |
109 | my $surely_this_arbitrary_number_is_fine = (eval { | |
110 | use Fcntl qw(F_GETPIPE_SZ); | |
111 | fcntl($out, F_GETPIPE_SZ, 0); | |
112 | } || 0xfffff) + 1; | |
113 | ||
114 | # close during print | |
115 | ||
116 | fresh_io; | |
117 | $SIG{ALRM} = sub { $sigst = close($out) ? "ok" : "nok" }; | |
118 | $buf = "a" x $surely_this_arbitrary_number_is_fine . "\n"; | |
119 | select $out; $| = 1; select STDOUT; | |
120 | alarm(1); | |
121 | $st = print $out $buf; | |
122 | alarm(0); | |
123 | is($sigst, 'nok', 'print/close: sig handler close status'); | |
124 | ok(!$st, 'print/close: print status'); | |
125 | ok(!close($out), 'print/close: close status'); | |
126 | ||
127 | # die during print | |
128 | ||
129 | fresh_io; | |
130 | $SIG{ALRM} = sub { die }; | |
131 | $buf = "a" x $surely_this_arbitrary_number_is_fine . "\n"; | |
132 | select $out; $| = 1; select STDOUT; | |
133 | alarm(1); | |
134 | $st = eval { print $out $buf }; | |
135 | alarm(0); | |
136 | ok(!$st, 'print/die: print status'); | |
137 | # the close will hang since there's data to flush, so use alarm | |
138 | alarm(1); | |
139 | ok(!eval {close($out)}, 'print/die: close status'); | |
140 | alarm(0); | |
141 | ||
142 | # close during close | |
143 | ||
144 | # Apparently there's nothing in standard Linux that can cause an | |
145 | # EINTR in close(2); but run the code below just in case it does on some | |
146 | # platform, just to see if it segfaults. | |
147 | fresh_io; | |
148 | $SIG{ALRM} = sub { $sigst = close($in) ? "ok" : "nok" }; | |
149 | alarm(1); | |
150 | close $in; | |
151 | alarm(0); | |
152 | ||
153 | # die during close | |
154 | ||
155 | fresh_io; | |
156 | $SIG{ALRM} = sub { die }; | |
157 | alarm(1); | |
158 | eval { close $in }; | |
159 | alarm(0); | |
160 | } | |
abf9167d DM |
161 | |
162 | # vim: ts=4 sts=4 sw=4: |