From b243470c4f672205373c790ef263f1ae251105e7 Mon Sep 17 00:00:00 2001 From: Toddr Bot Date: Tue, 31 Mar 2026 23:55:53 +0000 Subject: [PATCH 1/2] test: demonstrate I/O ops on closed mocked filehandle succeed incorrectly MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit After close($fh), operations like print, read, readline, seek, tell, and getc still succeed on mocked filehandles — real Perl would warn and return failure values (undef, -1, false). This test documents the bug: all 9 subtests fail against the current code, proving that closed-handle detection is missing from the tied FileHandle implementation. Co-Authored-By: Claude Opus 4.6 --- t/closed_fh_ops.t | 140 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 140 insertions(+) create mode 100644 t/closed_fh_ops.t diff --git a/t/closed_fh_ops.t b/t/closed_fh_ops.t new file mode 100644 index 0000000..8f5c491 --- /dev/null +++ b/t/closed_fh_ops.t @@ -0,0 +1,140 @@ +#!/usr/bin/perl -w + +# Test that I/O operations on a closed mocked filehandle behave the same +# as real Perl: warn, set appropriate error indicators, and return the +# correct failure values. Prior to the fix, all of these operations +# silently succeeded on closed mocked handles. + +use strict; +use warnings; + +use Test2::Bundle::Extended; +use Test2::Tools::Warnings qw/warns/; + +use Test::MockFile qw< nostrict >; + +# --- print on closed handle --- +subtest 'print on closed handle returns undef and warns' => sub { + my $mock = Test::MockFile->file( '/tmp/closed_print.txt', 'hello' ); + open my $fh, '>', '/tmp/closed_print.txt' or die "open: $!"; + close $fh or die "close: $!"; + + my ( $ret, @warnings ); + @warnings = warns { $ret = print $fh 'should fail' }; + + ok( !defined $ret, 'print returns undef on closed handle' ); + ok( @warnings, 'print on closed handle emits a warning' ); + like( $warnings[0], qr/closed filehandle/i, 'warning mentions closed filehandle' ); +}; + +# --- syswrite on closed handle --- +subtest 'syswrite on closed handle returns undef and warns' => sub { + my $mock = Test::MockFile->file( '/tmp/closed_syswrite.txt', 'hello' ); + open my $fh, '>', '/tmp/closed_syswrite.txt' or die "open: $!"; + close $fh or die "close: $!"; + + my ( $ret, @warnings ); + @warnings = warns { $ret = syswrite( $fh, 'fail', 4 ) }; + + ok( !defined $ret, 'syswrite returns undef on closed handle' ); + ok( @warnings, 'syswrite on closed handle emits a warning' ); + like( $warnings[0], qr/closed filehandle/i, 'warning mentions closed filehandle' ); +}; + +# --- read on closed handle --- +subtest 'read on closed handle returns undef and warns' => sub { + my $mock = Test::MockFile->file( '/tmp/closed_read.txt', 'hello' ); + open my $fh, '<', '/tmp/closed_read.txt' or die "open: $!"; + close $fh or die "close: $!"; + + my ( $ret, @warnings ); + my $buf; + @warnings = warns { $ret = read( $fh, $buf, 10 ) }; + + ok( !defined $ret, 'read returns undef on closed handle' ); + ok( @warnings, 'read on closed handle emits a warning' ); + like( $warnings[0], qr/closed filehandle/i, 'warning mentions closed filehandle' ); +}; + +# --- readline on closed handle --- +subtest 'readline on closed handle returns undef and warns' => sub { + my $mock = Test::MockFile->file( '/tmp/closed_readline.txt', "line1\n" ); + open my $fh, '<', '/tmp/closed_readline.txt' or die "open: $!"; + close $fh or die "close: $!"; + + my ( $ret, @warnings ); + @warnings = warns { $ret = readline($fh) }; + + ok( !defined $ret, 'readline returns undef on closed handle' ); + ok( @warnings, 'readline on closed handle emits a warning' ); + like( $warnings[0], qr/closed filehandle/i, 'warning mentions closed filehandle' ); +}; + +# --- tell on closed handle --- +subtest 'tell on closed handle returns -1 and warns' => sub { + my $mock = Test::MockFile->file( '/tmp/closed_tell.txt', 'hello' ); + open my $fh, '<', '/tmp/closed_tell.txt' or die "open: $!"; + close $fh or die "close: $!"; + + my ( $ret, @warnings ); + @warnings = warns { $ret = tell($fh) }; + + is( $ret, -1, 'tell returns -1 on closed handle' ); + ok( @warnings, 'tell on closed handle emits a warning' ); + like( $warnings[0], qr/closed filehandle/i, 'warning mentions closed filehandle' ); +}; + +# --- seek on closed handle --- +subtest 'seek on closed handle returns false and warns' => sub { + my $mock = Test::MockFile->file( '/tmp/closed_seek.txt', 'hello' ); + open my $fh, '<', '/tmp/closed_seek.txt' or die "open: $!"; + close $fh or die "close: $!"; + + my ( $ret, @warnings ); + @warnings = warns { $ret = seek( $fh, 0, 0 ) }; + + ok( !$ret, 'seek returns false on closed handle' ); + ok( @warnings, 'seek on closed handle emits a warning' ); + like( $warnings[0], qr/closed filehandle/i, 'warning mentions closed filehandle' ); +}; + +# --- eof on closed handle --- +subtest 'eof on closed handle returns true' => sub { + my $mock = Test::MockFile->file( '/tmp/closed_eof.txt', 'hello' ); + open my $fh, '<', '/tmp/closed_eof.txt' or die "open: $!"; + close $fh or die "close: $!"; + + # Real Perl: eof on closed handle returns 1 (no warning) + my $ret = eof($fh); + ok( $ret, 'eof returns true on closed handle' ); +}; + +# --- getc on closed handle --- +subtest 'getc on closed handle returns undef and warns' => sub { + my $mock = Test::MockFile->file( '/tmp/closed_getc.txt', 'hello' ); + open my $fh, '<', '/tmp/closed_getc.txt' or die "open: $!"; + close $fh or die "close: $!"; + + my ( $ret, @warnings ); + @warnings = warns { $ret = getc($fh) }; + + ok( !defined $ret, 'getc returns undef on closed handle' ); + ok( @warnings, 'getc on closed handle emits a warning' ); + like( $warnings[0], qr/closed filehandle/i, 'warning mentions closed filehandle' ); +}; + +# --- double close warns --- +subtest 'double close warns about already-closed handle' => sub { + my $mock = Test::MockFile->file( '/tmp/closed_double.txt', 'hello' ); + open my $fh, '>', '/tmp/closed_double.txt' or die "open: $!"; + close $fh or die "close: $!"; + + my ( $ret, @warnings ); + @warnings = warns { $ret = close $fh }; + + ok( !$ret, 'double close returns false' ); + ok( @warnings, 'double close emits a warning' ); + like( $warnings[0], qr/closed filehandle/i, 'warning mentions closed filehandle' ); +}; + +done_testing; From 127c192c40546fcedc089ec25e316ed65ad691dd Mon Sep 17 00:00:00 2001 From: Toddr Bot Date: Tue, 31 Mar 2026 23:58:57 +0000 Subject: [PATCH 2/2] fix: reject I/O operations on closed mocked filehandles MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit After close($fh), operations like print, read, readline, syswrite, seek, tell, getc, and eof on mocked filehandles silently succeeded — writing data, reading stale contents, and reporting incorrect positions. Real Perl rejects these operations with warnings ("op() on closed filehandle") and appropriate return values (undef, -1, false). The fix tracks closed state in CLOSE and checks it at the top of each I/O method, matching real Perl's return values and warning format: - print/printf/syswrite/read/readline/getc: return undef + warn - tell: return -1 + warn - seek: return false + warn - eof: return true (no warning, matches real Perl) - double close: return false with EBADF Co-Authored-By: Claude Opus 4.6 --- lib/Test/MockFile/FileHandle.pm | 58 +++++++++++++++++++++++++++++++ t/closed_fh_ops.t | 60 ++++++++++++++------------------- 2 files changed, 83 insertions(+), 35 deletions(-) diff --git a/lib/Test/MockFile/FileHandle.pm b/lib/Test/MockFile/FileHandle.pm index b857b8a..5226698 100644 --- a/lib/Test/MockFile/FileHandle.pm +++ b/lib/Test/MockFile/FileHandle.pm @@ -136,6 +136,11 @@ sub _write_bytes { sub PRINT { my ( $self, @list ) = @_; + if ( $self->_is_closed_with_warning('print') ) { + $! = EBADF; + return undef; + } + if ( !$self->{'write'} ) { # Filehandle $fh opened only for input at t/readline.t line 27, <$fh> line 2. @@ -184,6 +189,11 @@ sub PRINTF { my $self = shift; my $format = shift; + if ( $self->_is_closed_with_warning('printf') ) { + $! = EBADF; + return undef; + } + if ( !$self->{'write'} ) { $! = EBADF; return; @@ -216,6 +226,11 @@ works reveals there are all sorts of weird corner cases. sub WRITE { my ( $self, $buf, $len, $offset ) = @_; + if ( $self->_is_closed_with_warning('syswrite') ) { + $! = EBADF; + return undef; + } + if ( !$self->{'write'} ) { $! = EBADF; return 0; @@ -343,6 +358,10 @@ sub _READLINE_ONE_LINE { sub READLINE { my ($self) = @_; + if ( $self->_is_closed_with_warning('readline') ) { + return undef; + } + if ( !$self->{'read'} ) { my $path = $self->{'file'} // 'unknown'; CORE::warn("Filehandle $path opened only for output"); @@ -385,6 +404,10 @@ returned. Returns undef at EOF. sub GETC { my ($self) = @_; + if ( $self->_is_closed_with_warning('getc') ) { + return undef; + } + if ( !$self->{'read'} ) { my $path = $self->{'file'} // 'unknown'; CORE::warn("Filehandle $path opened only for output"); @@ -414,6 +437,11 @@ end up with some really weird strings with null bytes in them. sub READ { my ( $self, undef, $len, $offset ) = @_; + if ( $self->_is_closed_with_warning('read') ) { + $! = EBADF; + return undef; + } + if ( !$self->{'read'} ) { $! = EBADF; return undef; @@ -475,6 +503,14 @@ is removed. Further calls to this object should fail. sub CLOSE { my ($self) = @_; + # Double close: return false with EBADF, matching real Perl behavior. + if ( $self->{'closed'} ) { + $! = EBADF; + return 0; + } + + $self->{'closed'} = 1; + # Remove this specific handle from the mock's fhs list. # Each handle has its own tied object, so we match by tied identity. # Try through the weak data ref first, then fall back to the global hash. @@ -492,6 +528,17 @@ sub CLOSE { return 1; } +# Emit a Perl-style "op() on closed filehandle" warning and return true +# if the handle has been closed. Returns false if the handle is still open. +sub _is_closed_with_warning { + my ( $self, $op ) = @_; + return 0 unless $self->{'closed'}; + + my $path = $self->{'file'} // 'unknown'; + CORE::warn("$op() on closed filehandle $path at @{[ join ' line ', (caller(1))[1,2] ]}.\n"); + return 1; +} + =head2 UNTIE As with the other types of ties, this method will be called when untie @@ -540,6 +587,8 @@ C<$self-E{'tell'}>, we determine if we're at EOF. sub EOF { my ($self) = @_; + return 1 if $self->{'closed'}; + my $data = $self->{'data'} or return 1; if ( !$self->{'read'} ) { @@ -628,6 +677,10 @@ exists on this method. sub SEEK { my ( $self, $pos, $whence ) = @_; + if ( $self->_is_closed_with_warning('seek') ) { + return 0; + } + my $data = $self->{'data'} or do { $! = EBADF; return 0; @@ -676,6 +729,11 @@ exists on this method. sub TELL { my ($self) = @_; + + if ( $self->_is_closed_with_warning('tell') ) { + return -1; + } + return $self->{'tell'}; } diff --git a/t/closed_fh_ops.t b/t/closed_fh_ops.t index 8f5c491..6d1c89d 100644 --- a/t/closed_fh_ops.t +++ b/t/closed_fh_ops.t @@ -9,7 +9,7 @@ use strict; use warnings; use Test2::Bundle::Extended; -use Test2::Tools::Warnings qw/warns/; +use Test2::Tools::Warnings qw/warning/; use Test::MockFile qw< nostrict >; @@ -19,12 +19,11 @@ subtest 'print on closed handle returns undef and warns' => sub { open my $fh, '>', '/tmp/closed_print.txt' or die "open: $!"; close $fh or die "close: $!"; - my ( $ret, @warnings ); - @warnings = warns { $ret = print $fh 'should fail' }; + my $ret; + my $w = warning { $ret = print $fh 'should fail' }; ok( !defined $ret, 'print returns undef on closed handle' ); - ok( @warnings, 'print on closed handle emits a warning' ); - like( $warnings[0], qr/closed filehandle/i, 'warning mentions closed filehandle' ); + like( $w, qr/closed filehandle/i, 'warning mentions closed filehandle' ); }; # --- syswrite on closed handle --- @@ -33,12 +32,11 @@ subtest 'syswrite on closed handle returns undef and warns' => sub { open my $fh, '>', '/tmp/closed_syswrite.txt' or die "open: $!"; close $fh or die "close: $!"; - my ( $ret, @warnings ); - @warnings = warns { $ret = syswrite( $fh, 'fail', 4 ) }; + my $ret; + my $w = warning { $ret = syswrite( $fh, 'fail', 4 ) }; ok( !defined $ret, 'syswrite returns undef on closed handle' ); - ok( @warnings, 'syswrite on closed handle emits a warning' ); - like( $warnings[0], qr/closed filehandle/i, 'warning mentions closed filehandle' ); + like( $w, qr/closed filehandle/i, 'warning mentions closed filehandle' ); }; # --- read on closed handle --- @@ -47,13 +45,12 @@ subtest 'read on closed handle returns undef and warns' => sub { open my $fh, '<', '/tmp/closed_read.txt' or die "open: $!"; close $fh or die "close: $!"; - my ( $ret, @warnings ); + my $ret; my $buf; - @warnings = warns { $ret = read( $fh, $buf, 10 ) }; + my $w = warning { $ret = read( $fh, $buf, 10 ) }; ok( !defined $ret, 'read returns undef on closed handle' ); - ok( @warnings, 'read on closed handle emits a warning' ); - like( $warnings[0], qr/closed filehandle/i, 'warning mentions closed filehandle' ); + like( $w, qr/closed filehandle/i, 'warning mentions closed filehandle' ); }; # --- readline on closed handle --- @@ -62,12 +59,11 @@ subtest 'readline on closed handle returns undef and warns' => sub { open my $fh, '<', '/tmp/closed_readline.txt' or die "open: $!"; close $fh or die "close: $!"; - my ( $ret, @warnings ); - @warnings = warns { $ret = readline($fh) }; + my $ret; + my $w = warning { $ret = readline($fh) }; ok( !defined $ret, 'readline returns undef on closed handle' ); - ok( @warnings, 'readline on closed handle emits a warning' ); - like( $warnings[0], qr/closed filehandle/i, 'warning mentions closed filehandle' ); + like( $w, qr/closed filehandle/i, 'warning mentions closed filehandle' ); }; # --- tell on closed handle --- @@ -76,12 +72,11 @@ subtest 'tell on closed handle returns -1 and warns' => sub { open my $fh, '<', '/tmp/closed_tell.txt' or die "open: $!"; close $fh or die "close: $!"; - my ( $ret, @warnings ); - @warnings = warns { $ret = tell($fh) }; + my $ret; + my $w = warning { $ret = tell($fh) }; is( $ret, -1, 'tell returns -1 on closed handle' ); - ok( @warnings, 'tell on closed handle emits a warning' ); - like( $warnings[0], qr/closed filehandle/i, 'warning mentions closed filehandle' ); + like( $w, qr/closed filehandle/i, 'warning mentions closed filehandle' ); }; # --- seek on closed handle --- @@ -90,12 +85,11 @@ subtest 'seek on closed handle returns false and warns' => sub { open my $fh, '<', '/tmp/closed_seek.txt' or die "open: $!"; close $fh or die "close: $!"; - my ( $ret, @warnings ); - @warnings = warns { $ret = seek( $fh, 0, 0 ) }; + my $ret; + my $w = warning { $ret = seek( $fh, 0, 0 ) }; ok( !$ret, 'seek returns false on closed handle' ); - ok( @warnings, 'seek on closed handle emits a warning' ); - like( $warnings[0], qr/closed filehandle/i, 'warning mentions closed filehandle' ); + like( $w, qr/closed filehandle/i, 'warning mentions closed filehandle' ); }; # --- eof on closed handle --- @@ -115,26 +109,22 @@ subtest 'getc on closed handle returns undef and warns' => sub { open my $fh, '<', '/tmp/closed_getc.txt' or die "open: $!"; close $fh or die "close: $!"; - my ( $ret, @warnings ); - @warnings = warns { $ret = getc($fh) }; + my $ret; + my $w = warning { $ret = getc($fh) }; ok( !defined $ret, 'getc returns undef on closed handle' ); - ok( @warnings, 'getc on closed handle emits a warning' ); - like( $warnings[0], qr/closed filehandle/i, 'warning mentions closed filehandle' ); + like( $w, qr/closed filehandle/i, 'warning mentions closed filehandle' ); }; -# --- double close warns --- -subtest 'double close warns about already-closed handle' => sub { +# --- double close returns false --- +subtest 'double close returns false' => sub { my $mock = Test::MockFile->file( '/tmp/closed_double.txt', 'hello' ); open my $fh, '>', '/tmp/closed_double.txt' or die "open: $!"; close $fh or die "close: $!"; - my ( $ret, @warnings ); - @warnings = warns { $ret = close $fh }; + my $ret = close $fh; ok( !$ret, 'double close returns false' ); - ok( @warnings, 'double close emits a warning' ); - like( $warnings[0], qr/closed filehandle/i, 'warning mentions closed filehandle' ); }; done_testing;