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     @INC = '../lib';
  12 }
  13
  14 use warnings;
  15 use strict;
  16 use Config;
  17
  18 require './test.pl';
  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 my ($in, $out, $st, $sigst, $buf);
  44
  45 plan(tests => 10);
  46
  47
  48 # make two handles that will always block
  49
  50 sub fresh_io {
  51         undef $in; undef $out; # use fresh handles each time
  52         pipe $in, $out;
  53         $sigst = "";
  54 }
  55
  56 $SIG{PIPE} = 'IGNORE';
  57
  58 # close during read
  59
  60 fresh_io;
  61 $SIG{ALRM} = sub { $sigst = close($in) ? "ok" : "nok" };
  62 alarm(1);
  63 $st = read($in, $buf, 1);
  64 alarm(0);
  65 is($sigst, 'ok', 'read/close: sig handler close status');
  66 ok(!$st, 'read/close: read status');
  67 ok(!close($in), 'read/close: close status');
  68
  69 # die during read
  70
  71 fresh_io;
  72 $SIG{ALRM} = sub { die };
  73 alarm(1);
  74 $st = eval { read($in, $buf, 1) };
  75 alarm(0);
  76 ok(!$st, 'read/die: read status');
  77 ok(close($in), 'read/die: close status');
  78
  79 # close during print
  80
  81 fresh_io;
  82 $SIG{ALRM} = sub { $sigst = close($out) ? "ok" : "nok" };
  83 $buf = "a" x 1_000_000 . "\n"; # bigger than any pipe buffer hopefully
  84 select $out; $| = 1; select STDOUT;
  85 alarm(1);
  86 $st = print $out $buf;
  87 alarm(0);
  88 is($sigst, 'nok', 'print/close: sig handler close status');
  89 ok(!$st, 'print/close: print status');
  90 ok(!close($out), 'print/close: close status');
  91
  92 # die during print
  93
  94 fresh_io;
  95 $SIG{ALRM} = sub { die };
  96 $buf = "a" x 1_000_000 . "\n"; # bigger than any pipe buffer hopefully
  97 select $out; $| = 1; select STDOUT;
  98 alarm(1);
  99 $st = eval { print $out $buf };
 100 alarm(0);
 101 ok(!$st, 'print/die: print status');
 102 # the close will hang since there's data to flush, so use alarm
 103 alarm(1);
 104 ok(!eval {close($out)}, 'print/die: close status');
 105 alarm(0);
 106
 107 # close during close
 108
 109 # Apparently there's nothing in standard Linux that can cause an
 110 # EINTR in close(2); but run the code below just in case it does on some
 111 # platform, just to see if it segfaults.
 112 fresh_io;
 113 $SIG{ALRM} = sub { $sigst = close($in) ? "ok" : "nok" };
 114 alarm(1);
 115 close $in;
 116 alarm(0);
 117
 118 # die during close
 119
 120 fresh_io;
 121 $SIG{ALRM} = sub { die };
 122 alarm(1);
 123 eval { close $in };
 124 alarm(0);
 125
 126 # vim: ts=4 sts=4 sw=4: