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