This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Merge ext/IPC-Open2 into ext/IPC-Open3.
[perl5.git] / t / io / eintr.t
CommitLineData
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
9BEGIN {
10 chdir 't' if -d 't';
11 @INC = '../lib';
12}
13
14use warnings;
15use strict;
16use Config;
17
18require './test.pl';
19
20my $piped;
21eval {
22 pipe my $in, my $out;
23 $piped = 1;
24};
25if (!$piped) {
26 skip_all('pipe not implemented');
27 exit 0;
28}
29unless (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
38if (exists $ENV{PERLIO} && $ENV{PERLIO} =~ /stdio/ ) {
39 skip_all('stdio not supported for this script');
40 exit 0;
41}
42
df375c6d
DM
43# Determine whether this platform seems to support interruptible syscalls.
44#
f5122dbf
DM
45# on Win32, alarm() won't interrupt the read/write call.
46# Similar issues with VMS.
c81114d2
CB
47# On FreeBSD, writes to pipes of 8192 bytes or more use a mechanism
48# that is not interruptible (see perl #85842 and #84688).
400666af 49# "close during print" also hangs on Solaris 8 (but not 10 or 11).
df375c6d
DM
50
51{
52 my $pipe;
6e59d93a 53 note("checking for read interruptibility...");
df375c6d
DM
54 my $pid = eval { open($pipe, '-|') };
55 unless (defined $pid) {
56 skip_all("can't do -| open");
57 exit 0;
58 }
59 unless ($pid) {
60 #child
61 sleep 3;
62 close $pipe;
63 exit 0;
64 }
65
66 # parent
67
68 my $intr = 0;
69 $SIG{ALRM} = sub { $intr = 1 };
70 alarm(1);
71
72 my $x = <$pipe>;
73
74 unless ($intr) {
75 skip_all("reads aren't interruptible");
76 exit 0;
77 }
78 alarm(0);
6e59d93a
DM
79
80 $SIG{PIPE} = 'IGNORE';
81
82 note("checking for write interruptibility...");
83 $pid = eval { open($pipe, '|-') };
84 unless (defined $pid) {
85 skip_all("can't do |- open");
86 exit 0;
87 }
88 unless ($pid) {
89 #child
90 sleep 3;
91 close $pipe;
92 exit 0;
93 }
94
95 # parent
96
97 $intr = 0;
98 my $buf = "a" x 1_000_000 . "\n"; # bigger than any pipe buffer hopefully
99 alarm(1);
100 $x = print $pipe $buf;
101
102 unless ($intr) {
103 skip_all("writes aren't interruptible");
104 exit 0;
105 }
106 alarm(0);
603928ea
CB
107}
108
df375c6d 109
abf9167d
DM
110my ($in, $out, $st, $sigst, $buf);
111
112plan(tests => 10);
113
114
115# make two handles that will always block
116
117sub fresh_io {
118 undef $in; undef $out; # use fresh handles each time
119 pipe $in, $out;
120 $sigst = "";
121}
122
123$SIG{PIPE} = 'IGNORE';
124
125# close during read
126
127fresh_io;
128$SIG{ALRM} = sub { $sigst = close($in) ? "ok" : "nok" };
129alarm(1);
130$st = read($in, $buf, 1);
131alarm(0);
132is($sigst, 'ok', 'read/close: sig handler close status');
133ok(!$st, 'read/close: read status');
134ok(!close($in), 'read/close: close status');
135
136# die during read
137
138fresh_io;
139$SIG{ALRM} = sub { die };
140alarm(1);
141$st = eval { read($in, $buf, 1) };
142alarm(0);
143ok(!$st, 'read/die: read status');
144ok(close($in), 'read/die: close status');
145
146# close during print
147
148fresh_io;
149$SIG{ALRM} = sub { $sigst = close($out) ? "ok" : "nok" };
150$buf = "a" x 1_000_000 . "\n"; # bigger than any pipe buffer hopefully
151select $out; $| = 1; select STDOUT;
152alarm(1);
153$st = print $out $buf;
154alarm(0);
155is($sigst, 'nok', 'print/close: sig handler close status');
156ok(!$st, 'print/close: print status');
157ok(!close($out), 'print/close: close status');
158
159# die during print
160
161fresh_io;
162$SIG{ALRM} = sub { die };
163$buf = "a" x 1_000_000 . "\n"; # bigger than any pipe buffer hopefully
164select $out; $| = 1; select STDOUT;
165alarm(1);
166$st = eval { print $out $buf };
167alarm(0);
168ok(!$st, 'print/die: print status');
169# the close will hang since there's data to flush, so use alarm
170alarm(1);
171ok(!eval {close($out)}, 'print/die: close status');
172alarm(0);
173
174# close during close
175
176# Apparently there's nothing in standard Linux that can cause an
177# EINTR in close(2); but run the code below just in case it does on some
178# platform, just to see if it segfaults.
179fresh_io;
180$SIG{ALRM} = sub { $sigst = close($in) ? "ok" : "nok" };
181alarm(1);
182close $in;
183alarm(0);
184
185# die during close
186
187fresh_io;
188$SIG{ALRM} = sub { die };
189alarm(1);
190eval { close $in };
191alarm(0);
192
193# vim: ts=4 sts=4 sw=4: