mirror/perl
1
0
Fork 0
mirror of https://github.com/Perl/perl5.git synced 2026-01-26 08:38:23 +00:00
Code Issues Packages Projects Releases Wiki Activity

t/io/eintr.t: only show diag message on failure

Browse Source 
Also improve the error message by capturing the exception/error
returned by the `fnctl` call.
This commit is contained in:
Bram 2022-08-12 23:26:39 +02:00 committed by Karl Williamson
parent 347536df23
commit eeafc835b8
1 changed files with 26 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
t/io/eintr.t
View File

@ -61,7 +61,7 @@ if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'cygwin' || $^O =~ /freebsd/ || $
my ($in, $out, $st, $sigst, $buf, $pipe_buf_size);
my ($in, $out, $st, $sigst, $buf, $pipe_buf_size, $pipe_buf_err);
plan(tests => 10);
@ -73,6 +73,7 @@ sub fresh_io {
undef $in; undef $out; # use fresh handles each time
pipe $in, $out;
$sigst = "";
$pipe_buf_err = "";
# This used to be 1_000_000, but on Linux/ppc64 (POWER7) this kept
# consistently failing. At exactly 0x100000 it started passing
@ -80,11 +81,19 @@ sub fresh_io {
# that fails, hoping this number is bigger than any pipe buffer.
$pipe_buf_size = eval {
use Fcntl qw(F_GETPIPE_SZ);
fcntl($out, F_GETPIPE_SZ, 0);
# When F_GETPIPE_SZ isn't implemented then fcntl() raises an exception:
# "Your vendor has not defined Fcntl macro F_GETPIPE_SZ ..."
# When F_GETPIPE_SZ is implemented then errors are still possible
# (EINVAL, EBADF, ...). These are not exceptions (i.e. these don't die)
# but instead these set $! and make fcntl() return undef.
fcntl($out, F_GETPIPE_SZ, 0) or die "$!\n";
};
if ($@ or not $pipe_buf_size) {
my $err = $@;;
chomp $err;
$pipe_buf_size = 0xfffff;
diag("fcntl F_GETPIPE_SZ failed, falling back to $pipe_buf_size");
$pipe_buf_err = "fcntl F_GETPIPE_SZ failed" . ($err ? " ($err)" : "") .
", falling back to $pipe_buf_size";
};
$pipe_buf_size++; # goal is to completely fill the buffer so write one
# byte more then the buffer size
@ -99,9 +108,10 @@ $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');
my $result = is($sigst, 'ok', 'read/close: sig handler close status');
$result &= ok(!$st, 'read/close: read status');
$result &= ok(!close($in), 'read/close: close status');
diag($pipe_buf_err) if (not $result and $pipe_buf_err);
# die during read
@ -110,8 +120,9 @@ $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');
$result = ok(!$st, 'read/die: read status');
$result &= ok(close($in), 'read/die: close status');
diag($pipe_buf_err) if (not $result and $pipe_buf_err);
SKIP: {
skip "Tests hang on older versions of Darwin", 5
@ -126,9 +137,10 @@ SKIP: {
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');
$result = is($sigst, 'nok', 'print/close: sig handler close status');
$result &= ok(!$st, 'print/close: print status');
$result &= ok(!close($out), 'print/close: close status');
diag($pipe_buf_err) if (not $result and $pipe_buf_err);
# die during print
@ -139,11 +151,12 @@ SKIP: {
alarm(1);
$st = eval { print $out $buf };
alarm(0);
ok(!$st, 'print/die: print status');
$result = 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');
$result &= ok(!eval {close($out)}, 'print/die: close status');
alarm(0);
diag($pipe_buf_err) if (not $result and $pipe_buf_err);
# close during close