This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Make utf8::encode respect magic
[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
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
e683222a 52if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'cygwin' || $^O =~ /freebsd/ ||
1d0853ff
DM
53 ($^O eq 'solaris' && $Config{osvers} eq '2.8')
54 || ((int($]*1000) & 1) == 0)
55) {
56 skip_all('various portability issues');
57 exit 0;
603928ea
CB
58}
59
abf9167d
DM
60my ($in, $out, $st, $sigst, $buf);
61
62plan(tests => 10);
63
64
65# make two handles that will always block
66
67sub 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
77fresh_io;
78$SIG{ALRM} = sub { $sigst = close($in) ? "ok" : "nok" };
79alarm(1);
80$st = read($in, $buf, 1);
81alarm(0);
82is($sigst, 'ok', 'read/close: sig handler close status');
83ok(!$st, 'read/close: read status');
84ok(!close($in), 'read/close: close status');
85
86# die during read
87
88fresh_io;
89$SIG{ALRM} = sub { die };
90alarm(1);
91$st = eval { read($in, $buf, 1) };
92alarm(0);
93ok(!$st, 'read/die: read status');
94ok(close($in), 'read/die: close status');
95
96# close during print
97
98fresh_io;
99$SIG{ALRM} = sub { $sigst = close($out) ? "ok" : "nok" };
100$buf = "a" x 1_000_000 . "\n"; # bigger than any pipe buffer hopefully
101select $out; $| = 1; select STDOUT;
102alarm(1);
103$st = print $out $buf;
104alarm(0);
105is($sigst, 'nok', 'print/close: sig handler close status');
106ok(!$st, 'print/close: print status');
107ok(!close($out), 'print/close: close status');
108
109# die during print
110
111fresh_io;
112$SIG{ALRM} = sub { die };
113$buf = "a" x 1_000_000 . "\n"; # bigger than any pipe buffer hopefully
114select $out; $| = 1; select STDOUT;
115alarm(1);
116$st = eval { print $out $buf };
117alarm(0);
118ok(!$st, 'print/die: print status');
119# the close will hang since there's data to flush, so use alarm
120alarm(1);
121ok(!eval {close($out)}, 'print/die: close status');
122alarm(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.
129fresh_io;
130$SIG{ALRM} = sub { $sigst = close($in) ? "ok" : "nok" };
131alarm(1);
132close $in;
133alarm(0);
134
135# die during close
136
137fresh_io;
138$SIG{ALRM} = sub { die };
139alarm(1);
140eval { close $in };
141alarm(0);
142
143# vim: ts=4 sts=4 sw=4: