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 new file mode 100644 index 0000000..6d1c89d --- /dev/null +++ b/t/closed_fh_ops.t @@ -0,0 +1,130 @@ +#!/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/warning/; + +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; + my $w = warning { $ret = print $fh 'should fail' }; + + ok( !defined $ret, 'print returns undef on closed handle' ); + like( $w, 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; + my $w = warning { $ret = syswrite( $fh, 'fail', 4 ) }; + + ok( !defined $ret, 'syswrite returns undef on closed handle' ); + like( $w, 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; + my $buf; + my $w = warning { $ret = read( $fh, $buf, 10 ) }; + + ok( !defined $ret, 'read returns undef on closed handle' ); + like( $w, 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; + my $w = warning { $ret = readline($fh) }; + + ok( !defined $ret, 'readline returns undef on closed handle' ); + like( $w, 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; + my $w = warning { $ret = tell($fh) }; + + is( $ret, -1, 'tell returns -1 on closed handle' ); + like( $w, 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; + my $w = warning { $ret = seek( $fh, 0, 0 ) }; + + ok( !$ret, 'seek returns false on closed handle' ); + like( $w, 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; + my $w = warning { $ret = getc($fh) }; + + ok( !defined $ret, 'getc returns undef on closed handle' ); + like( $w, qr/closed filehandle/i, 'warning mentions closed filehandle' ); +}; + +# --- 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 = close $fh; + + ok( !$ret, 'double close returns false' ); +}; + +done_testing;