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    require './test.pl';
12    set_up_inc('../lib');
13    skip_all_without_dynamic_extension('Fcntl');
14}
15
16use warnings;
17use strict;
18use Config;
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
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# "close during print" also hangs on Solaris 8 (but not 10 or 11).
48#
49# Also skip on release builds, to avoid other possibly problematic
50# platforms
51
52my ($osmajmin) = $Config{osvers} =~ /^(\d+\.\d+)/;
53if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'cygwin' || $^O =~ /freebsd/ || $^O eq 'midnightbsd' ||
54     ($^O eq 'solaris' && $Config{osvers} eq '2.8') || $^O eq 'nto' ||
55     ($^O eq 'darwin' && $osmajmin < 9) ||
56    ((int($]*1000) & 1) == 0)
57) {
58	skip_all('various portability issues');
59	exit 0;
60}
61
62
63
64my ($in, $out, $st, $sigst, $buf);
65
66plan(tests => 10);
67
68
69# make two handles that will always block
70
71sub fresh_io {
72	close $in if $in; close $out if $out;
73	undef $in; undef $out; # use fresh handles each time
74	pipe $in, $out;
75	$sigst = "";
76}
77
78$SIG{PIPE} = 'IGNORE';
79
80# close during read
81
82fresh_io;
83$SIG{ALRM} = sub { $sigst = close($in) ? "ok" : "nok" };
84alarm(1);
85$st = read($in, $buf, 1);
86alarm(0);
87is($sigst, 'ok', 'read/close: sig handler close status');
88ok(!$st, 'read/close: read status');
89ok(!close($in), 'read/close: close status');
90
91# die during read
92
93fresh_io;
94$SIG{ALRM} = sub { die };
95alarm(1);
96$st = eval { read($in, $buf, 1) };
97alarm(0);
98ok(!$st, 'read/die: read status');
99ok(close($in), 'read/die: close status');
100
101SKIP: {
102    skip "Tests hang on older versions of Darwin", 5
103          if $^O eq 'darwin' && $osmajmin < 16;
104
105    # This used to be 1_000_000, but on Linux/ppc64 (POWER7) this kept
106    # consistently failing. At exactly 0x100000 it started passing
107    # again. Now we're asking the kernel what the pipe buffer is, and if
108    # that fails, hoping this number is bigger than any pipe buffer.
109    my $surely_this_arbitrary_number_is_fine = (eval {
110        use Fcntl qw(F_GETPIPE_SZ);
111        fcntl($out, F_GETPIPE_SZ, 0);
112    } || 0xfffff) + 1;
113
114    # close during print
115
116    fresh_io;
117    $SIG{ALRM} = sub { $sigst = close($out) ? "ok" : "nok" };
118    $buf = "a" x $surely_this_arbitrary_number_is_fine . "\n";
119    select $out; $| = 1; select STDOUT;
120    alarm(1);
121    $st = print $out $buf;
122    alarm(0);
123    is($sigst, 'nok', 'print/close: sig handler close status');
124    ok(!$st, 'print/close: print status');
125    ok(!close($out), 'print/close: close status');
126
127    # die during print
128
129    fresh_io;
130    $SIG{ALRM} = sub { die };
131    $buf = "a" x $surely_this_arbitrary_number_is_fine . "\n";
132    select $out; $| = 1; select STDOUT;
133    alarm(1);
134    $st = eval { print $out $buf };
135    alarm(0);
136    ok(!$st, 'print/die: print status');
137    # the close will hang since there's data to flush, so use alarm
138    alarm(1);
139    ok(!eval {close($out)}, 'print/die: close status');
140    alarm(0);
141
142    # close during close
143
144    # Apparently there's nothing in standard Linux that can cause an
145    # EINTR in close(2); but run the code below just in case it does on some
146    # platform, just to see if it segfaults.
147    fresh_io;
148    $SIG{ALRM} = sub { $sigst = close($in) ? "ok" : "nok" };
149    alarm(1);
150    close $in;
151    alarm(0);
152
153    # die during close
154
155    fresh_io;
156    $SIG{ALRM} = sub { die };
157    alarm(1);
158    eval { close $in };
159    alarm(0);
160}
161
162# vim: ts=4 sts=4 sw=4:
163