t/io/eintr.t

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