| 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 | require './test.pl'; |
| 12 | set_up_inc('../lib'); |
| 13 | skip_all_without_dynamic_extension('Fcntl'); |
| 14 | } |
| 15 | |
| 16 | use warnings; |
| 17 | use strict; |
| 18 | use Config; |
| 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 | # "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 | |
| 52 | my ($osmajmin) = $Config{osvers} =~ /^(\d+\.\d+)/; |
| 53 | if ($^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 | |
| 64 | my ($in, $out, $st, $sigst, $buf); |
| 65 | |
| 66 | plan(tests => 10); |
| 67 | |
| 68 | |
| 69 | # make two handles that will always block |
| 70 | |
| 71 | sub 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 | |
| 82 | fresh_io; |
| 83 | $SIG{ALRM} = sub { $sigst = close($in) ? "ok" : "nok" }; |
| 84 | alarm(1); |
| 85 | $st = read($in, $buf, 1); |
| 86 | alarm(0); |
| 87 | is($sigst, 'ok', 'read/close: sig handler close status'); |
| 88 | ok(!$st, 'read/close: read status'); |
| 89 | ok(!close($in), 'read/close: close status'); |
| 90 | |
| 91 | # die during read |
| 92 | |
| 93 | fresh_io; |
| 94 | $SIG{ALRM} = sub { die }; |
| 95 | alarm(1); |
| 96 | $st = eval { read($in, $buf, 1) }; |
| 97 | alarm(0); |
| 98 | ok(!$st, 'read/die: read status'); |
| 99 | ok(close($in), 'read/die: close status'); |
| 100 | |
| 101 | SKIP: { |
| 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: |