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'; | |
11 | @INC = '../lib'; | |
12 | } | |
13 | ||
14 | use warnings; | |
15 | use strict; | |
16 | use Config; | |
17 | ||
18 | require './test.pl'; | |
19 | ||
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). |
a9e4bc69 DM |
48 | # |
49 | # Also skip on release builds, to avoid other possibly problematic | |
50 | # platforms | |
f5122dbf | 51 | |
d6a735e7 | 52 | if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'cygwin' || $^O eq 'freebsd' || |
a9e4bc69 DM |
53 | ($^O eq 'solaris' && $Config{osvers} eq '2.8') |
54 | || ((int($]*1000) & 1) == 0) | |
55 | ) { | |
603928ea CB |
56 | skip_all('various portability issues'); |
57 | exit 0; | |
58 | } | |
59 | ||
abf9167d DM |
60 | my ($in, $out, $st, $sigst, $buf); |
61 | ||
62 | plan(tests => 10); | |
63 | ||
64 | ||
65 | # make two handles that will always block | |
66 | ||
67 | sub fresh_io { | |
68 | undef $in; undef $out; # use fresh handles each time | |
69 | pipe $in, $out; | |
70 | $sigst = ""; | |
71 | } | |
72 | ||
73 | $SIG{PIPE} = 'IGNORE'; | |
74 | ||
75 | # close during read | |
76 | ||
77 | fresh_io; | |
78 | $SIG{ALRM} = sub { $sigst = close($in) ? "ok" : "nok" }; | |
79 | alarm(1); | |
80 | $st = read($in, $buf, 1); | |
81 | alarm(0); | |
82 | is($sigst, 'ok', 'read/close: sig handler close status'); | |
83 | ok(!$st, 'read/close: read status'); | |
84 | ok(!close($in), 'read/close: close status'); | |
85 | ||
86 | # die during read | |
87 | ||
88 | fresh_io; | |
89 | $SIG{ALRM} = sub { die }; | |
90 | alarm(1); | |
91 | $st = eval { read($in, $buf, 1) }; | |
92 | alarm(0); | |
93 | ok(!$st, 'read/die: read status'); | |
94 | ok(close($in), 'read/die: close status'); | |
95 | ||
96 | # close during print | |
97 | ||
98 | fresh_io; | |
99 | $SIG{ALRM} = sub { $sigst = close($out) ? "ok" : "nok" }; | |
100 | $buf = "a" x 1_000_000 . "\n"; # bigger than any pipe buffer hopefully | |
101 | select $out; $| = 1; select STDOUT; | |
102 | alarm(1); | |
103 | $st = print $out $buf; | |
104 | alarm(0); | |
105 | is($sigst, 'nok', 'print/close: sig handler close status'); | |
106 | ok(!$st, 'print/close: print status'); | |
107 | ok(!close($out), 'print/close: close status'); | |
108 | ||
109 | # die during print | |
110 | ||
111 | fresh_io; | |
112 | $SIG{ALRM} = sub { die }; | |
113 | $buf = "a" x 1_000_000 . "\n"; # bigger than any pipe buffer hopefully | |
114 | select $out; $| = 1; select STDOUT; | |
115 | alarm(1); | |
116 | $st = eval { print $out $buf }; | |
117 | alarm(0); | |
118 | ok(!$st, 'print/die: print status'); | |
119 | # the close will hang since there's data to flush, so use alarm | |
120 | alarm(1); | |
121 | ok(!eval {close($out)}, 'print/die: close status'); | |
122 | alarm(0); | |
123 | ||
124 | # close during close | |
125 | ||
126 | # Apparently there's nothing in standard Linux that can cause an | |
127 | # EINTR in close(2); but run the code below just in case it does on some | |
128 | # platform, just to see if it segfaults. | |
129 | fresh_io; | |
130 | $SIG{ALRM} = sub { $sigst = close($in) ? "ok" : "nok" }; | |
131 | alarm(1); | |
132 | close $in; | |
133 | alarm(0); | |
134 | ||
135 | # die during close | |
136 | ||
137 | fresh_io; | |
138 | $SIG{ALRM} = sub { die }; | |
139 | alarm(1); | |
140 | eval { close $in }; | |
141 | alarm(0); | |
142 | ||
143 | # vim: ts=4 sts=4 sw=4: |