From 89341f87f9fc65c4d7133e497bb04586e86b8052 Mon Sep 17 00:00:00 2001

From: Tony Cook <tony@develop-help.com>

Date: Tue, 12 May 2020 10:29:17 +1000

Subject: [PATCH 1/2] make $fh->error report errors from both input and output

MIME-Version: 1.0

Content-Type: text/plain; charset=UTF-8

Content-Transfer-Encoding: 8bit

For character devices and sockets perl uses separate PerlIO objects

for input and output so they can be buffered separately.

The IO::Handle::error() method only checked the input stream, so

if a write error occurs error() would still returned false.

Change this so both the input and output streams are checked.

fixes #6799

Signed-off-by: Petr Pц╜saе≥ <ppisar@redhat.com>

---

 dist/IO/IO.xs     | 12 ++++++++----

 dist/IO/t/io_xs.t | 19 ++++++++++++++++++-

 2 files changed, 26 insertions(+), 5 deletions(-)

diff --git a/dist/IO/IO.xs b/dist/IO/IO.xs

index 68b7352c38..99d523d2c1 100644

--- a/dist/IO/IO.xs

+++ b/dist/IO/IO.xs

@@ -389,13 +389,17 @@ ungetc(handle, c)

 int

 ferror(handle)

-	InputStream	handle

+	SV *	handle

+    PREINIT:

+        IO *io = sv_2io(handle);

+        InputStream in = IoIFP(io);

+        OutputStream out = IoOFP(io);

     CODE:

-	if (handle)

+	if (in)

 #ifdef PerlIO

-	    RETVAL = PerlIO_error(handle);

+	    RETVAL = PerlIO_error(in) || (in != out && PerlIO_error(out));

 #else

-	    RETVAL = ferror(handle);

+	    RETVAL = ferror(in) || (in != out && ferror(out));

 #endif

 	else {

 	    RETVAL = -1;

diff --git a/dist/IO/t/io_xs.t b/dist/IO/t/io_xs.t

index 1e3c49a4a7..f890e92558 100644

--- a/dist/IO/t/io_xs.t

+++ b/dist/IO/t/io_xs.t

@@ -11,7 +11,7 @@ BEGIN {

     }

 }

-use Test::More tests => 5;

+use Test::More tests => 7;

 use IO::File;

 use IO::Seekable;

@@ -50,3 +50,20 @@ SKIP:

     ok($fh->sync, "sync to a read only handle")

 	or diag "sync(): ", $!;

 }

+

+

+SKIP: {

+    # gh 6799

+    #

+    # This isn't really a Linux/BSD specific test, but /dev/full is (I

+    # hope) reasonably well defined on these.  Patches welcome if your platform

+    # also supports it (or something like it)

+    skip "no /dev/full or not a /dev/full platform", 2

+      unless $^O =~ /^(linux|netbsd|freebsd)$/ && -c "/dev/full";

+    open my $fh, ">", "/dev/full"

+      or skip "Could not open /dev/full: $!", 2;

+    $fh->print("a" x 1024);

+    ok(!$fh->flush, "should fail to flush");

+    ok($fh->error, "stream should be in error");

+    close $fh; # silently ignore the error

+}

-- 

2.25.4