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
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
43 # Determine whether this platform seems to support interruptible syscalls.
44 #
45 # on Win32, alarm() won't interrupt the read/write call.
46 # Similar issues with VMS.
47 # On FreeBSD, writes to pipes of 8192 bytes or more use a mechanism
48 # that is not interruptible (see perl #85842 and #84688).
49 # "close during print" also hangs on Solaris 8 (but not 10 or 11).
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);
78 }
79
80
81 my ($in, $out, $st, $sigst, $buf);
82
83 plan(tests => 10);
84
85
86 # make two handles that will always block
87
88 sub 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
98 fresh_io;
99 $SIG{ALRM} = sub { $sigst = close($in) ? "ok" : "nok" };
100 alarm(1);
101 $st = read($in, $buf, 1);
102 alarm(0);
103 is($sigst, 'ok', 'read/close: sig handler close status');
104 ok(!$st, 'read/close: read status');
105 ok(!close($in), 'read/close: close status');
106
107 # die during read
108
109 fresh_io;
110 $SIG{ALRM} = sub { die };
111 alarm(1);
112 $st = eval { read($in, $buf, 1) };
113 alarm(0);
114 ok(!$st, 'read/die: read status');
115 ok(close($in), 'read/die: close status');
116
117 # close during print
118
119 fresh_io;
120 $SIG{ALRM} = sub { $sigst = close($out) ? "ok" : "nok" };
121 $buf = "a" x 1_000_000 . "\n"; # bigger than any pipe buffer hopefully
122 select $out; $| = 1; select STDOUT;
123 alarm(1);
124 $st = print $out $buf;
125 alarm(0);
126 is($sigst, 'nok', 'print/close: sig handler close status');
127 ok(!$st, 'print/close: print status');
128 ok(!close($out), 'print/close: close status');
129
130 # die during print
131
132 fresh_io;
133 $SIG{ALRM} = sub { die };
134 $buf = "a" x 1_000_000 . "\n"; # bigger than any pipe buffer hopefully
135 select $out; $| = 1; select STDOUT;
136 alarm(1);
137 $st = eval { print $out $buf };
138 alarm(0);
139 ok(!$st, 'print/die: print status');
140 # the close will hang since there's data to flush, so use alarm
141 alarm(1);
142 ok(!eval {close($out)}, 'print/die: close status');
143 alarm(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.
150 fresh_io;
151 $SIG{ALRM} = sub { $sigst = close($in) ? "ok" : "nok" };
152 alarm(1);
153 close $in;
154 alarm(0);
155
156 # die during close
157
158 fresh_io;
159 $SIG{ALRM} = sub { die };
160 alarm(1);
161 eval { close $in };
162 alarm(0);
163
164 # vim: ts=4 sts=4 sw=4: