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