From eeafc835b85738d31557cc262190bbf2df4c6d65 Mon Sep 17 00:00:00 2001
From: Bram <perl-rt@wizbit.be>
Date: Fri, 12 Aug 2022 23:26:39 +0200
Subject: [PATCH] t/io/eintr.t: only show diag message on failure

Also improve the error message by capturing the exception/error
returned by the `fnctl` call.
---
 t/io/eintr.t | 39 ++++++++++++++++++++++++++-------------
 1 file changed, 26 insertions(+), 13 deletions(-)

diff --git a/t/io/eintr.t b/t/io/eintr.t
index f0414c4576..fd700dda5b 100644
--- a/t/io/eintr.t
+++ b/t/io/eintr.t
@@ -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