diff --git a/lib/Test/MockFile.pm b/lib/Test/MockFile.pm index 9824dbe..9516d67 100644 --- a/lib/Test/MockFile.pm +++ b/lib/Test/MockFile.pm @@ -1966,6 +1966,151 @@ sub _goto_is_available { return 0; # 5. } +################ +# IO::File # +################ + +# IO::File::open() uses CORE::open internally, which bypasses CORE::GLOBAL::open. +# This means IO::File->new($mocked_file) would NOT use the mock. +# Fix: override IO::File::open to check for mocked files first. + +my $_orig_io_file_open; + +sub _io_file_mock_open { + my ( $fh, $abs_path, $mode ) = @_; + my $mock_file = _get_file_object($abs_path); + + # If contents is undef and reading, file doesn't exist + if ( !defined $mock_file->contents() && grep { $mode eq $_ } qw/< + +>> +>> > >>/; + + # Tie the existing IO::File glob directly (don't create a new one) + tie *{$fh}, 'Test::MockFile::FileHandle', $abs_path, $rw; + + # Track the handle + $mock_file->{'fh'} = $fh; + Scalar::Util::weaken( $mock_file->{'fh'} ) if ref $fh; + + # Handle append/truncate modes + if ( $mode eq '>>' or $mode eq '+>>' ) { + $mock_file->{'contents'} //= ''; + seek $fh, length( $mock_file->{'contents'} ), 0; + } + elsif ( $mode eq '>' or $mode eq '+>' ) { + $mock_file->{'contents'} = ''; + } + + return 1; +} + +sub _io_file_open_override { + @_ >= 2 && @_ <= 4 + or croak('usage: $fh->open(FILENAME [,MODE [,PERMS]])'); + + my $fh = $_[0]; + my $file = $_[1]; + + # Numeric mode (sysopen flags) + if ( @_ > 2 && $_[2] =~ /^\d+$/ ) { + my $sysmode = $_[2]; + my $abs_path = _find_file_or_fh( $file, 1 ); + my $mock_file; + if ( $abs_path && !ref $abs_path ) { + $mock_file = _get_file_object($abs_path); + } + + if ( !$mock_file ) { + # Not mocked — fall through to real sysopen + my $perms = defined $_[3] ? $_[3] : 0666; + return sysopen( $fh, $file, $sysmode, $perms ); + } + + # Handle O_CREAT / O_TRUNC / O_EXCL on the mock + if ( $sysmode & Fcntl::O_EXCL && $sysmode & Fcntl::O_CREAT && defined $mock_file->{'contents'} ) { + $! = EEXIST; + return; + } + if ( $sysmode & Fcntl::O_CREAT && !defined $mock_file->{'contents'} ) { + $mock_file->{'contents'} = ''; + } + if ( !defined $mock_file->{'contents'} ) { + $! = ENOENT; + return; + } + + # Convert sysopen flags to string mode for _io_file_mock_open + my $rd_wr = $sysmode & 3; + my $mode = + $rd_wr == Fcntl::O_RDONLY ? '<' + : $rd_wr == Fcntl::O_WRONLY ? '>' + : $rd_wr == Fcntl::O_RDWR ? '+<' + : '<'; + + if ( $sysmode & Fcntl::O_TRUNC ) { + $mock_file->{'contents'} = ''; + } + if ( $sysmode & Fcntl::O_APPEND ) { + $mode = '>>' if $rd_wr == Fcntl::O_WRONLY; + $mode = '+>>' if $rd_wr == Fcntl::O_RDWR; + } + + return _io_file_mock_open( $fh, $abs_path, $mode ); + } + + my $mode; + if ( @_ > 2 ) { + if ( $_[2] =~ /:/ ) { + + # IO layer mode like "<:utf8" — extract base mode + if ( $_[2] =~ /^([+]?[<>]{1,2})/ ) { + $mode = $1; + } + else { + # Pure layer spec without mode prefix — default to read + $mode = '<'; + } + } + else { + $mode = IO::Handle::_open_mode_string( $_[2] ); + } + } + else { + # 2-arg form: mode may be embedded in filename + if ( $file =~ /^\s*(>>|[+]?[<>])\s*(.+)\s*$/ ) { + $mode = $1; + $file = $2; + } + else { + $mode = '<'; + } + } + + # Pipe opens — not mockable + if ( $mode eq '|-' || $mode eq '-|' ) { + goto &$_orig_io_file_open; + } + + # Check if file is mocked + my $abs_path = _find_file_or_fh( $file, 1 ); + if ( !$abs_path || ( ref $abs_path && ( $abs_path eq BROKEN_SYMLINK || $abs_path eq CIRCULAR_SYMLINK ) ) ) { + goto &$_orig_io_file_open; + } + + my $mock_file = _get_file_object($abs_path); + if ( !$mock_file ) { + goto &$_orig_io_file_open; + } + + # File is mocked — handle via mock layer + return _io_file_mock_open( $fh, $abs_path, $mode ); +} + ############ # KEYWORDS # ############ @@ -2857,6 +3002,14 @@ BEGIN { *Cwd::fast_abs_path = \&__cwd_abs_path; *Cwd::fast_realpath = \&__cwd_abs_path; } + + # Override IO::File::open to intercept mocked files. + # IO::File uses CORE::open internally which bypasses CORE::GLOBAL::open. + $_orig_io_file_open = \&IO::File::open; + { + no warnings 'redefine'; + *IO::File::open = \&_io_file_open_override; + } } =head1 CAEATS AND LIMITATIONS diff --git a/t/io_file_compat.t b/t/io_file_compat.t new file mode 100644 index 0000000..a212f0a --- /dev/null +++ b/t/io_file_compat.t @@ -0,0 +1,177 @@ +#!/usr/bin/perl -w + +use strict; +use warnings; + +use Test::More; +use Errno qw/ENOENT/; + +use Test::MockFile qw< nostrict >; + +# IO::File is loaded by Test::MockFile itself, so it's available. +# The key issue: IO::File::open() uses CORE::open which bypasses CORE::GLOBAL::open. + +note "-------------- IO::File->new with mocked file --------------"; +{ + my $mock = Test::MockFile->file( '/fake/iofile_test', "hello world\n" ); + + my $fh = IO::File->new( '/fake/iofile_test', 'r' ); + ok( defined $fh, "IO::File->new opens a mocked file" ); + if ($fh) { + my $line = <$fh>; + is( $line, "hello world\n", " ... reads correct content" ); + is( <$fh>, undef, " ... EOF" ); + $fh->close; + } +} + +note "-------------- IO::File->new read mode (default) --------------"; +{ + my $mock = Test::MockFile->file( '/fake/iofile_default', "line1\nline2\n" ); + + my $fh = IO::File->new('/fake/iofile_default'); + ok( defined $fh, "IO::File->new with bare filename opens mocked file" ); + if ($fh) { + my @lines = <$fh>; + is_deeply( \@lines, [ "line1\n", "line2\n" ], " ... reads all lines" ); + $fh->close; + } +} + +note "-------------- IO::File->new with explicit read mode '<' --------------"; +{ + my $mock = Test::MockFile->file( '/fake/iofile_read', "content here\n" ); + + my $fh = IO::File->new( '/fake/iofile_read', '<' ); + ok( defined $fh, "IO::File->new with '<' mode opens mocked file" ); + if ($fh) { + my $line = <$fh>; + is( $line, "content here\n", " ... reads correct content" ); + $fh->close; + } +} + +note "-------------- IO::File->new with write mode 'w' --------------"; +{ + my $mock = Test::MockFile->file( '/fake/iofile_write', '' ); + + my $fh = IO::File->new( '/fake/iofile_write', 'w' ); + ok( defined $fh, "IO::File->new with 'w' mode opens mocked file" ); + if ($fh) { + print $fh "written via IO::File\n"; + $fh->close; + } + + is( $mock->contents(), "written via IO::File\n", " ... content was written to mock" ); +} + +note "-------------- IO::File->new with append mode 'a' --------------"; +{ + my $mock = Test::MockFile->file( '/fake/iofile_append', "existing\n" ); + + my $fh = IO::File->new( '/fake/iofile_append', 'a' ); + ok( defined $fh, "IO::File->new with 'a' mode opens mocked file" ); + if ($fh) { + print $fh "appended\n"; + $fh->close; + } + + is( $mock->contents(), "existing\nappended\n", " ... content was appended" ); +} + +note "-------------- IO::File->new with read-write mode 'r+' --------------"; +{ + my $mock = Test::MockFile->file( '/fake/iofile_rw', "original\n" ); + + my $fh = IO::File->new( '/fake/iofile_rw', 'r+' ); + ok( defined $fh, "IO::File->new with 'r+' mode opens mocked file" ); + if ($fh) { + my $line = <$fh>; + is( $line, "original\n", " ... reads existing content" ); + $fh->close; + } +} + +note "-------------- IO::File->new on non-existent mock --------------"; +{ + my $mock = Test::MockFile->file('/fake/iofile_noexist'); + + my $fh = IO::File->new( '/fake/iofile_noexist', 'r' ); + ok( !defined $fh, "IO::File->new returns undef for non-existent mock" ); +} + +note "-------------- IO::File->new with numeric sysopen mode --------------"; +{ + use Fcntl qw/O_RDONLY O_WRONLY O_CREAT O_TRUNC/; + + my $mock = Test::MockFile->file( '/fake/iofile_sysopen', "sysopen data\n" ); + + my $fh = IO::File->new( '/fake/iofile_sysopen', O_RDONLY ); + ok( defined $fh, "IO::File->new with O_RDONLY opens mocked file" ); + if ($fh) { + my $line = <$fh>; + is( $line, "sysopen data\n", " ... reads correct content via sysopen" ); + $fh->close; + } +} + +note "-------------- IO::File->open method on existing object --------------"; +{ + my $mock = Test::MockFile->file( '/fake/iofile_method', "method test\n" ); + + my $fh = IO::File->new; + ok( defined $fh, "IO::File->new creates empty handle" ); + + my $result = $fh->open( '/fake/iofile_method', 'r' ); + ok( $result, " ... open method succeeds on mocked file" ); + if ($result) { + my $line = <$fh>; + is( $line, "method test\n", " ... reads correct content" ); + $fh->close; + } +} + +note "-------------- IO::File with 2-arg embedded mode --------------"; +{ + my $mock = Test::MockFile->file( '/fake/iofile_2arg', '' ); + + my $fh = IO::File->new('>/fake/iofile_2arg'); + ok( defined $fh, "IO::File->new with '>/path' opens mocked file for write" ); + if ($fh) { + print $fh "two-arg write\n"; + $fh->close; + } + + is( $mock->contents(), "two-arg write\n", " ... content was written" ); +} + +note "-------------- IO::File with write+truncate via sysopen mode --------------"; +{ + my $mock = Test::MockFile->file( '/fake/iofile_trunc', "old data" ); + + my $fh = IO::File->new( '/fake/iofile_trunc', O_WRONLY | O_TRUNC ); + ok( defined $fh, "IO::File->new with O_WRONLY|O_TRUNC opens mocked file" ); + if ($fh) { + print $fh "new"; + $fh->close; + } + + is( $mock->contents(), "new", " ... old content was truncated" ); +} + +note "-------------- IO::File getline method on mocked file --------------"; +{ + my $mock = Test::MockFile->file( '/fake/iofile_getline', "first\nsecond\nthird\n" ); + + my $fh = IO::File->new( '/fake/iofile_getline', 'r' ); + ok( defined $fh, "IO::File->new opens for getline test" ); + if ($fh) { + is( $fh->getline, "first\n", " ... getline returns first line" ); + is( $fh->getline, "second\n", " ... getline returns second line" ); + is( $fh->getline, "third\n", " ... getline returns third line" ); + is( $fh->getline, undef, " ... getline returns undef at EOF" ); + $fh->close; + } +} + +done_testing();