This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
eintr.t: skip based on capability rather than OS
[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;
53 my $pid = eval { open($pipe, '-|') };
54 unless (defined $pid) {
55 skip_all("can't do -| open");
56 exit 0;
57 }
58 unless ($pid) {
59 #child
60 sleep 3;
61 close $pipe;
62 exit 0;
63 }
64
65 # parent
66
67 my $intr = 0;
68 $SIG{ALRM} = sub { $intr = 1 };
69 alarm(1);
70
71 my $x = <$pipe>;
72
73 unless ($intr) {
74 skip_all("reads aren't interruptible");
75 exit 0;
76 }
77 alarm(0);
603928ea
CB
78}
79
df375c6d 80
abf9167d
DM
81my ($in, $out, $st, $sigst, $buf);
82
83plan(tests => 10);
84
85
86# make two handles that will always block
87
88sub fresh_io {
89 undef $in; undef $out; # use fresh handles each time
90 pipe $in, $out;
91 $sigst = "";
92}
93
94$SIG{PIPE} = 'IGNORE';
95
96# close during read
97
98fresh_io;
99$SIG{ALRM} = sub { $sigst = close($in) ? "ok" : "nok" };
100alarm(1);
101$st = read($in, $buf, 1);
102alarm(0);
103is($sigst, 'ok', 'read/close: sig handler close status');
104ok(!$st, 'read/close: read status');
105ok(!close($in), 'read/close: close status');
106
107# die during read
108
109fresh_io;
110$SIG{ALRM} = sub { die };
111alarm(1);
112$st = eval { read($in, $buf, 1) };
113alarm(0);
114ok(!$st, 'read/die: read status');
115ok(close($in), 'read/die: close status');
116
117# close during print
118
119fresh_io;
120$SIG{ALRM} = sub { $sigst = close($out) ? "ok" : "nok" };
121$buf = "a" x 1_000_000 . "\n"; # bigger than any pipe buffer hopefully
122select $out; $| = 1; select STDOUT;
123alarm(1);
124$st = print $out $buf;
125alarm(0);
126is($sigst, 'nok', 'print/close: sig handler close status');
127ok(!$st, 'print/close: print status');
128ok(!close($out), 'print/close: close status');
129
130# die during print
131
132fresh_io;
133$SIG{ALRM} = sub { die };
134$buf = "a" x 1_000_000 . "\n"; # bigger than any pipe buffer hopefully
135select $out; $| = 1; select STDOUT;
136alarm(1);
137$st = eval { print $out $buf };
138alarm(0);
139ok(!$st, 'print/die: print status');
140# the close will hang since there's data to flush, so use alarm
141alarm(1);
142ok(!eval {close($out)}, 'print/die: close status');
143alarm(0);
144
145# close during close
146
147# Apparently there's nothing in standard Linux that can cause an
148# EINTR in close(2); but run the code below just in case it does on some
149# platform, just to see if it segfaults.
150fresh_io;
151$SIG{ALRM} = sub { $sigst = close($in) ? "ok" : "nok" };
152alarm(1);
153close $in;
154alarm(0);
155
156# die during close
157
158fresh_io;
159$SIG{ALRM} = sub { die };
160alarm(1);
161eval { close $in };
162alarm(0);
163
164# vim: ts=4 sts=4 sw=4: