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