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
|
#!./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.
if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'cygwin') {
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:
|
