1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
|
#!./perl
# If a read or write is interrupted by a signal, Perl will call the
# signal handler and then attempt to restart the call. If the handler does
# something nasty like close the handle or pop layers, make sure that the
# read/write handles this gracefully (for some definition of 'graceful':
# principally, don't segfault).
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
use warnings;
use strict;
use Config;
require './test.pl';
my $piped;
eval {
pipe my $in, my $out;
$piped = 1;
};
if (!$piped) {
skip_all('pipe not implemented');
exit 0;
}
unless (exists $Config{'d_alarm'}) {
skip_all('alarm not implemented');
exit 0;
}
# XXX for some reason the stdio layer doesn't seem to interrupt
# write system call when the alarm triggers. This makes the tests
# hang.
if (exists $ENV{PERLIO} && $ENV{PERLIO} =~ /stdio/ ) {
skip_all('stdio not supported for this script');
exit 0;
}
# on Win32, alarm() won't interrupt the read/write call.
# Similar issues with VMS.
# On FreeBSD, writes to pipes of 8192 bytes or more use a mechanism
# that is not interruptible (see perl #85842 and #84688).
# "close during print" also hangs on Solaris 8 (but not 10 or 11).
#
# Also skip on release builds, to avoid other possibly problematic
# platforms
if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'cygwin' || $^O eq 'freebsd' ||
($^O eq 'solaris' && $Config{osvers} eq '2.8')
|| ((int($]*1000) & 1) == 0)
) {
skip_all('various portability issues');
exit 0;
}
my ($in, $out, $st, $sigst, $buf);
plan(tests => 10);
# make two handles that will always block
sub fresh_io {
undef $in; undef $out; # use fresh handles each time
pipe $in, $out;
$sigst = "";
}
$SIG{PIPE} = 'IGNORE';
# close during read
fresh_io;
$SIG{ALRM} = sub { $sigst = close($in) ? "ok" : "nok" };
alarm(1);
$st = read($in, $buf, 1);
alarm(0);
is($sigst, 'ok', 'read/close: sig handler close status');
ok(!$st, 'read/close: read status');
ok(!close($in), 'read/close: close status');
# die during read
fresh_io;
$SIG{ALRM} = sub { die };
alarm(1);
$st = eval { read($in, $buf, 1) };
alarm(0);
ok(!$st, 'read/die: read status');
ok(close($in), 'read/die: close status');
# close during print
fresh_io;
$SIG{ALRM} = sub { $sigst = close($out) ? "ok" : "nok" };
$buf = "a" x 1_000_000 . "\n"; # bigger than any pipe buffer hopefully
select $out; $| = 1; select STDOUT;
alarm(1);
$st = print $out $buf;
alarm(0);
is($sigst, 'nok', 'print/close: sig handler close status');
ok(!$st, 'print/close: print status');
ok(!close($out), 'print/close: close status');
# die during print
fresh_io;
$SIG{ALRM} = sub { die };
$buf = "a" x 1_000_000 . "\n"; # bigger than any pipe buffer hopefully
select $out; $| = 1; select STDOUT;
alarm(1);
$st = eval { print $out $buf };
alarm(0);
ok(!$st, 'print/die: print status');
# the close will hang since there's data to flush, so use alarm
alarm(1);
ok(!eval {close($out)}, 'print/die: close status');
alarm(0);
# close during close
# Apparently there's nothing in standard Linux that can cause an
# EINTR in close(2); but run the code below just in case it does on some
# platform, just to see if it segfaults.
fresh_io;
$SIG{ALRM} = sub { $sigst = close($in) ? "ok" : "nok" };
alarm(1);
close $in;
alarm(0);
# die during close
fresh_io;
$SIG{ALRM} = sub { die };
alarm(1);
eval { close $in };
alarm(0);
# vim: ts=4 sts=4 sw=4:
|
