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 @INC = '../lib'; 12} 13 14use warnings; 15use strict; 16use Config; 17 18require './test.pl'; 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 62my ($in, $out, $st, $sigst, $buf); 63 64plan(tests => 10); 65 66 67# make two handles that will always block 68 69sub fresh_io { 70 undef $in; undef $out; # use fresh handles each time 71 pipe $in, $out; 72 $sigst = ""; 73} 74 75$SIG{PIPE} = 'IGNORE'; 76 77# close during read 78 79fresh_io; 80$SIG{ALRM} = sub { $sigst = close($in) ? "ok" : "nok" }; 81alarm(1); 82$st = read($in, $buf, 1); 83alarm(0); 84is($sigst, 'ok', 'read/close: sig handler close status'); 85ok(!$st, 'read/close: read status'); 86ok(!close($in), 'read/close: close status'); 87 88# die during read 89 90fresh_io; 91$SIG{ALRM} = sub { die }; 92alarm(1); 93$st = eval { read($in, $buf, 1) }; 94alarm(0); 95ok(!$st, 'read/die: read status'); 96ok(close($in), 'read/die: close status'); 97 98# This used to be 1_000_000, but on Linux/ppc64 (POWER7) this kept 99# consistently failing. At exactly 0x100000 it started passing 100# again. We're hoping this number is bigger than any pipe buffer. 101my $surely_this_arbitrary_number_is_fine = 0x100000; 102 103# close during print 104 105fresh_io; 106$SIG{ALRM} = sub { $sigst = close($out) ? "ok" : "nok" }; 107$buf = "a" x $surely_this_arbitrary_number_is_fine . "\n"; 108select $out; $| = 1; select STDOUT; 109alarm(1); 110$st = print $out $buf; 111alarm(0); 112is($sigst, 'nok', 'print/close: sig handler close status'); 113ok(!$st, 'print/close: print status'); 114ok(!close($out), 'print/close: close status'); 115 116# die during print 117 118fresh_io; 119$SIG{ALRM} = sub { die }; 120$buf = "a" x $surely_this_arbitrary_number_is_fine . "\n"; 121select $out; $| = 1; select STDOUT; 122alarm(1); 123$st = eval { print $out $buf }; 124alarm(0); 125ok(!$st, 'print/die: print status'); 126# the close will hang since there's data to flush, so use alarm 127alarm(1); 128ok(!eval {close($out)}, 'print/die: close status'); 129alarm(0); 130 131# close during close 132 133# Apparently there's nothing in standard Linux that can cause an 134# EINTR in close(2); but run the code below just in case it does on some 135# platform, just to see if it segfaults. 136fresh_io; 137$SIG{ALRM} = sub { $sigst = close($in) ? "ok" : "nok" }; 138alarm(1); 139close $in; 140alarm(0); 141 142# die during close 143 144fresh_io; 145$SIG{ALRM} = sub { die }; 146alarm(1); 147eval { close $in }; 148alarm(0); 149 150# vim: ts=4 sts=4 sw=4: 151