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