Test-MockFile-0.037/0000755000000000000000000000000015011451313012621 5ustar rootrootTest-MockFile-0.037/t/0000755000000000000000000000000015011451313013064 5ustar rootrootTest-MockFile-0.037/t/unlink.t0000644000000000000000000000530214341720311014553 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Errno qw/ENOENT EISDIR/; use File::Temp qw/tempfile tempdir/; my $temp_dir_name = tempdir( CLEANUP => 1 ); my ( undef, $missing_file_name ) = tempfile(); CORE::unlink($missing_file_name); my ( $fh, $existing_file_name ) = tempfile(); print $fh "This is the real file\n"; close $fh; use Test::MockFile qw< nostrict >; subtest 'unlink on a missing file' => sub { $! = 0; is( CORE::unlink($missing_file_name), 0, "REAL CORE::unlink returns 0 files deleted." ); is( $! + 0, ENOENT, '$! is set to ENOENT' ); my $mock = Test::MockFile->file($missing_file_name); $! = 0; is( unlink($missing_file_name), 0, "MOCKED unlink returns 0 files deleted." ); is( $! + 0, ENOENT, '$! is set to ENOENT' ); }; subtest 'unlink on an existing directory' => sub { $! = 0; is( CORE::unlink($temp_dir_name), 0, "REAL CORE::unlink returns 0 files deleted." ); my $real_dir_unlink_error = $! + 0; my $mock = Test::MockFile->dir($temp_dir_name); ok( !-d $temp_dir_name, 'Directory does not exist yet' ); ok( mkdir($temp_dir_name), 'Created directory successfully' ); ok( -d $temp_dir_name, 'Directory now exists' ); $! = 0; is( unlink($temp_dir_name), 0, "MOCKED unlink returns 0 files deleted." ); my $err_code = $! + 0; SKIP: { skip q{This docker container doesn't emit $! failures reliably.}, 1 if on_broken_docker(); is( $err_code, $real_dir_unlink_error, '$! is set to EISDIR' ); } }; subtest 'unlink on an existing file' => sub { $! = 0; is( CORE::unlink($existing_file_name), 1, "REAL CORE::unlink returns 1 files deleted." ); is( $! + 0, 0, '$! remains 0' ); my $mock = Test::MockFile->file( $existing_file_name, "abc" ); $! = 0; is( unlink($existing_file_name), 1, "MOCKED unlink returns 1 files deleted." ); is( $! + 0, 0, '$! remains 0' ); }; subtest 'unlink on an unmocked file' => sub { CORE::open( $fh, '>', $existing_file_name ) or die; print $fh "This is the real file\n"; close $fh; $! = 0; is( unlink($existing_file_name), 1, "MOCKED unlink returns 1 files deleted." ); is( $! + 0, 0, '$! remains 0' ); is( CORE::open( $fh, '<', $existing_file_name ), undef, "CORE::open fails since the file is removed from disk" ); is( $! + 0, ENOENT, '$! becomes ENOENT' ); }; done_testing(); sub on_broken_docker { return 0 if $] > 5.019; return 0 unless -f '/.dockerenv'; return 1; } Test-MockFile-0.037/t/chown-chmod-nostrict.t0000644000000000000000000000215214341720311017324 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Test2::Tools::Exception qw< dies >; use Test::MockFile qw< nostrict >; use Cwd (); my $euid = $>; my $egid = int $); my $filename = __FILE__; my $file = Test::MockFile->file( $filename, 'whatevs' ); subtest( 'Unmocked files and mixing unmocked and mocked files' => sub { my $mocked = Cwd::getcwd() . "/$filename"; my $unmocked = '/foo_DOES_NOT_EXIST.znxc'; like( dies( sub { chown -1, -1, $filename, $unmocked } ), qr/^\QYou called chown() on a mix of mocked ($mocked) and unmocked files ($unmocked)\E/xms, 'Even without strict mode, you cannot mix mocked and unmocked files (chown)', ); like( dies( sub { chmod 0755, $filename, $unmocked } ), qr/^\QYou called chmod() on a mix of mocked ($mocked) and unmocked files ($unmocked) \E/xms, 'Even without strict mode, you cannot mix mocked and unmocked files (chmod)', ); } ); done_testing(); exit; Test-MockFile-0.037/t/readlink.t0000644000000000000000000001070314341720311015045 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Errno qw/ENOENT EINVAL/; use File::Temp qw/tempfile tempdir/; my $temp_dir_name = tempdir( CLEANUP => 1 ); my $file = "$temp_dir_name/a"; open( my $fh, ">", $file ) or die; print $fh "abc\n"; close $fh; my $symlink = "$temp_dir_name/b"; my $bad_symlink = "$temp_dir_name/c"; CORE::symlink( "a", $symlink ); CORE::symlink( "notafile", $bad_symlink ); use Test::MockFile qw< nostrict >; note "-------------- REAL MODE --------------"; $! = 0; is( CORE::readlink("$temp_dir_name/missing_file"), undef, "readlink on missing file " ); is( $! + 0, ENOENT, '$! is ENOENT for a missing file readlink.' ); $! = 0; is( CORE::readlink($symlink), 'a', "readlink on a working symlink works." ); is( $! + 0, 0, '$! is 0 for a missing file readlink.' ); $! = 0; is( CORE::readlink($bad_symlink), 'notafile', "readlink on a broken symlink still works." ); is( $! + 0, 0, '$! is 0 for a missing file readlink.' ); $! = 0; is( CORE::readlink($file), undef, "readlink on a file is undef." ); is( $! + 0, EINVAL, '$! is EINVAL for a readlink on a file.' ); $! = 0; is( CORE::readlink($temp_dir_name), undef, "readlink on a dir is undef." ); is( $! + 0, EINVAL, '$! is EINVAL for a readlink on a dir.' ); $! = 0; my $got = 'abc'; like( warning { $got = CORE::readlink(undef) }, qr/^Use of uninitialized value in readlink at /, "Got expected warning for passing no value to readlink" ); is( $got, undef, "readlink without args is undef." ); if ( $^O eq 'freebsd' ) { is( $! + 0, EINVAL, '$! is EINVAL for a readlink(undef)' ); } else { is( $! + 0, ENOENT, '$! is ENOENT for a readlink(undef)' ); } $! = 0; $got = 'abc'; like( warning { $got = CORE::readlink() }, qr/^Use of uninitialized value \$_ in readlink at /, "Got expected warning for passing no value to readlink" ); is( $got, undef, "readlink without args is undef." ); if ( $^O eq 'freebsd' ) { is( $! + 0, EINVAL, '$! is EINVAL for a readlink(undef)' ); } else { is( $! + 0, ENOENT, '$! is ENOENT for a readlink(undef)' ); } note "Cleaning up..."; CORE::unlink( $symlink, $bad_symlink, $file ); note "-------------- MOCK MODE --------------"; $temp_dir_name = '/a/random/path/not/on/disk'; $file = "$temp_dir_name/a"; $symlink = "$temp_dir_name/b"; $bad_symlink = "$temp_dir_name/c"; my @mocks; push @mocks, Test::MockFile->file($file); push @mocks, Test::MockFile->dir($temp_dir_name); push @mocks, Test::MockFile->symlink( "a", $symlink ); push @mocks, Test::MockFile->symlink( "notafile", $bad_symlink ); $! = 0; is( readlink("$temp_dir_name/missing_file"), undef, "readlink on missing file " ); is( $! + 0, ENOENT, '$! is ENOENT for a missing file readlink.' ); $! = 0; is( readlink($symlink), 'a', "readlink on a working symlink works." ); is( $! + 0, 0, '$! is 0 for a missing file readlink.' ); $! = 0; is( readlink($bad_symlink), 'notafile', "readlink on a broken symlink still works." ); is( $! + 0, 0, '$! is 0 for a missing file readlink.' ); $! = 0; is( readlink($file), undef, "readlink on a file is undef." ); is( $! + 0, EINVAL, '$! is EINVAL for a readlink on a file.' ); $! = 0; is( readlink($temp_dir_name), undef, "readlink on a dir is undef." ); is( $! + 0, EINVAL, '$! is EINVAL for a readlink on a dir.' ); $! = 0; $got = 'abc'; like( warning { $got = readlink(undef) }, qr/^Use of uninitialized value in readlink at /, "Got expected warning for passing no value to readlink" ); is( $got, undef, "readlink without args is undef." ); if ( $^O eq 'freebsd' ) { is( $! + 0, EINVAL, '$! is EINVAL for a readlink(undef)' ); } else { is( $! + 0, ENOENT, '$! is ENOENT for a readlink(undef)' ); } $! = 0; $got = 'abc'; todo "Something's wrong with readlink's prototype and the warning is incorrect no matter what we do in the code." => sub { like( warning { $got = readlink() }, qr/^Use of uninitialized value \$_ in readlink at /, "Got expected warning for passing no value to readlink" ); }; is( $got, undef, "readlink without args is undef." ); if ( $^O eq 'freebsd' ) { is( $! + 0, EINVAL, '$! is EINVAL for a readlink(undef)' ); } else { is( $! + 0, ENOENT, '$! is ENOENT for a readlink(undef)' ); } done_testing(); Test-MockFile-0.037/t/strict-rules_scalar.t0000644000000000000000000000240614460235754017260 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Test::MockFile qw< strict >; # yeap it's strict ok( dies { -e "/no/mocked" }, q[-e "/no/mocked"] ); ok( dies { -l "/no/mocked" }, q[-l "/no/mocked"] ); note "add_strict_rule_for_command for stat / lstat"; # incorrect ok( dies { Test::MockFile::add_strict_rule_for_command( [qw{ lstat stat }] => '/this/path', 1 ) }, "command not supported" ); # correct Test::MockFile::add_strict_rule_for_command( [qw{ lstat stat }] => sub { my ($ctx) = @_; return 1 if $ctx->{filename} eq '/this/path'; return; # continue to the next rule } ); ok( dies { -e "/no/mocked" }, q[-e "/no/mocked"] ); ok( dies { -l "/no/mocked" }, q[-l "/no/mocked"] ); ok( lives { -l '/this/path' }, q[-l "/this/path" mocked] ); ok( dies { -l "/another/mocked" }, q[-l "/another/mocked"] ); Test::MockFile::add_strict_rule( [qw{ lstat stat }] => '/another/path', 1 ); ok( dies { -e "/no/mocked" }, q[-e "/no/mocked"] ); ok( dies { -l "/no/mocked" }, q[-l "/no/mocked"] ); ok( lives { -l '/this/path' }, q[-l "/this/path" mocked] ); ok( lives { -l '/another/path' }, q[-l "/another/path" mocked] ); done_testing; Test-MockFile-0.037/t/strict-rules.t0000644000000000000000000000645114341720311015721 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Test::MockFile qw< strict >; # yeap it's strict like dies { open( my $fh, ">", '/this/is/a/test' ) }, qr{Use of open to access unmocked file or directory}, "Cannot open an unmocked file in strict mode"; note "add_strict_rule_for_filename"; Test::MockFile::add_strict_rule_for_filename( "/cherry" => 1 ); ok lives { open( my $fh, '>', '/cherry' ) }, "can open a file with a custom rule"; ok dies { open( my $fh, '>', '/cherry/abcd' ) }, "cannot open a file under the directory"; Test::MockFile::add_strict_rule_for_filename( "/another" => 1 ); foreach my $f (qw{/cherry /another}) { ok lives { open( my $fh, '>', $f ) }, "open $f with multiple rules"; } Test::MockFile::clear_strict_rules(); ok dies { open( my $fh, '>', '/cherry' ) }, "clear_strict_rules removes all previous rules"; Test::MockFile::add_strict_rule_for_filename( qr{^/cherry} => 1 ); ok lives { open( my $fh, '>', '/cherry' ) }, "can open a file with a custom rule - regexp"; ok lives { open( my $fh, '>', '/cherry/abcd' ) }, "can open a file with a custom rule - regexp"; Test::MockFile::clear_strict_rules(); Test::MockFile::add_strict_rule_for_filename( [ qw{/foo /bar}, qr{^/cherry} ] => 1 ); ok lives { open( my $fh, '>', '/foo' ) }, "add_strict_rule_for_filename multiple rules"; ok lives { open( my $fh, '>', '/cherry/abcd' ) }, "add_strict_rule_for_filename multiple rules"; Test::MockFile::clear_strict_rules(); note "add_strict_rule_for_command"; ok dies { opendir( my $fh, '/whatever' ) }, "opendir fails without add_strict_rule_for_command"; Test::MockFile::add_strict_rule_for_command( 'opendir' => 1 ); ok lives { opendir( my $fh, '/whatever' ) }, "add_strict_rule_for_command"; Test::MockFile::clear_strict_rules(); Test::MockFile::add_strict_rule_for_command( qr{op.*} => 1 ); ok lives { opendir( my $fh, '/whatever' ) }, "add_strict_rule_for_command - regexp"; Test::MockFile::clear_strict_rules(); Test::MockFile::add_strict_rule_for_command( [ 'abcd', 'opendir' ] => 1 ); ok lives { opendir( my $fh, '/whatever' ) }, "add_strict_rule_for_command - list"; Test::MockFile::clear_strict_rules(); note "add_strict_rule_generic"; ok dies { open( my $fh, '>', '/cherry' ) }, "no rules setup"; my $context; Test::MockFile::add_strict_rule_generic( sub { my ($ctx) = @_; $context = $ctx; return 1; } ); ok lives { open( my $fh, '>', '/cherry' ) }, "add_strict_rule_generic"; if ( $^V >= 5.18.0 ) { # behaving differently in 5.16 due to glob stuff... is $context, { 'at_under_ref' => [ D(), '>', '/cherry' ], 'command' => 'open', 'filename' => '/cherry' }, "context set for open" or diag explain $context; } ok lives { open( my $fh, '>', '/////cherry' ) }, "add_strict_rule_generic"; is $context->{filename}, '/cherry', "context uses normalized path"; my $is_exception; Test::MockFile::clear_strict_rules(); Test::MockFile::add_strict_rule_generic( sub { $is_exception } ); ok dies { open( my $fh, '>', '/cherry' ) }, "add_strict_rule_generic - no exception"; $is_exception = 1; ok lives { open( my $fh, '>', '/cherry' ) }, "add_strict_rule_generic - exception"; done_testing; Test-MockFile-0.037/t/handle-corruption.t0000644000000000000000000000123014341720311016704 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Tools::Exception qw< lives >; use Test2::Plugin::NoWarnings; use Test::MockFile; use IO::Handle; my $handle = IO::Handle->new(); isa_ok( $handle, 'IO::Handle' ); my $file = Test::MockFile->file( '/foo', '' ); $! = 0; ok( open( $handle, '<', '/foo' ), 'Succesfully opened file' ); is( "$!", '', 'No error (string)' ); is( $! + 0, 0, 'No error (code)' ); isa_ok( $handle, 'IO::File' ); $! = 0; ok( close($handle), 'Successfully closed handle' ); is( "$!", '', 'No error (string)' ); is( $! + 0, 0, 'No error (code)' ); done_testing(); exit; Test-MockFile-0.037/t/chmod-filetemp.t0000644000000000000000000000060414341720311016150 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; BEGIN { skip_all("Skip for now < 5.28") unless $^V ge 5.28.0; } use Test::MockFile plugin => "FileTemp"; use File::Temp qw< tempfile >; my $dir = File::Temp::tempdir(); open my $fh, ">", "$dir/thefile"; ok chmod 0777, $fh; done_testing(); exit; Test-MockFile-0.037/t/stat-x.t0000644000000000000000000000343714341720311014502 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Test::MockFile; subtest( '-x after unlink' => sub { my $filename = '/bin/mine'; my $mocked = Test::MockFile->file( $filename => '#!/bin/true' ); chmod 0755, $filename; ok( -e $filename, 'File should exist' ); ok( -x $filename, 'File should be executable' ); unlink $filename; ok( !-e $filename, 'File should not exist' ); ok( !-x $filename, 'File should not be executable' ); } ); subtest( '-x with multiple files' => sub { my $filename1 = q[/bin/one]; my $filename2 = q[/bin/two]; my $mock1 = Test::MockFile->file($filename1); my $mock2 = Test::MockFile->file($filename2); ok( !-x $filename1, 'First filename should not be executable' ); ok( !-x $filename2, 'Second filename should not be executable' ); $mock1->touch; chmod 0755, $filename1; ok( -e $filename1, 'First filename should now exist' ); ok( -x $filename1, 'First filename should now be executable' ); ok( !-e $filename2, 'Second filename should still not exist' ); ok( !-x $filename2, 'Second filename should still not be executable' ); } ); subtest( 'rmdir works for mocked directories' => sub { my $dir = q[/some/where]; my $mocked = Test::MockFile->dir($dir); ok( mkdir($dir), 'Created directory successfully' ); ok( -d $dir, 'Directory now exists' ); is( $! + 0, 0, 'No errors yet' ); ok( rmdir($dir), 'Successfully rmdir directory' ); is( $! + 0, 0, 'Still no errors' ); ok( !-d $dir, 'Directory no longer exists' ); } ); done_testing(); exit; Test-MockFile-0.037/t/mkdir.t0000644000000000000000000001224414341720311014364 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Errno qw/ENOENT EISDIR EEXIST/; use File::Temp qw/tempfile tempdir/; my $temp_dir_name = tempdir( CLEANUP => 1 ); CORE::rmdir $temp_dir_name; use Test::MockFile qw< nostrict >; # Proves umask works in this test. umask 022; subtest "basic mkdir" => sub { $! = 0; is( CORE::mkdir($temp_dir_name), 1, "REAL mkdir when dir is missing." ); is( $! + 0, 0, ' - $! is unset.' ) or diag "$!"; is( CORE::rmdir $temp_dir_name, 1, "REAL rmdir when dir is there" ); my $mock = Test::MockFile->dir($temp_dir_name); is( mkdir($temp_dir_name), 1, "MOCK mkdir when dir is missing." ); is( $! + 0, 0, ' - $! is unset.' ) or diag "$!"; is( $mock->permissions, 0755, "Perms are 0755" ); ok( -d $temp_dir_name, "-d" ); is( $! + 0, 0, ' - $! is unset.' ) or diag "$!"; is( rmdir $temp_dir_name, 1, "MOCK rmdir when dir is there" ); is( $! + 0, 0, ' - $! is unset.' ) or diag "$!"; ok( !-d $temp_dir_name, "Directory is not there with -d" ); ok( !-e $temp_dir_name, "Directory is not there with -e" ); }; subtest "undef dir name" => sub { my $return; $! = 0; like( warning { $return = CORE::mkdir(undef) }, qr/^Use of uninitialized value in mkdir at.+\n$/, "REAL mkdir when undef is passed as the file name." ); is( $! + 0, ENOENT, ' - $! is ENOENT.' ) or diag "\$\! = $!"; is( $return, 0, " - Returns 0" ); $! = 0; like( warning { $return = mkdir(undef) }, qr/^Use of uninitialized value in mkdir at.+\n$/, "MOCK mkdir when undef is passed as the file name." ); is( $! + 0, ENOENT, ' - $! is ENOENT.' ) or diag "\$\! = $!"; is( $return, 0, " - Returns 0" ); }; subtest "REAL mkdir" => sub { $! = 0; is( CORE::mkdir($temp_dir_name), 1, "put the real tempdir back" ); is( mkdir("$temp_dir_name/a"), 1, "A real mkdir through the shim" ); is( $! + 0, 0, ' - $! is unset.' ) or diag "\$\! = $!"; is( mkdir("$temp_dir_name/a"), 0, "A real mkdir through the shim when it exists already" ); is( $! + 0, EEXIST, ' - $! is EEXIST.' ) or diag "\$\! = $!"; # Cleanup. rmdir "$temp_dir_name/a"; }; subtest "mkdir when file exists" => sub { my $file_path = "$temp_dir_name/a"; CORE::mkdir $temp_dir_name; touch($file_path); $! = 0; is( CORE::mkdir($file_path), 0, "A real mkdir when the dir is already a file." ); is( $! + 0, EEXIST, ' - $! is EEXIST.' ) or diag "\$\! = $!"; my $mock = Test::MockFile->file( $file_path, "" ); $! = 0; is( mkdir($file_path), 0, "A mock mkdir when the dir is already a file." ); is( $! + 0, EEXIST, ' - $! is EEXIST.' ) or diag "\$\! = $!"; $mock->unlink; is( mkdir($file_path), 1, "A mock mkdir when the path is a mocked file but not on disk becomes a directory mock." ); is( $mock->is_dir, 1, '$mock is now a directory' ); }; subtest "mkdir when symlink exists" => sub { my $file_path = "$temp_dir_name/a"; CORE::mkdir $temp_dir_name; CORE::symlink( "$temp_dir_name/ab", $file_path ); $! = 0; is( CORE::mkdir($file_path), 0, "A real mkdir when the dir is already a symlink." ); is( $! + 0, EEXIST, ' - $! is EEXIST.' ) or diag "\$\! = $!"; CORE::unlink($file_path); my $mock = Test::MockFile->symlink( "${file_path}b", $file_path ); $! = 0; is( mkdir($file_path), 0, "A mock mkdir when the dir is already a symlink." ); is( $! + 0, EEXIST, ' - $! is EEXIST.' ) or diag "\$\! = $!"; # Stop mocking this and start over undef $mock; $mock = Test::MockFile->dir($file_path); is( mkdir($file_path), 1, "A mock mkdir when the path is a mocked symlink but not on disk turns the mock object into a dir." ); is( $mock->is_dir, 1, '$mock is now a directory' ); }; subtest "mkdir with file perms" => sub { CORE::mkdir $temp_dir_name; my $file_path = "$temp_dir_name/a"; umask(0); $! = 0; is( CORE::mkdir( $file_path, 0770 ), 1, "A real mkdir with 0770 perms." ); is( $! + 0, 0, ' - $! is unset.' ) or diag "\$\! = $!"; my @stats = CORE::stat($file_path); is( $stats[2], 040770, "permissions are the real file's permissions" ); my $mock = Test::MockFile->dir($file_path); $! = 0; is( mkdir( $file_path, 0700 ), 1, "A mock mkdir with 0700 perms." ); is( $! + 0, 0, ' - $! is unset.' ) or diag "\$\! = $!"; is( $mock->permissions, 0700, "Permissions are the mock permissions of 0700" ); umask(022); is( rmdir($file_path), 1, "Remove the fake dir" ); is( mkdir( $file_path, 0777 ), 1, "A mock mkdir with 0700 perms." ); is( $! + 0, 0, ' - $! is unset.' ) or diag "\$\! = $!"; is( $mock->permissions, 0755, "Permissions get umask applied." ); }; done_testing(); sub touch { my $path = shift or die; CORE::open( my $fh, '>>', $path ) or die; print $fh ''; close $fh; return 1; } Test-MockFile-0.037/t/new_dir_interface.t0000644000000000000000000000724014341720311016725 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Test2::Tools::Exception qw< lives dies >; use Test::MockFile; sub test_content_with_keywords { my ( $dirname, $dir_content ) = @_; my $dh; my $open; ok( lives( sub { $open = opendir $dh, $dirname } ), "opendir() $dirname successful", ); $open or return; my @content; ok( lives( sub { @content = readdir($dh) } ), "readdir() on $dirname successful", ); is( \@content, $dir_content, 'Correct directory content through Perl core keywords', ); ok( lives( sub { closedir $dh } ), "closedir() on $dirname successful", ); } my $count = 0; my $get_dirname = sub { $count++; return "/foo$count"; }; subtest( '->dir() checks when going through ->new_dir()' => sub { like( dies( sub { Test::MockFile->new_dir( '/etc', { 1 => 2 } ) } ), qr!^\QYou cannot set stats for nonexistent dir '/etc'\E!xms, 'Cannot do TMF->dir( "/etc", { 1 => 2 } )', ); like( dies( sub { Test::MockFile->new_dir( '/etc', [ 'foo', 'bar' ], { 1 => 2 } ) } ), qr!^\QYou cannot set stats for nonexistent dir '/etc'\E!xms, 'Cannot do TMF->dir( "/etc", [@content], { 1 => 2 } )', ); like( dies( sub { Test::MockFile->new_dir( '/etc', [ 'foo', 'bar' ] ) } ), qr!^\QYou cannot set stats for nonexistent dir '/etc'\E!xms, 'Cannot do TMF->dir( "/etc", [@content] )', ); } ); subtest( 'Scenario 1: ->new_dir() can create dir' => sub { my $dirname = $get_dirname->(); my $dir = Test::MockFile->new_dir($dirname); ok( -d $dirname, "Directory $dirname exists" ); is( $dir->contents(), [qw< . .. >], 'Correct contents of directory through ->contents()', ); test_content_with_keywords( $dirname, [qw< . .. >] ); } ); subtest( 'Scenario 2: ->new_dir() with mode sets the mode' => sub { my $dirname = $get_dirname->(); my $base_dir = Test::MockFile->new_dir("${dirname}-base"); my $dir = Test::MockFile->new_dir( $dirname, { 'mode' => 0300 } ); ok( -d $base_dir->path(), "$dirname exists" ); ok( -d $dirname, "$dirname exists" ); my $def_perms = sprintf '%04o', ( ( stat $base_dir->path() )[2] ^ umask ) & 07777; my $new_perms = sprintf '%04o', ( ( stat $dirname )[2] ^ umask ) & 07777; # make sure we're not getting fooled by the default permissions isnt( $def_perms, $new_perms, "We picked perms ($new_perms) that are not the default ($def_perms)" ); is( $new_perms, '0300', 'Mode was set correctly', ); is( $dir->contents(), [qw< . .. >], "Correct contents to $dirname", ); test_content_with_keywords( $dirname, [qw< . .. >] ); } ); subtest( 'Scenario 3: ->new_dir() after mkdir() has an error' => sub { my $dirname = $get_dirname->(); my $dir = Test::MockFile->new_dir($dirname); ok( -d $dirname, "$dirname exists" ); ok( !mkdir($dirname), "mkdir $dirname fails, since dir already exists" ); isnt( $! + 0, 0, "\$! is set to an error: " . ( $! + 0 ) . " ($!)" ); is( $dir->contents(), [qw< . .. >], "Correct contents to $dirname", ); test_content_with_keywords( $dirname, [qw< . .. >] ); } ); done_testing(); Test-MockFile-0.037/t/pod.t0000644000000000000000000000053614341720311014041 0ustar rootroot#!perl -T use 5.006; use strict; use warnings; use Test::More; unless ( $ENV{RELEASE_TESTING} ) { plan( skip_all => "Author tests not required for installation" ); } # Ensure a recent version of Test::Pod my $min_tp = 1.22; eval "use Test::Pod $min_tp"; plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; all_pod_files_ok(); Test-MockFile-0.037/t/goto_is_available.t0000644000000000000000000000237214341720311016722 0ustar rootroot#!/usr/bin/perl use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Test::MockFile qw< nostrict >; Internals::SvREADONLY( $], 0 ); $] = '5.006002'; is( Test::MockFile::_goto_is_available(), 0, "goto isn't available on $]" ); $] = '5.008008'; is( Test::MockFile::_goto_is_available(), 0, "goto isn't available on $]" ); $] = '5.016000'; is( Test::MockFile::_goto_is_available(), 1, "goto was first available on $]" ); $] = '5.018000'; is( Test::MockFile::_goto_is_available(), 1, "goto was available on $]" ); $] = '5.020000'; is( Test::MockFile::_goto_is_available(), 1, "goto was available on $]" ); $] = '5.022001'; is( Test::MockFile::_goto_is_available(), 0, "goto was broken on $] (7bdb4ff0943cf93297712faf504cdd425426e57f)" ); $] = '5.024000'; is( Test::MockFile::_goto_is_available(), 0, "goto was broken on $] (7bdb4ff0943cf93297712faf504cdd425426e57f)" ); $] = '5.026000'; is( Test::MockFile::_goto_is_available(), 0, "goto was broken on $] (7bdb4ff0943cf93297712faf504cdd425426e57f)" ); $] = '5.028000'; is( Test::MockFile::_goto_is_available(), 1, "goto works again for $]" ); $] = '5.030000'; is( Test::MockFile::_goto_is_available(), 1, "goto works on $]" ); done_testing(); exit; Test-MockFile-0.037/t/pod-coverage.t0000644000000000000000000000124414341720311015627 0ustar rootroot#!perl -T use 5.006; use strict; use warnings; use Test::More; unless ( $ENV{RELEASE_TESTING} ) { plan( skip_all => "Author tests not required for installation" ); } # Ensure a recent version of Test::Pod::Coverage my $min_tpc = 1.08; eval "use Test::Pod::Coverage $min_tpc"; plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" if $@; # Test::Pod::Coverage doesn't require a minimum Pod::Coverage version, # but older versions don't recognize some common documentation styles my $min_pc = 0.18; eval "use Pod::Coverage $min_pc"; plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" if $@; all_pod_coverage_ok(); Test-MockFile-0.037/t/sysopen_strict.t0000644000000000000000000000146114341717063016357 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Plugin::NoWarnings; my $can_run; BEGIN { $can_run = ($^V ge 5.28.0); } use Test::MockFile ($can_run ? ( plugin => 'FileTemp' ) : ()); use Fcntl; use File::Temp; plan skip_all => 'Needs FileTemp plugin' if !$can_run; my $dir = File::Temp::tempdir( CLEANUP => 1 ); my ($separator) = $dir =~ m<([\\/])> or die "No separator in $dir!"; Test::MockFile::add_strict_rule( 'open', qr<\Q$dir$separator\E>, 1, ); my $path = "$dir${separator}file"; sysopen my $fh, $path, Fcntl::O_WRONLY | Fcntl::O_CREAT or die "sysopen($path): $!"; my $fh_str = "$fh"; my $err = dies { sysopen my $fh2, $fh, Fcntl::O_RDONLY }; like( $err, qr<\Q$fh_str\E>, 'sysopen() to read a filehandle fails', ); done_testing; 1; Test-MockFile-0.037/t/file_access_hooks.t0000644000000000000000000000607414341720311016725 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use File::Temp qw/tempfile tempdir/; use Fcntl; #use Errno qw/ENOENT EBADF/; use Test::MockFile; # Everything below this can have its open overridden. my ( undef, $temp_file ) = tempfile(); my $temp_dir = tempdir( CLEANUP => 1 ); note "-------------- REAL MODE --------------"; like( dies { open( my $fh, "<", $temp_file ) }, qr/^Use of open to access unmocked file or directory '$temp_file' in strict mode at $0 line \d+/, "Using open on an unmocked file throws a croak" ); like( dies { open( my $fh, "file( $mock_file_name, "content" ); # Missing file but mocked. ok( -s $mock_file_name, "-s $mock_file_name" ); package DynaLoader; main::is( __PACKAGE__, "DynaLoader", "Testing from a different source scope (DynaLoader)" ); main::is( -d '/tmp', 1, "-d is allowed in certain packages without a die (DynaLoader)" ); package main; is( open( my $fh, '<&STDIN' ), 1, "open STDIN isn't an error" ); my ( $fh_temp, $file_on_disk ) = tempfile(); print {$fh_temp} "a" x 4096 . "\n"; $fh_temp->flush; my @stat = stat($fh_temp); is( $stat[7], 4097, "Stat on a file handle which didn't get filtered through MockFile works without a die" ) or diag explain \@stat; done_testing(); Test-MockFile-0.037/t/chmod.t0000644000000000000000000001317214341720311014351 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Test2::Tools::Exception qw< lives dies >; use Test2::Tools::Warnings qw< warning >; use Test::MockFile qw< nostrict >; use File::Temp qw< tempfile >; my $filename = __FILE__; my $file = Test::MockFile->file( $filename, 'whatevs' ); subtest( 'Defaults' => sub { my $dir_foo = Test::MockFile->dir('/foo'); my $file_bar = Test::MockFile->file( '/foo/bar', 'content' ); ok( -d '/foo', 'Directory /foo exists' ); ok( -f '/foo/bar', 'File /foo/bar exists' ); my $dir_def_perm = sprintf '%04o', 0777 - umask; is( sprintf( '%04o', ( stat '/foo' )[2] & 07777 ), $dir_def_perm, "Directory /foo is set to $dir_def_perm", ); # These variables are for debugging test failures my $umask = sprintf '%04o', umask; my $perms_before = sprintf '%04o', Test::MockFile::S_IFPERMS() & 0666; my $perms_after_1 = sprintf '%04o', ( Test::MockFile::S_IFPERMS() & 0666 ) ^ umask; my $perms_after_2 = sprintf '%04o', ( ( Test::MockFile::S_IFPERMS() & 0666 ) ^ umask ) | Test::MockFile::S_IFREG(); my $file_def_perm = sprintf '%04o', 0666 - umask; is( sprintf( '%04o', ( stat '/foo/bar' )[2] & 07777 ), $file_def_perm, "File /foo/bar is set to $file_def_perm (umask: $umask, perms before: $perms_before, perms after 1: $perms_after_1, perms after 2: $perms_after_2)", ); } ); subtest( 'Changing mode (real vs. mocked)' => sub { ok( CORE::mkdir('fooz'), 'Successfully created real directory' ); ok( CORE::chmod( 0600, 'fooz' ), 'Successfully chmod\'ed real directory' ); is( sprintf( '%04o', ( CORE::stat('fooz') )[2] & 07777 ), '0600', 'CORE::chmod() set the perms correctly', ); ok( CORE::rmdir('fooz'), 'Successfully deleted real directory' ); my $dir_foo = Test::MockFile->dir('/foo'); my $file_bar = Test::MockFile->file( '/foo/bar', 'content' ); ok( -d '/foo', 'Directory /foo exists' ); ok( -f '/foo/bar', 'File /foo/bar exists' ); chmod 0600, qw< /foo /foo/bar >; is( sprintf( '%04o', ( stat '/foo' )[2] & 07777 ), '0600', 'Directory /foo is now set to 0600', ); is( sprintf( '%04o', ( stat '/foo/bar' )[2] & 07777 ), '0600', 'File /foo/bar is now set to 0600', ); chmod 0777, qw< /foo /foo/bar >; is( sprintf( '%04o', ( stat '/foo' )[2] & 07777 ), '0777', 'Directory /foo is now set to 0600', ); is( sprintf( '%04o', ( stat '/foo/bar' )[2] & 07777 ), '0777', 'File /foo/bar is now set to 0600', ); } ); subtest( 'Changing mode filehandle' => sub { SKIP: { if ( $^V lt 5.28.0 ) { skip "Skipped: need Perl >= 5.28.0", 1; return; } my $test_string = "abcd\nefgh\n"; my ( $fh_real, $filename ) = tempfile(); print $fh_real $test_string; { note "-------------- REAL MODE --------------"; ok chmod( 0700, $filename ), 'chmod on file'; open( my $fh, '>', $filename ); ok chmod( 0711, $fh ), 'chmod on filehandle'; } { note "-------------- MOCK MODE --------------"; my $bar = Test::MockFile->file( $filename, $test_string ); ok chmod( 0700, $filename ), 'chmod on file'; open( my $fh, '>', $filename ); ok chmod( 0711, $fh ), 'chmod on filehandle'; } } return; } ); subtest( 'Providing a string as mode mask' => sub { ok( CORE::mkdir('fooz'), 'Successfully created real directory' ); my $core_chmod_res; like( warning( sub { $core_chmod_res = CORE::chmod( 'hello', 'fooz' ) } ), qr/^\QArgument "hello" isn't numeric in chmod\E/xms, 'CORE::chmod() threw a warning when trying to numify', ); ok( $core_chmod_res, 'Successfully chmod\'ed real directory' ); is( $!, '', 'No observed error' ); is( sprintf( '%04o', ( CORE::stat('fooz') )[2] & 07777 ), '0000', 'CORE::chmod() set the perms correctly', ); ok( CORE::rmdir('fooz'), 'Successfully deleted real directory' ); # --- Mock --- my $dir_foo = Test::MockFile->dir('/foo'); ok( !-d '/foo', 'Directory /foo does not exist' ); # If we don't zero this out, nothing else will - wtf? $! = 0; ok( mkdir('/foo'), 'Successfully created mocked directory' ); ok( -d '/foo', 'Directory /foo now exists' ); my $chmod_res; like( warning( sub { $chmod_res = chmod 'hello', '/foo' } ), qr/^\QArgument "hello" isn't numeric in chmod\E/xms, 'chmod() threw a warning when trying to numify', ); ok( $chmod_res, 'Successfully chmod\'ed real directory' ); is( $!, '', 'No observed error' ); is( sprintf( '%04o', ( CORE::stat('/foo') )[2] & 07777 ), '0000', 'chmod() set the perms correctly', ); ok( rmdir('/foo'), 'Successfully deleted real directory' ); ok( !-d '/foo', 'Directory /foo no longer exist' ); } ); done_testing(); exit; Test-MockFile-0.037/t/runtime-bareword-filehandles.t0000644000000000000000000000140414341720311021014 0ustar rootrootuse strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Test2::Tools::Exception qw< lives >; # This must be loaded after other modules that use open() in BEGIN use Test::MockFile qw< nostrict >; # specifically not "strict" to trigger the issue # This must be loaded after Test::MockFile so we override the core functions # that will be used in File::Find when it compiles use File::Find (); ok( lives( sub { File::Find::find( { 'wanted' => sub { 1 } }, '.', ); } ), 'Successfully handled bareword filehandles during runtime', ); is( "$@", '', 'No observed error' ); done_testing(); Test-MockFile-0.037/t/chown.t0000644000000000000000000001342714341720311014400 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Test2::Tools::Exception qw< lives dies >; use Test::MockFile (); my $euid = $>; my $egid = int $); my $filename = __FILE__; my $file = Test::MockFile->file( $filename, 'whatevs' ); my $is_root = $> == 0 || $) =~ /( ^ | \s ) 0 ( \s | $)/xms; my $top_gid; my $next_gid; if ( !$is_root ) { my @groups; ( $top_gid, @groups ) = split /\s+/xms, $); # root can have $) set to "0 0" ($next_gid) = grep $_ != $top_gid, @groups; } # Three scenarios: # 1. If you're root, switch to +9999 # 2. If you're not root, do you have another group to use? # 3. If you're not root and have no other group, switch to -1 subtest( 'Default ownership' => sub { my $dir_foo = Test::MockFile->dir('/foo'); my $file_bar = Test::MockFile->file( '/foo/bar', 'content' ); ok( -d '/foo', 'Directory /foo exists' ); ok( -f '/foo/bar', 'File /foo/bar exists' ); foreach my $path (qw< /foo /foo/bar >) { is( ( stat $path )[4], $euid, "$path set UID correctly to $euid", ); is( ( stat $path )[5], $egid, "$path set GID correctly to $egid", ); } } ); subtest( 'Change ownership of file to someone else' => sub { note("\$>: $>, \$): $)"); my $chown_cb = sub { my ( $args, $message ) = @_; $! = 0; if ($is_root) { ok( chown( @{$args} ), $message ); is( $! + 0, 0, 'chown succeeded' ); is( "$!", '', 'No failure' ); } else { ok( !chown( @{$args} ), $message ); is( $! + 0, 1, "chown failed (EPERM): \$>:$>, \$):$)" ); } }; $chown_cb->( [ $euid + 9999, $egid + 9999, $filename ], 'chown file to some high, probably unavailable, UID/GID', ); $chown_cb->( [ $euid, $egid + 9999, $filename ], 'chown file to some high, probably unavailable, GID', ); $chown_cb->( [ $euid + 9999, $egid, $filename ], 'chown file to some high, probably unavailable, UID', ); $chown_cb->( [ 0, 0, $filename ], 'chown file to root', ); $chown_cb->( [ $euid, 0, $filename ], 'chown file to root GID', ); $chown_cb->( [ 0, $egid, $filename ], 'chown file to root UID', ); } ); subtest( 'chown with bareword (nonexistent file)' => sub { no strict; my $bareword_file = Test::MockFile->file('RANDOM_FILE_THAT_WILL_NOT_EXIST'); is( $! + 0, 0, '$! starts clean' ); ok( !chown( $euid, $egid, RANDOM_FILE_THAT_WILL_NOT_EXIST ), 'Using bareword treats it as string', ); is( $! + 0, 2, 'Correct ENOENT error' ); } ); subtest( 'chown only user, only group, both' => sub { is( $! + 0, 0, '$! starts clean' ); ok( chown( $euid, -1, $filename ), 'chown\'ing file to only UID', ); is( $! + 0, 0, '$! still clean' ); ok( chown( -1, $egid, $filename ), 'chown\'ing file to only GID', ); is( $! + 0, 0, '$! still clean' ); ok( chown( $euid, $egid, $filename ), 'chown\'ing file to both UID and GID', ); is( $! + 0, 0, '$! still clean' ); } ); subtest( 'chown to different group of same user' => sub { # See if this user has another group available # (we might be on a user that has only one group) $next_gid or skip_all('This user only has one group'); is( $top_gid, $egid, 'Skipping the first GID' ); isnt( $next_gid, $egid, 'Testing a different GID' ); is( $! + 0, 0, '$! starts clean' ); ok( chown( -1, $next_gid, $filename ), 'chown\'ing file to a different GID', ); is( $! + 0, 0, '$! stays clean' ); } ); subtest( 'chown on typeglob / filehandle' => sub { my $filename = '/tmp/not-a-file'; my $file = Test::MockFile->file($filename); open my $fh, '>', $filename or die; print {$fh} "whatevs\n" or die; my ( $exp_euid, $exp_egid ) = $is_root ? ( $euid + 9999, $egid + 9999 ) : ( $euid, $egid ); if ($is_root) { is( $! + 0, 0, '$! starts clean' ); is( chown( $exp_euid, $exp_egid, $fh ), 1, 'root chown on a file handle works' ); is( $! + 0, 0, '$! stays clean' ); } else { is( $! + 0, 0, '$! starts clean' ); is( chown( $exp_euid, $exp_egid, $fh ), 1, 'Non-root chown on a file handle works' ); is( $! + 0, 0, '$! stays clean' ); } close $fh or die; my ( $dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, $blksize, $blocks ) = stat($filename); is( $uid, $exp_euid, "Owner of the file is now there" ); is( $gid, $exp_egid, "Group of the file is now there" ); } ); subtest( 'chown does not reset $!' => sub { my $file = Test::MockFile->file( '/foo' => 'bar' ); $! = 3; is( $! + 0, 3, '$! is set to 3 for our test' ); ok( chown( -1, -1, '/foo' ), 'Successfully run chown' ); is( $! + 0, 3, '$! is still 3 (not reset by chown)' ); } ); done_testing(); exit; Test-MockFile-0.037/t/sysopen.t0000644000000000000000000001471614341720311014764 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use File::Temp qw/tempfile tempdir/; use File::Slurper (); use Fcntl; #use Errno qw/ENOENT EBADF/; use Test::MockFile qw< nostrict >; # Everything below this can have its open overridden. my ( undef, $filename ) = tempfile(); unlink $filename; { note "-------------- REAL MODE --------------"; is( sysopen( my $fh, $filename, O_WRONLY | O_CREAT | O_EXCL | O_TRUNC ), 1, "Sysopen for write" ); my $str = join( "", "a" .. "z" ); is( syswrite( $fh, $str ), 26, "2 arg syswrite" ); my $str_cap = join( "", "A" .. "Y" ); is( syswrite( $fh, $str_cap, 13 ), 13, "3 arg syswrite" ); is( syswrite( $fh, $str_cap, 12, 13 ), 12, "4 arg syswrite" ); is( close $fh, 1, "sysclose \$fh" ); is( File::Slurper::read_binary($filename), $str . $str_cap, "file contents match what was written" ); unlink $filename; } { my $str = join( "", "a" .. "z" ); my $str_cap = join( "", "A" .. "Y" ); note "-------------- MOCK MODE --------------"; my $bar = Test::MockFile->file($filename); is( sysopen( my $fh, $filename, O_WRONLY | O_CREAT | O_EXCL | O_TRUNC ), 1, "Sysopen for write" ); is( syswrite( $fh, $str ), 26, "2 arg syswrite" ); is( syswrite( $fh, $str_cap, 13 ), 13, "3 arg syswrite" ); is( syswrite( $fh, $str_cap, 12, 13 ), 12, "4 arg syswrite" ); is( close $fh, 1, "sysclose \$fh" ); is( $bar->contents, $str . $str_cap, "Fake file contents match what was written" ); undef $bar; ok( !-e $filename, "mocked $filename is not present after mock file goes offline" ); } is( \%Test::MockFile::files_being_mocked, {}, "No mock files are in cache" ) or die; { my $str = join( "", "a" .. "z" ); my $str_cap = join( "", "A" .. "Y" ); note "-------------- REAL MODE --------------"; File::Slurper::write_binary( $filename, $str_cap . $str ); is( sysopen( my $fh, $filename, O_RDONLY | O_NOFOLLOW ), 1, "Sysopen for read" ); my $buf = "blah"; is( sysread( $fh, $buf, 2, 4 ), 2, "Read 2 into buf at EOL" ); is( $buf, "blahAB", "Confirm 2 line read" ); is( sysread( $fh, $buf, 2, 0 ), 2, "Read into buf at pos 0 truncates the buffer." ); is( $buf, "CD", "Confirm 2 line read" ); $buf = "a" x 10; is( sysread( $fh, $buf, 0, 0 ), 0, "Read 0 into buf at pos 0 truncates the buffer completely." ); is( $buf, "", "Buffer is clear" ); $buf = "b" x 10; is( sysread( $fh, $buf, 2, 5 ), 2, "Read 2 into buf at pos 5 truncates after the buffer." ); is( $buf, "bbbbbEF", "Line is as expected." ); $buf = "c" x 2; is( sysread( $fh, $buf, 3, 6 ), 3, "Read 3 into buf after EOL for the buffer fills in zeroes." ); is( $buf, "cc\0\0\0\0GHI", "Buffer has null bytes in the middle of it." ); $buf = "d" x 5; is( seek( $fh, 49, 0 ), 1, "Seek to near EOF" ); is( sysread( $fh, $buf, 4 ), 2, "Read 2 into buf since we're at EOF" ); is( $buf, "yz", "Buffer is clear" ); ok( seek( $fh, 0, 0 ), 0, "Seek to start of file returns true" ); is( sysseek( $fh, 0, 0 ), "0 but true", "sysseek to start of file returns '0 but true' to make it so." ); ok( sysseek( $fh, 0, 0 ), "sysseek to start of file returns true when checked with ok()" ); } { my $str = join( "", "a" .. "z" ); my $str_cap = join( "", "A" .. "Y" ); note "-------------- MOCK MODE --------------"; my $bar = Test::MockFile->file( $filename, $str_cap . $str ); is( sysopen( my $fh, $filename, O_RDONLY | O_NOFOLLOW ), 1, "Sysopen for read" ); like( "$fh", qr/^IO::File=GLOB\(0x[0-9a-f]+\)$/, '$fh stringifies to a IO::File GLOB' ); my $buf = "blah"; is( sysread( $fh, $buf, 2, 4 ), 2, "Read 2 into buf at EOL" ); is( $buf, "blahAB", "Confirm 2 line read" ); is( sysread( $fh, $buf, 2, 0 ), 2, "Read into buf at pos 0 truncates the buffer." ); is( $buf, "CD", "Confirm 2 line read" ); $buf = "a" x 10; is( sysread( $fh, $buf, 0, 0 ), 0, "Read 0 into buf at pos 0 truncates the buffer completely." ); is( $buf, "", "Buffer is clear" ); $buf = "b" x 10; is( sysread( $fh, $buf, 2, 5 ), 2, "Read 2 into buf at pos 5 truncates after the buffer." ); is( $buf, "bbbbbEF", "Line is as expected." ); $buf = "c" x 2; is( sysread( $fh, $buf, 3, 6 ), 3, "Read 3 into buf after EOL for the buffer fills in zeroes." ); is( $buf, "cc\0\0\0\0GHI", "Buffer has null bytes in the middle of it." ); $buf = "d" x 5; is( seek( $fh, 49, 0 ), 49, "Seek to near EOF" ); is( sysread( $fh, $buf, 4 ), 2, "Read 2 into buf since we're at EOF" ); is( $buf, "yz", "Buffer is clear" ); ok( seek( $fh, 0, 0 ), 0, "Seek to start of file returns true" ); is( sysseek( $fh, 0, 0 ), "0 but true", "sysseek to start of file returns '0 but true' to make it so." ); ok( sysseek( $fh, 0, 0 ), "sysseek to start of file returns true when checked with ok()" ); close $fh; undef $bar; } { my $str = join( "", "a" .. "z" ); my $str_cap = join( "", "A" .. "Y" ); note "-------------- REAL MODE --------------"; File::Slurper::write_binary( $filename, $str_cap . $str ); is( sysopen( my $fh, $filename, O_RDONLY | O_NOFOLLOW ), 1, "Sysopen for read" ); my $buf; is( sysread( $fh, $buf, 2 ), 2, "Read 2 into buf when buf is undef." ); is( $buf, "AB", "Confirm 2 char is read" ); unlink $filename; } { my $str = join( "", "a" .. "z" ); my $str_cap = join( "", "A" .. "Y" ); note "-------------- MOCK MODE --------------"; my $bar = Test::MockFile->file( $filename, $str_cap . $str ); is( sysopen( my $fh, $filename, O_RDONLY | O_NOFOLLOW ), 1, "Sysopen for read" ); my $buf; is( sysread( $fh, $buf, 2 ), 2, "Read 2 into buf when buf is undef." ); is( $buf, "AB", "Confirm 2 char is read" ); } is( \%Test::MockFile::files_being_mocked, {}, "No mock files are in cache" ); done_testing(); exit; Test-MockFile-0.037/t/plugin.t0000644000000000000000000000632114341720311014553 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use FindBin; use lib map { "$FindBin::Bin/$_" } qw{ ./lib ../lib }; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use File::Temp (); use File::Path (); use File::Slurper qw{ write_text }; use Test::TMF qw ( tmf_test_code ); my $test_code; $test_code = <<'EOS'; use Test::MockFile ( plugin => q[Unknown] ); EOS tmf_test_code( name => q[Cannot find a Test::MockFile plugin for Unknown], exit => 512, test => sub { my ($out) = @_; #note explain $out; like $out->{output}, qr{Cannot find a Test::MockFile plugin for Unknown}, 'Cannot find a Test::MockFile plugin for Unknown'; return; }, test_code => $test_code, debug => 0, ); # ------------------------------------------------------------------------------------ my $tmp = File::Temp->newdir(); my $base_dir = "$tmp/Test/MockFile/Plugin"; ok File::Path::make_path($base_dir), "create Test/MockFile/Plugin dir for testing"; my $MyPlugin_filename = "$base_dir/MyPlugin.pm"; File::Slurper::write_text( $MyPlugin_filename, <<"EOS" ); package Test::MockFile::Plugin::MyPlugin; use base 'Test::MockFile::Plugin'; sub register { print qq[MyPlugin is now registered!\n]; } 1 EOS $test_code = <<'EOS'; use Test::MockFile ( plugin => q[MyPlugin] ); ok 1; EOS tmf_test_code( name => q[Loading a plugin from default namespace], perl_args => ["-I$tmp"], exit => 0, test => sub { my ($out) = @_; like $out->{output}, qr{MyPlugin is now registered}, 'load and register plugin'; return; }, test_code => $test_code, debug => 0, ); $test_code = <<'EOS'; use Test::MockFile ( plugin => [ 'MyPlugin' ] ); ok 1; EOS tmf_test_code( name => q[use Test::MockFile ( plugin => [ 'MyPlugin' ] )], perl_args => ["-I$tmp"], exit => 0, test => sub { my ($out) = @_; like $out->{output}, qr{MyPlugin is now registered}, 'load and register plugin'; return; }, test_code => $test_code, debug => 0, ); # ------------------------------------------------------------------------------------ note "Testing a custom namespace"; $base_dir = "$tmp/CustomPluginNamespace"; ok File::Path::make_path($base_dir), "create Test/MockFile/Plugin dir for testing"; my $AnotherPlugin_filename = "$base_dir/Another.pm"; File::Slurper::write_text( $AnotherPlugin_filename, <<"EOS" ); package CustomPluginNamespace::Another; use base 'Test::MockFile::Plugin'; sub register { print qq[AnotherPlugin from a Custom namespace is now registered!\n]; } 1 EOS $test_code = <<'EOS'; BEGIN { require Test::MockFile::Plugins; push @Test::MockFile::Plugins::NAMESPACES, 'CustomPluginNamespace'; } use Test::MockFile ( plugin => q[Another] ); ok 1; EOS tmf_test_code( name => q[Loading a plugin from default namespace], perl_args => ["-I$tmp"], exit => 0, test => sub { my ($out) = @_; #note explain $out; like $out->{output}, qr{AnotherPlugin from a Custom namespace is now registered!}, 'load and register plugin from a custom namespace'; return; }, test_code => $test_code, debug => 0, ); done_testing; Test-MockFile-0.037/t/manifest.t0000644000000000000000000000064714341720311015070 0ustar rootroot#!perl -T use 5.006; use strict; use warnings; use Test::More; plan( skip_all => "Test::CheckManifest is broken - https://github.com/reneeb/Test-CheckManifest/issues/20" ); unless ( $ENV{RELEASE_TESTING} ) { plan( skip_all => "Author tests not required for installation" ); } my $min_tcm = 0.9; eval "use Test::CheckManifest $min_tcm"; plan skip_all => "Test::CheckManifest $min_tcm required" if $@; ok_manifest(); Test-MockFile-0.037/t/writeline.t0000644000000000000000000000406614341720311015263 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use File::Temp qw/tempfile/; use Test::MockFile qw; # Everything below this can have its open overridden. note "-------------- REAL MODE --------------"; my ( $fh_real, $filename ) = tempfile(); print $fh_real "will be thrown out"; close $fh_real; is( -s $filename, 18, "tempfile originally writes out 16 bytes" ); is( open( $fh_real, ">", $filename ), 1, "Open file for overwrite" ); like( "$fh_real", qr/^GLOB\(0x[0-9a-f]+\)$/, '$real_fh stringifies to a GLOB' ); print {$fh_real} "not\nmocked\n"; is( close $fh_real, 1, "Close \$real_fh" ); ok( $!, '$! hasn\'t been cleared' ); is( -s $filename, 11, "Temp file is on disk and right size assuming a re-write happened." ); note "-------------- MOCK MODE --------------"; my $bar = Test::MockFile->file($filename); is( open( my $fh, '>', $filename ), 1, "Mocked temp file opens for write and returns true" ); isa_ok( $fh, ["IO::File"], '$fh is a IO::File' ); like( "$fh", qr/^IO::File=GLOB\(0x[0-9a-f]+\)$/, '$fh stringifies to a IO::File GLOB' ); my $oneline = "Just one line"; is( ( print {$fh} $oneline ), 13, "overwrite the contents" ); is( $bar->contents, $oneline, '$foo->contents reflects an overwrite' ); is( close($fh), 1, 'Close $fh' ); ok( $!, '$! hasn\'t been cleared' ); is( open( $fh, '>>', $filename ), 1, 'Re-open $fh for append' ); is( ( print $fh " but really long\n" ), 17, "Append line" ); my $bytes = printf $fh "%04d", 42; is( $bytes, 4, "Append line with a printf" ); is( $bar->contents, "$oneline but really long\n0042", '$foo->contents reflects an append' ); my $undef_len = print $fh undef; is( $undef_len, 0, "Printing undef returns 0 and is not a warning." ); is( close($fh), 1, 'Close $fh' ); ok( $!, '$! hasn\'t been cleared' ); undef $bar; note "-------------- REAL MODE --------------"; is( -s $filename, 11, "Temp file on disk is unaltered once \$bar is clear." ); done_testing(); Test-MockFile-0.037/t/symlink.t0000644000000000000000000000160214341720311014740 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Test2::Tools::Exception qw< lives dies >; use Test::MockFile; my $dir = Test::MockFile->dir('/foo'); my $file = Test::MockFile->file('/bar'); ok( !-d ('/foo'), 'Directory does not exist yet' ); my $symlink = Test::MockFile->symlink( '/bar', '/foo/baz' ); ok( -d ('/foo'), 'Directory now exists' ); { opendir my $dh, '/foo' or die $!; my @content = readdir $dh; closedir $dh or die $!; is( \@content, [qw< . .. baz >], 'Directory with symlink content are correct', ); } undef $symlink; { opendir my $dh, '/foo' or die $!; my @content = readdir $dh; closedir $dh or die $!; is( \@content, [qw< . .. >], 'Directory no longer has symlink', ); } done_testing(); exit 0; Test-MockFile-0.037/t/strict-rules_file-temp-example.t0000644000000000000000000000337714341720311021320 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use File::Temp (); # not loaded under strict mode... use Test::MockFile qw< strict >; # yeap it's strict { ### ### Without mock ### my ( $tmp_fh, $tmp ) = File::Temp::tempfile; like dies { open( my $fh, ">", "$tmp" ) }, qr{Use of open to access unmocked file or directory}, "Cannot open an unmocked file in strict mode"; my $tempdir = File::Temp::tempdir( CLEANUP => 1 ); like dies { opendir( my $dh, "$tempdir" ) }, qr{Use of opendir to access unmocked}, "Cannot open directory from tempdir"; } { ## ## After mock ## ok _setup_strict_rules_for_file_temp(), "_setup_strict_rules_for_file_temp"; my ( $tmp_fh, $tmp ) = File::Temp::tempfile; ok lives { open( my $fh, ">", "$tmp" ) }, "we can open a tempfile"; my $tempdir = File::Temp::tempdir( CLEANUP => 1 ); ok lives { opendir( my $dh, "$tempdir" ) }, "Can open directory from tempdir"; } done_testing; sub _setup_strict_rules_for_file_temp { no warnings qw{redefine once}; { my $sub_tempfile = File::Temp->can('tempfile'); *File::Temp::tempfile = sub { my (@in) = @_; my @out = $sub_tempfile->(@in); Test::MockFile::add_strict_rule_for_filename( $out[1] => 1 ); return @out; }; } { my $sub_tempdir = File::Temp->can('tempdir'); *File::Temp::tempdir = sub { my (@in) = @_; my $out = $sub_tempdir->(@in); my $dir = "$out"; Test::MockFile::add_strict_rule_for_filename( [ $dir, qr{^${dir}/} ] => 1 ); return $out; }; } return 1; } Test-MockFile-0.037/t/00-load.t0000644000000000000000000000066514341720311014416 0ustar rootroot#!perl -T use 5.006; use strict; use warnings; use Test::More; plan tests => 3; BEGIN { use_ok('Test::MockFile') || print "Bail out!\n"; use_ok('Overload::FileCheck') || print "Bail out!\n"; use_ok('File::Temp') || print "Bail out!\n"; } diag("Testing Test::MockFile $Test::MockFile::VERSION with Overload::FileCheck $Overload::FileCheck::VERSION and File::Temp $File::Temp::VERSION"); diag("Perl $], $^X"); Test-MockFile-0.037/t/rmdir.t0000644000000000000000000001001414341720311014364 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Errno qw/ENOENT EISDIR EEXIST ENOTDIR/; use File::Temp qw/tempfile tempdir/; my $temp_dir_name = tempdir( CLEANUP => 1 ); CORE::rmdir $temp_dir_name; use Test::MockFile qw< nostrict >; # Proves umask works in this test. umask 022; subtest "basic rmdir" => sub { $! = 0; is( CORE::mkdir($temp_dir_name), 1, "REAL mkdir when dir is missing." ); is( $! + 0, 0, ' - $! is unset.' ) or diag "$!"; is( CORE::rmdir $temp_dir_name, 1, "REAL rmdir when dir is there" ); my $mock = Test::MockFile->dir($temp_dir_name); is( mkdir($temp_dir_name), 1, "MOCK mkdir when dir is missing." ); is( $! + 0, 0, ' - $! is unset.' ) or diag "$!"; is( $mock->permissions, 0755, "Perms are 0755" ); ok( -d $temp_dir_name, "-d" ); is( $! + 0, 0, ' - $! is unset.' ) or diag "$!"; is( rmdir $temp_dir_name, 1, "MOCK rmdir when dir is there" ); is( $! + 0, 0, ' - $! is unset.' ) or diag "$!"; ok( !-d $temp_dir_name, "Directory is not there with -d" ); ok( !-e $temp_dir_name, "Directory is not there with -e" ); }; subtest "undef rmdir" => sub { my $returns; local $_; like( warning { $returns = CORE::rmdir() }, qr/^Use of uninitialized value \$_ in rmdir at.+\n$/, "REAL mkdir when nothing is passed as the directory." ); is( $returns, 0, " - returns 0" ); like( warning { $returns = CORE::rmdir(undef) }, qr/^Use of uninitialized value in rmdir at.+\n$/, "REAL mkdir when undef is passed as the directory." ); is( $returns, 0, " - returns 0" ); local $_; like( warning { $returns = rmdir(undef) }, qr/^Use of uninitialized value in rmdir at.+\n$/, "REAL mkdir when undef is passed as the directory." ); is( $returns, 0, " - returns 0" ); }; subtest "rmdir existing file" => sub { CORE::mkdir $temp_dir_name; my $temp_file = "$temp_dir_name/a"; touch($temp_file); $! = 0; is( rmdir($temp_file), 0, "real rmdir on existing file." ); is( $! + 0, ENOTDIR, ' - $! is ENOTDIR.' ) or diag "$!"; CORE::unlink $temp_file; my $m = Test::MockFile->file( '/abc', '' ); $! = 0; is( rmdir('/abc'), 0, "mock rmdir on existing file." ); is( $! + 0, ENOTDIR, ' - $! is ENOTDIR.' ) or diag "$!"; }; subtest "rmdir existing symlink" => sub { CORE::mkdir $temp_dir_name; my $temp_file = "$temp_dir_name/a"; CORE::symlink( "$temp_dir_name/ab", $temp_file ); $! = 0; is( rmdir($temp_file), 0, "real rmdir on existing file." ); is( $! + 0, ENOTDIR, ' - $! is ENOTDIR.' ) or diag "$!"; CORE::unlink $temp_file; my $m = Test::MockFile->symlink( '/someotherpath', '/abc' ); $! = 0; is( rmdir('/abc'), 0, "mock rmdir on existing file." ); is( $! + 0, ENOTDIR, ' - $! is ENOTDIR.' ) or diag "$!"; }; subtest "rmdir when nothing is there." => sub { CORE::mkdir $temp_dir_name; my $temp_dir = "$temp_dir_name/a"; $! = 0; is( rmdir($temp_dir), 0, "real rmdir on existing file." ); is( $! + 0, ENOENT, ' - $! is ENOENT.' ) or diag "$!"; my $m = Test::MockFile->dir('/abc'); $! = 0; is( rmdir('/abc'), 0, "mock rmdir on existing file." ); is( $! + 0, ENOENT, ' - $! is ENOENT.' ) or diag "$!"; }; subtest( 'rmdir non-empty directory fails' => sub { my $foo = Test::MockFile->dir('/foo'); my $bar = Test::MockFile->file( '/foo/bar', 'content' ); $! = 0; ok( -e ('/foo/bar'), 'File exists' ); ok( -d ('/foo'), 'Directory exists' ); is( $! + 0, 0, 'No errors yet' ); ok( !rmdir('/foo'), 'rmdir failed because directory has files' ); is( $! + 0, 39, '$! is set to correct perror (39)' ); } ); done_testing(); sub touch { my $path = shift or die; CORE::open( my $fh, '>>', $path ) or die; print $fh ''; close $fh; return 1; } Test-MockFile-0.037/t/mock_stat.t0000644000000000000000000001327414341720311015246 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Test::MockFile qw< nostrict >; use Overload::FileCheck qw/:check/; use Errno qw/ELOOP/; use Cwd (); # Assures testers don't mess up with our hard coded perms expectations. umask 022; note "_abs_path_to_file"; my $cwd = Cwd::getcwd(); is( Test::MockFile::_abs_path_to_file("0"), "$cwd/0", "no / prefix makes prepends path on it" ); is( Test::MockFile::_abs_path_to_file(), undef, "undef is undef" ); my @abs_path = ( [ '/lib' => '/lib' ], [ '/lib/' => '/lib' ], [ '/abc/.' => '/abc' ], [ '/abc/./' => '/abc' ], [ '/abc/./././.' => '/abc' ], [ '/from/here/or-not/..' => '/from/here' ], [ '/../../..' => '/' ], [ '/one/two/three/four/../../..' => '/one' ], [ '/a.b.c.d' => '/a.b.c.d' ], ); foreach my $t (@abs_path) { my ( $path, $normalized_path ) = @$t; is( Test::MockFile::_abs_path_to_file($path), $normalized_path, "_abs_path_to_file( '$path' ) = '$normalized_path'" ); } note "_fh_to_file"; my @mocked_files; push @mocked_files, Test::MockFile->file( '/foo/bar', "" ); push @mocked_files, Test::MockFile->file( '/bar/foo', "" ); open( my $fh, "<", "/foo/bar" ) or die; open( my $fh2, "<", "/bar/foo" ) or die; is( Test::MockFile::_fh_to_file(), undef, "_fh_to_file()" ); is( Test::MockFile::_fh_to_file(0), undef, "_fh_to_file(0)" ); is( Test::MockFile::_fh_to_file(''), undef, "_fh_to_file('')" ); is( Test::MockFile::_fh_to_file(' '), undef, "_fh_to_file(' ')" ); is( Test::MockFile::_fh_to_file('/etc/passwd'), undef, "_fh_to_file('/etc/passwd')" ); is( Test::MockFile::_fh_to_file($fh), '/foo/bar', "_fh_to_file(\$fh)" ); is( Test::MockFile::_fh_to_file($fh2), '/bar/foo', "_fh_to_file(\$fh2)" ); close $fh; close $fh2; is( Test::MockFile::_fh_to_file($fh), undef, "_fh_to_file(\$fh) when closed." ); note "_find_file_or_fh"; push @mocked_files, Test::MockFile->symlink( '/foo/bar', '/abc' ); is( Test::MockFile::_find_file_or_fh('/abc'), '/abc', "_find_file_or_fh('/abc')" ); is( Test::MockFile::_find_file_or_fh( '/abc', 1 ), '/foo/bar', "_find_file_or_fh('/abc', 1) - follow" ); push @mocked_files, Test::MockFile->symlink( '/not/a/file', '/broken_link' ); is( Test::MockFile::_find_file_or_fh( '/broken_link', 1 ), Test::MockFile::BROKEN_SYMLINK(), "_find_file_or_fh('/broken_link', 1) is undef when /broken_link is mocked." ); push @mocked_files, Test::MockFile->symlink( '/aaa', '/bbb' ); push @mocked_files, Test::MockFile->symlink( '/bbb', '/aaa' ); is( Test::MockFile::_find_file_or_fh( '/aaa', 1 ), Test::MockFile::CIRCULAR_SYMLINK(), "_find_file_or_fh('/aaaa', 1) - with circular links" ); is( $! + 0, ELOOP, '$! is ELOOP' ); note "_mock_stat"; is( Test::MockFile::_mock_stat( 'lstat', "/lib" ), FALLBACK_TO_REAL_OP(), "An unmocked file will return FALLBACK_TO_REAL_OP() to tell XS to handle it" ); like( dies { Test::MockFile::_mock_stat() }, qr/^_mock_stat called without a stat type at /, "no args fails cause we should have gotten a stat type." ); like( dies { Test::MockFile::_mock_stat( 'notastat', '' ) }, qr/^Unexpected stat type 'notastat' at /, "An unknown stat type fails cause this should never happen." ); is( Test::MockFile::_mock_stat( 'lstat', "" ), FALLBACK_TO_REAL_OP(), "empty string passes to XS" ); is( Test::MockFile::_mock_stat( 'stat', ' ' ), FALLBACK_TO_REAL_OP(), "A space string passes to XS" ); my $basic_stat_return = array { item 0; item 0; item 0100644; item 0; item match qr/^[0-9]+$/; item match qr/^[0-9\s]+$/; item 0; item 0; item match qr/^[0-9]{3,}$/; item match qr/^[0-9]{3,}$/; item match qr/^[0-9]{3,}$/; item 4096; item 1; }; is( Test::MockFile::_mock_stat( 'lstat', '/foo/bar' ), $basic_stat_return, "/foo/bar mock stat" ); is( Test::MockFile::_mock_stat( 'stat', '/aaa' ), [], "/aaa mock stat when looped." ); is( $! + 0, ELOOP, "Throws an ELOOP error" ); push @mocked_files, Test::MockFile->file('/foo/baz'); # Missing file but mocked. is( Test::MockFile::_mock_stat( 'lstat', '/foo/baz' ), [], "/foo/baz mock stat when missing." ); my $symlink_lstat_return = array { item 0; item 0; item 0127777; item 0; item match qr/^[0-9]+$/; item match qr/^[0-9\s]+$/; item 0; item 1; item match qr/^[0-9]{3,}$/; item match qr/^[0-9]{3,}$/; item match qr/^[0-9]{3,}$/; item 4096; item 1; }; is( Test::MockFile::_mock_stat( 'lstat', '/broken_link' ), $symlink_lstat_return, "lstat on /broken_link returns the stat on the symlink itself." ); is( Test::MockFile::_mock_stat( 'stat', '/broken_link' ), [], "stat on /broken_link is an empty array since what it points to doesn't exist." ); { my $exe = q[/tmp/custom.exe]; my $tmp = Test::MockFile->file( $exe, " ", { mode => 0700 } ); ok -x $exe, "mocked file is executable"; my ( $dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, $blksize, $blocks ) = stat($exe); is $uid, $>, 'default uid is current UID'; note "GID $gid"; is $gid, int $), 'default fid is current GID'; } { # make sure directories with trailing slash are not ignored by stat by accident my $dir = Test::MockFile->dir('/quux'); mkdir $dir->path(); ok( -d ( $dir->path() ), 'Directory /quux exists' ); ok( -d ( $dir->path() . '/' ), 'Directory /quux/ also exists' ); } done_testing(); exit; Test-MockFile-0.037/t/dir_interface.t0000644000000000000000000001034714341720311016056 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Test2::Tools::Exception qw< lives dies >; use Test::MockFile; sub test_content_with_keywords { my ( $dirname, $dir_content ) = @_; my $dh; my $open; ok( lives( sub { $open = opendir $dh, $dirname } ), "opendir() $dirname successful", ); $open or return; my @content; ok( lives( sub { @content = readdir($dh) } ), "readdir() on $dirname successful", ); is( \@content, $dir_content, 'Correct directory content through Perl core keywords', ); ok( lives( sub { closedir $dh } ), "closedir() on $dirname successful", ); } my $count = 0; my $get_dirname = sub { $count++; return "/foo$count"; }; subtest( '->dir() checks' => sub { like( dies( sub { Test::MockFile->dir( '/etc', [ 'foo', 'bar' ], { 1 => 2 } ) } ), qr!^\QYou cannot set stats for nonexistent dir '/etc'\E!xms, 'Cannot do TMF->dir( "/etc", [@content], { 1 => 2 } )', ); like( dies( sub { Test::MockFile->dir( '/etc', [ 'foo', 'bar' ] ) } ), qr!^\QYou cannot set stats for nonexistent dir '/etc'\E!xms, 'Cannot do TMF->dir( "/etc", [@content] )', ); } ); subtest( 'Scenario 1: ->dir() does not create dir, keywords do' => sub { my $dirname = $get_dirname->(); my $dir = Test::MockFile->dir($dirname); ok( !-d $dirname, "Directory $dirname does not exist yet" ); ok( mkdir($dirname), "Directory $dirname got created" ); ok( -d $dirname, "Directory $dirname now exists" ); is( $dir->contents(), [qw< . .. >], 'Correct contents of directory through ->contents()', ); test_content_with_keywords( $dirname, [qw< . .. >] ); } ); subtest( 'Scenario 2: ->dir() on an already existing dir fails made with ->dir()' => sub { my $dirname = $get_dirname->(); my $file = Test::MockFile->file( "$dirname/bar", 'my content' ); my $dir = Test::MockFile->dir($dirname); ok( -d $dirname, "-d $dirname succeeds, dir exists" ); ok( !mkdir($dirname), "mkdir $dirname fails, dir already exists" ); test_content_with_keywords( $dirname, [qw< . .. bar >] ); } ); subtest( 'Scneario 3: Undef files with ->file() do not create dirs, adding content changes dir' => sub { my $dirname = $get_dirname->(); my $dir = Test::MockFile->dir($dirname); ok( !-d $dirname, "-d $dirname fails, does not exist yet" ); my $file = Test::MockFile->file("$dirname/foo"); ok( !-d $dirname, "-d $dirname still fails after mocking file with no content" ); ok( mkdir($dirname), "mkdir $dirname works" ); ok( -d $dirname, "-d $dirname now succeeds" ); is( $dir->contents(), [qw< . .. >], "Correct contents to $dirname", ); test_content_with_keywords( $dirname, [qw< . .. >] ); ok( !-e "$dirname/foo", "$dirname/foo does not exist, even if $dirname does" ); $file->contents("hello"); ok( -e "$dirname/foo", "After file->contents(), $dirname/foo exists" ); is( $dir->contents(), [qw< . .. foo >], "Correct updated contents to $dirname", ); test_content_with_keywords( $dirname, [qw< . .. foo >] ); } ); subtest( 'Scenario 4: Creating ->file() with content creates dir' => sub { my $dirname = $get_dirname->(); my $dir = Test::MockFile->dir($dirname); ok( !-d $dirname, "$dirname does not exist yet" ); my $file = Test::MockFile->file( "$dirname/foo", 'some content' ); ok( -d $dirname, "$dirname now exists, after creating file with content" ); ok( !mkdir($dirname), "mkdir $dirname fails, since dir already exists" ); is( $dir->contents(), [qw< . .. foo >], "Correct contents to $dirname", ); test_content_with_keywords( $dirname, [qw< . .. foo >] ); } ); done_testing(); Test-MockFile-0.037/t/plugin-filetemp.t0000644000000000000000000000262314341720311016357 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Test2::V0; use Test2::Plugin::NoWarnings; BEGIN { skip_all("Skip for now < 5.28") unless $^V ge 5.28.0; } # Do not load File::Temp to ensure this can be loaded under Test::MockFile my $has_filetemp_before_load; BEGIN { $has_filetemp_before_load = $INC{'File/Temp.pm'}; } use Test::MockFile 'strict', plugin => 'FileTemp'; ok !$has_filetemp_before_load, "File::Temp is not loaded before Test::MockFile"; ok $INC{'File/Temp.pm'}, 'File::Temp is loaded'; require File::Temp; # not really needed { my ( $tmp_fh, $tmp ) = File::Temp::tempfile; ok lives { open( my $fh, ">", "$tmp" ) }, "we can open a tempfile"; { my $tempdir = File::Temp::tempdir( CLEANUP => 1 ); ok lives { opendir( my $dh, "$tempdir" ) }, "Can open directory from tempdir"; ok lives { open( my $fh, ">", "$tempdir/here" ) }, "we can open a tempfile under a tempdir"; } # scalar context { my $fh = File::Temp::tempfile; ok lives { print {$fh} "test" }, "print to a tempfile - scalar context"; } } { my $dir = File::Temp->newdir(); ok opendir( my $dh, "$dir" ), "opendir - newdir"; ok open( my $f, '>', "$dir/myfile.txt" ), "open a file created under newdir"; } { my $fh = File::Temp::tempfile(); is( scalar( ( stat $fh )[3] ), 0, "tempfile in scalar context" ); } done_testing; Test-MockFile-0.037/t/opendir.t0000644000000000000000000001120715011450405014713 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use File::Temp qw/tempfile tempdir/; use File::Basename; use Errno qw/ENOENT EBADF ENOTDIR/; use Test::MockFile qw< nostrict >; # Everything below this can have its open overridden. my $temp_dir = tempdir( CLEANUP => 1 ); my ( undef, $filename ) = tempfile( DIR => $temp_dir ); my ( undef, $temp_notdir ) = tempfile(); note "-------------- REAL MODE --------------"; is( -d $temp_dir, 1, "Temp is created on disk." ); is( opendir( my $dir_fh, $temp_dir ), 1, "$temp_dir can be read" ); my @dir_files; push @dir_files, scalar readdir($dir_fh); push @dir_files, scalar readdir($dir_fh); push @dir_files, scalar readdir($dir_fh); my $base = basename $filename; is( [ sort @dir_files ], [ sort( qw/. .. /, $base ) ], "We read 3 entries in some order. Not predictable, but sort fixes that!" ); is( scalar readdir($dir_fh), undef, "undef when nothing left from readdir." ); is( closedir($dir_fh), 1, "close the fake dir handle" ); like( warning { readdir($dir_fh) }, qr/^readdir\(\) attempted on invalid dirhandle \S+ /, "warn on readdir when file handle is closed." ); is( opendir( my $bad_fh, "/not/a/valid/path/kdshjfkjd" ), undef, "opendir on a bad path returns false" ); is( $! + 0, ENOENT, '$! numeric is right.' ); is( opendir( my $notdir_fh, $temp_notdir ), undef, "opendir on a file returns false" ); is( $! + 0, ENOTDIR, '$! numeric is right.' ); my ( $real_fh, $f3 ) = tempfile( DIR => $temp_dir ); like( warning { readdir($real_fh) }, qr/^readdir\(\) attempted on (?:invalid dir)?handle \$fh/, "We only warn if the file handle or glob is invalid." ); note "-------------- MOCK MODE --------------"; my $abc = Test::MockFile->file( "$temp_dir/abc", 'hello' ); my $def = Test::MockFile->file( "$temp_dir/def", 'hello' ); my $bar = Test::MockFile->dir($temp_dir); my $baz = Test::MockFile->file( $temp_notdir, '' ); is( opendir( $dir_fh, $temp_dir ), 1, "Mocked temp dir opens and returns true" ); is( scalar readdir($dir_fh), ".", "Read . from fake readdir" ); is( scalar readdir($dir_fh), "..", "Read .. from fake readdir" ); is( telldir($dir_fh), 2, "tell dir in the middle of fake readdir is right." ); is( scalar readdir($dir_fh), "abc", "Read abc from fake readdir" ); is( scalar readdir($dir_fh), "def", "Read def from fake readdir" ); is( telldir($dir_fh), 4, "tell dir at the end of fake readdir is right." ); is( scalar readdir($dir_fh), undef, "Read from fake readdir but no more in the list." ); is( scalar readdir($dir_fh), undef, "Read from fake readdir but no more in the list." ); is( scalar readdir($dir_fh), undef, "Read from fake readdir but no more in the list." ); is( scalar readdir($dir_fh), undef, "Read from fake readdir but no more in the list." ); is( rewinddir($dir_fh), 1, "rewinddir returns true." ); is( telldir($dir_fh), 0, "telldir afer rewinddir is right." ); is( [ readdir($dir_fh) ], [qw/. .. abc def/], "Read the whole dir from fake readdir after rewinddir" ); is( telldir($dir_fh), 4, "tell dir at the end of fake readdir is right." ); is( seekdir( $dir_fh, 1 ), 1, "seekdir returns where it sought." ); is( [ readdir($dir_fh) ], [qw/.. abc def/], "Read the whole dir from fake readdir after seekdir" ); closedir($dir_fh); is( opendir( my $still_notdir_fh, $temp_notdir ), undef, "opendir on a mocked file returns false" ); is( $! + 0, ENOTDIR, '$! numeric is right.' ); # Check symlinks appear in readdir my $dir_for_symlink = Test::MockFile->dir('/foo'); my $dir_in_dir = Test::MockFile->dir('/foo/infoo'); my $symlink_dest = Test::MockFile->file( '/foo/dest', '' ); my $symlink = Test::MockFile->symlink( '/foo/dest', '/foo/source' ); opendir my $sdh, '/foo' or die $!; my @contents = readdir $sdh; closedir $sdh or die $!; is( [ sort @contents ], [qw< . .. dest infoo source >], 'Symlink and directories appears in directory content' ); { my $d1 = Test::MockFile->dir('/foo2/bar'); my $d2 = Test::MockFile->dir('/foo2'); mkdir $d1->path(); mkdir $d2->path(); my $f = Test::MockFile->file( '/foo2/bar/baz', '' ); opendir my $dh, '/foo2' or die $!; my @content = readdir $dh; closedir $dh or die $!; is( \@content, [qw< . .. bar >], 'Did not get confused by internal files' ); } done_testing(); exit; Test-MockFile-0.037/t/globbing.t0000644000000000000000000000426014341720311015040 0ustar rootrootuse strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Test::MockFile; my $file1 = Test::MockFile->file('/file1.txt'); my $file2 = Test::MockFile->file('/file2.txt'); my $file3 = Test::MockFile->file('/file3.jpg'); my $file4 = Test::MockFile->file('/dir1/file4.txt'); my $file5 = Test::MockFile->file('/dir2/file5.jpg'); my $file6 = Test::MockFile->file('/dir3/dir4/file6.jpg'); my $dir5 = Test::MockFile->dir('/dir3/dir5'); my @tests = ( [ [qw< /file1.txt /file2.txt >], '/*.txt' ], [ [qw< /file1.txt /file2.txt /file3.jpg >], '/*.{txt,jp{g}}' ], [ [qw< /file1.txt /file2.txt /file3.jpg >], '/*.txt /*.jpg' ], [ [ '/dir1/file4.txt', '/dir2/file5.jpg', '/dir3/dir4' ], '/*/*' ], [ [ '/dir1/file4.txt', '/dir2/file5.jpg', '/dir3/dir4', '/dir3/dir5' ], '/*/*' ], ); is( [ glob('/*.txt') ], [], 'glob(' . $tests[0][1] . ')', ); is( [], [], '<' . $tests[0][1] . '>', ); $file1->contents('1'); $file2->contents('2'); $file3->contents('3'); $file4->contents('4'); $file5->contents('5'); $file6->contents('6'); is( [ glob('/*.txt') ], $tests[0][0], 'glob(' . $tests[0][1] . ')', ); is( [], $tests[0][0], '<' . $tests[0][1] . '>', ); is( [ glob('/*.{txt,jp{g}}') ], $tests[1][0], 'glob(' . $tests[1][1] . ')', ); is( [], $tests[1][0], '<' . $tests[1][1] . '>', ); is( [], # / (fix syntax highlighting on vim) $tests[2][0], '<' . $tests[2][1] . '>', ); is( [ glob('/*.txt /*.jpg') ], $tests[2][0], 'glob(' . $tests[2][1] . ')', ); is( [], # / (fix syntax highlighting on vim) $tests[3][0], '<' . $tests[3][1] . '>', ); my $top_dir3 = Test::MockFile->dir('/dir3'); ok( -d '/dir3', 'Directory now exists' ); ok( !-d '/dir3/dir5', 'Directory does not exist' ); ok( mkdir('/dir3/dir5'), 'Created directory successfully' ); ok( -d '/dir3/dir5', 'Directory now exists' ); is( [], # / (fix syntax highlighting on vim) $tests[4][0], '<' . $tests[4][1] . '>', ); done_testing(); exit; Test-MockFile-0.037/t/open-noclose.t0000644000000000000000000000235314341720311015657 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Test::MockFile qw< nostrict >; { like( dies { myread() }, qr/Missing file argument/, 'missing file argument' ); my $path = q[/tmp/somewhere]; my $mock_file = Test::MockFile->file($path); like( dies { myread($path) }, qr/Failed to open file/, 'missing file' ); $mock_file->touch; note "empty file"; is myread($path), [], "empty file"; $mock_file->contents( <<'EOS' ); Some content for your eyes only EOS ok !-z $path, "file is not empty"; ok $mock_file->contents; my $out = myread($path); is $out, [ split( /\n/, $mock_file->contents ) ], "$path file should not be empty (on second read)" or diag explain $out; } done_testing; sub myread { my ($script) = @_; die q[Missing file argument] unless defined $script; my @lines; my $fh; #diag explain \%Test::MockFile::files_being_mocked; open( $fh, '<', $script ) or die qq[Failed to open file: $!]; while ( my $line = readline $fh ) { chomp $line; push @lines, $line; } return \@lines; } 1; Test-MockFile-0.037/t/import.t0000644000000000000000000000536714341720311014600 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use FindBin; use lib map { "$FindBin::Bin/$_" } qw{ ./lib ../lib }; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Test::TMF qw ( tmf_test_code ); my $test_code; note "Happy Imports"; $test_code = <<'EOS'; use Test::MockFile (); is $Test::MockFile::STRICT_MODE_STATUS, Test::MockFile::STRICT_MODE_DEFAULT, 'STRICT_MODE_DEFAULT'; is Test::MockFile::is_strict_mode(), 1, "is_strict_mode helper is true"; EOS tmf_test_code( name => q[default mode is STRICT_MODE_DEFAULT], #args => [], exit => 0, # test => sub { # my ($out) = @_; # note explain $out; # }, test_code => $test_code, debug => 0, ); $test_code = <<'EOS'; use Test::MockFile; is $Test::MockFile::STRICT_MODE_STATUS, Test::MockFile::STRICT_MODE_ENABLED, 'STRICT_MODE_ENABLED'; is Test::MockFile::is_strict_mode(), 1, "is_strict_mode helper is true"; EOS tmf_test_code( name => q[import enable STRICT_MODE_ENABLED], exit => 0, test_code => $test_code, debug => 0, ); $test_code = <<'EOS'; use Test::MockFile qw< strict >; is $Test::MockFile::STRICT_MODE_STATUS, Test::MockFile::STRICT_MODE_ENABLED, 'STRICT_MODE_ENABLED'; is Test::MockFile::is_strict_mode(), 1, "is_strict_mode helper is true"; EOS tmf_test_code( name => q[use Test::MockFile qw< strict >], exit => 0, test_code => $test_code, debug => 0, ); $test_code = <<'EOS'; use Test::MockFile qw< nostrict >; is $Test::MockFile::STRICT_MODE_STATUS, Test::MockFile::STRICT_MODE_DISABLED, 'STRICT_MODE_DISABLED'; is Test::MockFile::is_strict_mode(), 0, "is_strict_mode helper is false"; EOS tmf_test_code( name => q[use Test::MockFile qw< nostrict >], exit => 0, test_code => $test_code, debug => 0, ); $test_code = <<'EOS'; use Test::MockFile qw< strict >; use Test::MockFile qw< strict >; is $Test::MockFile::STRICT_MODE_STATUS, Test::MockFile::STRICT_MODE_ENABLED, 'STRICT_MODE_ENABLED'; is Test::MockFile::is_strict_mode(), 1, "is_strict_mode helper is true"; EOS tmf_test_code( name => q[multiple - use Test::MockFile qw< strict >], exit => 0, test_code => $test_code, debug => 0, ); note "Failed Imports"; $test_code = <<'EOS'; use Test::MockFile qw< strict >; use Test::MockFile qw< nostrict >; EOS tmf_test_code( name => q[use Test::MockFile qw< strict > + qw< nostrict >], exit => 65280, test_code => $test_code, debug => 0, ); $test_code = <<'EOS'; use Test::MockFile; use Test::MockFile qw< nostrict >; EOS tmf_test_code( name => q[use Test::MockFile + qw< nostrict >], exit => 65280, test_code => $test_code, debug => 0, ); done_testing(); Test-MockFile-0.037/t/path.t0000644000000000000000000000072614341720311014214 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Test::MockFile qw< nostrict >; my $path = '/some/nonexistant/path'; my $mock = Test::MockFile->file($path); is( $mock->path(), $path, "$path is set when the file isn't there." ); open( my $fh, '>', $path ) or die; print $fh "abc"; close $fh; is( $mock->path(), $path, "$path is set when the file is there." ); done_testing(); Test-MockFile-0.037/t/open_strict.t0000644000000000000000000000103714341717063015617 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Plugin::NoWarnings; use Test::MockFile; pipe my $fh, my $wfh; my $fh_str = "$fh"; my $err = dies { open my $fh2, '<', $fh }; like( $err, qr<\Q$fh_str\E>, 'open() to read a filehandle fails', ); ok( lives { open my $fh2, '<&', fileno $fh }, 'open() to dup a file descriptor works', ) or note $@; ok( lives { open my $fh2, '<&=', fileno $fh }, 'open() to re-perlify a file descriptor works', ) or note $@; done_testing; 1; Test-MockFile-0.037/t/detect-common-mistakes.t0000644000000000000000000001064614341720311017636 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Test2::Tools::Exception qw< lives dies >; use Test::MockFile; subtest( 'Removing trailing forward slash for directories' => sub { my $dir0; ok( lives( sub { $dir0 = Test::MockFile->dir('/foo/'); } ), 'Create /foo/', ); isa_ok( $dir0, 'Test::MockFile' ); is( $dir0->path(), '/foo', 'Trailing / is removed' ); } ); subtest( 'Checking for multiple forward slash in paths' => sub { my $x = ''; ok( lives( sub { $x = Test::MockFile->dir('/bar//')->path(); } ), 'dir() successful', ); is( $x, '/bar', 'Double trailing forward slash', ); $x = ''; ok( lives( sub { $x = Test::MockFile->dir('/bar///')->path(); } ), 'dir() succesful', ); is( $x, '/bar', 'Multiple trailing forward slash', ); $x = ''; ok( lives( sub { $x = Test::MockFile->dir('//bar/')->path(); } ), 'dir() succesful', ); is( $x, '/bar', 'Double leading forward slash for dir', ); $x = ''; ok( lives( sub { $x = Test::MockFile->file( '//bar', '' )->path(); } ), 'dir() succesful', ); is( $x, '/bar', 'Double leading forward slash for file', ); $x = ''; ok( lives( sub { $x = Test::MockFile->dir('/foo//bar/')->path(); } ), 'dir() succesful', ); is( $x, '/foo/bar', 'Double forward slash in the middle for dir', ); $x = ''; ok( lives( sub { $x = Test::MockFile->file( '/foo//bar', '' )->path(); } ), 'dir() succesful', ); is( $x, '/foo/bar', 'Double forward slash in the middle for file', ); } ); subtest( 'Relative paths' => sub { is( lives( sub { Test::MockFile->dir('./bar/'); } ), 1, 'Success with ./ for dir', ); is( lives( sub { Test::MockFile->file( './bar', [] ); } ), 1, 'Success with ./ for file', ); like( dies( sub { Test::MockFile->dir('../bar/'); } ), qr/\QRelative paths are not supported\E/xms, 'Failure with ../ for dir', ); like( dies( sub { Test::MockFile->file( '../bar', [] ); } ), qr/\QRelative paths are not supported\E/xms, 'Failure with ../ for file', ); like( dies( sub { Test::MockFile->dir('/foo/../bar/'); } ), qr/\QRelative paths are not supported\E/xms, 'Failure with /../ for dir', ); is( lives( sub { Test::MockFile->file( '/foo/.', [] ); } ), 1, 'Success with /. for file', ); like( dies( sub { Test::MockFile->file( '/foo/..', [] ); } ), qr/\QRelative paths are not supported\E/xms, 'Failure with /.. for file', ); like( dies( sub { Test::MockFile->file( '/foo/../bar', [] ); } ), qr/\QRelative paths are not supported\E/xms, 'Failure with /../ for file', ); is( lives( sub { Test::MockFile->dir('/foo/./bar/'); } ), 1, 'Success with /./ for dir', ); is( lives( sub { Test::MockFile->file( '/foo/./bar', [] ); } ), 1, 'Success with /./ for file', ); is( lives( sub { Test::MockFile->file( 'foo', [] ); } ), 1, 'No problem with current directory paths (file with trailing forward slash)', ); is( lives( sub { Test::MockFile->dir('foo/'); } ), 1, 'No problem with current directory paths (dir with trailing forward slash)', ); is( lives( sub { Test::MockFile->file( 'foo', [] ); } ), 1, 'No problem with current directory paths (dir with no trailing forward slash)', ); } ); done_testing(); exit; Test-MockFile-0.037/t/lib/0000755000000000000000000000000015011451313013632 5ustar rootrootTest-MockFile-0.037/t/lib/Test/0000755000000000000000000000000015011451313014551 5ustar rootrootTest-MockFile-0.037/t/lib/Test/TMF.pm0000644000000000000000000001154214341720311015542 0ustar rootrootpackage Test::TMF; # inspired by App::Yath::Tester use strict; use warnings; use Test2::V0; use Test2::Tools::Explain; use Test2::API qw/context run_subtest/; use Test2::Tools::Compare qw/is/; use Carp qw/croak/; use File::Temp qw/tempfile tempdir/; use File::Basename qw(basename); use POSIX; use Fcntl qw/SEEK_CUR/; use Cwd 'abs_path'; use Test2::Harness::Util::IPC qw/run_cmd/; use Exporter 'import'; our @EXPORT = qw{ tmf_test_code t2_run_script }; our $TMP; # directory sub _setup_tmp_dir { $TMP //= File::Temp->newdir(); } my @_tmf_test_args; sub tmf_test_code { my (%params) = @_; if ( !scalar @_tmf_test_args ) { require Test::MockFile; my $path = $INC{"Test/MockFile.pm"} or die; $path =~ s{\QTest/MockFile.pm\E$}{}; push @_tmf_test_args, '-I' . $path; } my $perl_args = [@_tmf_test_args]; my $extra_args = delete $params{perl_args}; if ( defined $extra_args ) { if ( ref $extra_args ) { push @$perl_args, @$extra_args; } else { push @$perl_args, $extra_args; } } return t2_run_script( perl_args => $perl_args, %params ); } sub t2_run_script { my (%params) = @_; my $perl_args = delete $params{perl_args} // []; my $test_code = delete $params{test_code} // croak("no test code"); my ( $fh, $filename ) = tempfile( DIR => _setup_tmp_dir() ); print {$fh} <<"EOS"; use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; $test_code done_testing; EOS close $fh; return _test_script( sub { return ( $filename, @$perl_args ) }, %params ); } sub _test_script { my ( $finder, %params ) = @_; my $ctx = context(); my $cmd = delete $params{cmd} // delete $params{command}; my $cli = delete $params{cli} // delete $params{args} // []; my $env = delete $params{env} // {}; my $prefix = delete $params{prefix}; my $subtest = delete $params{test} // delete $params{tests} // delete $params{subtest}; my $exittest = delete $params{exit}; my $debug = delete $params{debug} // 0; my $capture = delete $params{capture} // 1; my $name = delete $params{name}; if ( keys %params ) { croak "Unexpected parameters: " . join( ', ', sort keys %params ); } my ( $wh, $cfile ); if ($capture) { ( $wh, $cfile ) = tempfile( "cpdev-$$-XXXXXXXX", TMPDIR => 1, CLEANUP => 1, SUFFIX => '.out' ); $wh->autoflush(1); } die q[Finder need to be a coderef] unless ref $finder eq 'CODE'; my ( $script, @lib ) = $finder->(); my @all_args = ( $cmd ? ($cmd) : (), @$cli ); my @cmd = ( $^X, @lib, $script, @all_args ); print STDERR "DEBUG: Command = " . join( ' ' => @cmd ) . "\n" if $debug; local %ENV = %ENV; $ENV{$_} = $env->{$_} for keys %$env; my $pid = run_cmd( no_set_pgrp => 1, $capture ? ( stderr => $wh, stdout => $wh ) : (), command => \@cmd, run_in_parent => [ sub { close($wh) } ], ); my ( @lines, $exit ); if ($capture) { open( my $rh, '<', $cfile ) or die "Could not open output file: $!"; $rh->blocking(0); while (1) { seek( $rh, 0, SEEK_CUR ); # CLEAR EOF my @new = <$rh>; push @lines => @new; print map { chomp($_); "DEBUG: > $_\n" } @new if $debug > 1; waitpid( $pid, WNOHANG ) or next; $exit = $?; last; } while ( my @new = <$rh> ) { push @lines => @new; print map { chomp($_); "DEBUG: > $_\n" } @new if $debug > 1; } } else { print STDERR "DEBUG: Waiting for $pid\n" if $debug; waitpid( $pid, 0 ); $exit = $?; } print STDERR "DEBUG: Exit: $exit\n" if $debug; my $out = { exit => $exit, $capture ? ( output => join( '', @lines ) ) : (), }; $name //= join( ' ', map { length($_) < 30 ? $_ : substr( $_, 0, 10 ) . "[...]" . substr( $_, -10 ) } grep { defined($_) } basename($script), @all_args ); run_subtest( $name, sub { if ( defined $exittest ) { my $ictx = context( level => 3 ); is( $exit, $exittest, "Exit Value Check" ); $ictx->release; } if ($subtest) { local $_ = $out->{output}; local $? = $out->{exit}; $subtest->($out); } my $ictx = context( level => 3 ); $ictx->diag( "Command = " . join( ' ' => grep { defined $_ } @cmd ) . "\nExit = $exit\n==== Output ====\n$out->{output}\n========" ) unless $ictx->hub->is_passing; $ictx->release; }, { buffered => 1 }, $out, ) if $subtest || defined $exittest; $ctx->release; return $out; } 1; Test-MockFile-0.037/t/open.t0000644000000000000000000001206014341720311014213 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Test::More; use Errno qw/ENOENT/; use File::Temp qw/tempfile/; use Test::MockFile qw< nostrict >; # Everything below this can have its open overridden. my $test_string = "abcd\nefgh\n"; my ( $fh_real, $filename ) = tempfile(); print $fh_real $test_string; note "-------------- REAL MODE --------------"; my $open_return = open( $fh_real, '<:stdio', $filename ); is( $open_return, 1, "Open a real file bypassing PERLIO" ); is( <$fh_real>, "abcd\n", " ... line 1" ); is( <$fh_real>, "efgh\n", " ... line 2" ); is( <$fh_real>, undef, " ... EOF" ); close $fh_real; undef $fh_real; unlink $filename; note "-------------- MOCK MODE --------------"; my $bar = Test::MockFile->file( $filename, $test_string ); $open_return = open( $fh_real, '<:stdio', $filename ); is( $open_return, 1, "Open a mocked file bypassing PERLIO" ); is( <$fh_real>, "abcd\n", " ... line 1" ); is( <$fh_real>, "efgh\n", " ... line 2" ); is( <$fh_real>, undef, " ... EOF" ); close $fh_real; ok( -e $filename, "Real file is there" ); undef $bar; ok( !-e $filename, "Real file is not there" ); note "Following symlinks for open"; my $mock_file = Test::MockFile->file( $filename, $test_string ); my $mock_link = Test::MockFile->symlink( $filename, '/qwerty' ); { is( open( my $fh, '<', '/qwerty' ), 1, "Open a mocked file via its symlink" ); is( <$fh>, "abcd\n", " ... line 1" ); is( <$fh>, "efgh\n", " ... line 2" ); is( <$fh>, undef, " ... EOF" ); close $fh; } { $mock_file->unlink; is( open( my $fh, '<', '/qwerty' ), undef, "Open a mocked file via its symlink when the file is missing fails." ); is( $! + 0, ENOENT, '$! is ENOENT' ); } subtest( 'open modes' => sub { foreach my $write_mode (qw( > >> )) { my $open_str = $write_mode . '/debug.log'; my $file = Test::MockFile->file( '/debug.log', '' ); my $fh; $! = 0; ok( open( $fh, $open_str ), "Two-arg $write_mode open works" ); is( $! + 0, 0, 'No error' ); $! = 0; ok( close($fh), 'Successfully closed open handle' ); is( $! + 0, 0, 'No error' ); } foreach my $read_mode ( '<', '' ) { my $open_str = $read_mode . '/debug.log'; my $file = Test::MockFile->file( '/debug.log', '' ); my $fh; $! = 0; ok( open( $fh, $open_str ), "Two-arg $read_mode open works" ); is( $open_str, "${read_mode}/debug.log", "arg not changed" ); is( $! + 0, 0, 'No error' ); $! = 0; ok( close($fh), 'Successfully closed open handle' ); is( $! + 0, 0, 'No error' ); } foreach my $multi_mode (qw( +< +> )) { my $open_str = $multi_mode . '/debug.log'; my $file = Test::MockFile->file( '/debug.log', '' ); my $fh; $! = 0; ok( open( $fh, $open_str ), "Two-arg $multi_mode open fails" ); is( $! + 0, 0, 'No error' ); $! = 0; ok( open( $fh, $multi_mode, '/debug.log' ), "Three-arg $multi_mode open fails" ); is( $! + 0, 0, 'No error' ); } # Pipe open pass-through my ( $fh, $tempfile ) = tempfile( 'CLEANUP' => 1 ); my $pipefh; # Three-arg pipe write ok( open( $pipefh, '|-', "echo hello >> $tempfile" ), 'Succesful three-arg pipe open write' ); # No point testing $! because it will correctly be set to ESPIPE (29, illegal seek) $! = 0; ok( close($pipefh), 'Successfully closed pipe' ); is( $! + 0, 0, 'No error' ); # Two-arg pipe write ok( open( $pipefh, "|echo world >> $tempfile" ), 'Succesful two-arg pipe open write' ); # No point testing $! because it will correctly be set to ESPIPE (29, illegal seek) $! = 0; ok( close($pipefh), 'Successfully closed pipe' ); is( $! + 0, 0, 'No error' ); # Three-arg pipe write ok( open( $pipefh, '-|', "cat $tempfile" ), 'Succesful three-arg pipe open read' ); # No point testing $! because it will correctly be set to ESPIPE (29, illegal seek) my $out = <$pipefh>; is( $out, "hello\n", 'Succesfully read from pipe with three-arg' ); ok( close($pipefh), 'Successfully closed pipe' ); # No point testing $! because it will correctly be set to ESPIPE (29, illegal seek) # Two-arg pipe write $out = ''; ok( open( $pipefh, "cat $tempfile|" ), 'Succesful two-arg pipe open read' ); # No point testing $! because it will correctly be set to ESPIPE (29, illegal seek) $out = <$pipefh>; $out .= <$pipefh>; is( $out, "hello\nworld\n", 'Succesfully read from pipe with two-arg' ); $! = 0; ok( close($pipefh), 'Successfully closed pipe' ); is( $! + 0, 0, 'No error' ); } ); done_testing(); exit; Test-MockFile-0.037/t/fileno.t0000644000000000000000000000102114341720311014521 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Test2::Tools::Exception qw< lives dies >; use Test::MockFile qw< strict >; my $file = Test::MockFile->file( '/foo', '' ); my $fh; ok( lives( sub { open $fh, '<', '/foo' } ), 'Opened file' ); like( dies( sub { fileno $fh } ), qr/\Qfileno is purposefully unsupported\E/xms, 'Refuse to support fileno', ); ok( lives( sub { close $fh } ), 'Opened file' ); done_testing(); exit; Test-MockFile-0.037/t/Test-MockFile_file.t0000644000000000000000000000043614341720311016663 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Fcntl; #use Errno qw/ENOENT EBADF/; use Test::MockFile; # Everything below this can have its open overridden. pass("Todo"); done_testing(); Test-MockFile-0.037/t/readline.t0000644000000000000000000001127714341720311015046 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Errno qw/ENOENT EBADF/; use File::Temp qw/tempfile/; use Test::MockFile qw< nostrict >; # Everything below this can have its open overridden. my ( $fh_real, $filename ) = tempfile(); print {$fh_real} "not\nmocked\n"; close $fh_real; note "-------------- REAL MODE --------------"; is( -s $filename, 11, "Temp file is on disk and right size" ); is( open( $fh_real, '<', $filename ), 1, "Open a real file written by File::Temp" ); like( "$fh_real", qr/^GLOB\(0x[0-9a-f]+\)$/, '$fh2 stringifies to a GLOB' ); is( <$fh_real>, "not\n", " ... line 1" ); is( <$fh_real>, "mocked\n", " ... line 2" ); { my $warn_msg; local $SIG{__WARN__} = sub { $warn_msg = shift }; is( print( {$fh_real} "TEST" ), undef, "Fails to write to a read handle in mock mode." ); is( $! + 0, EBADF, q{$! when the file is written to and it's a read file handle.} ); like( $warn_msg, qr{^Filehandle \S+ opened only for input at t/readline.t line \d+}, "Warns about writing to a read file handle" ); } close $fh_real; note "-------------- MOCK MODE --------------"; my $bar = Test::MockFile->file( $filename, "abc\ndef\nghi\n" ); is( open( my $fh, '<', $filename ), 1, "Mocked temp file opens and returns true" ); isa_ok( $fh, ["IO::File"], '$fh is a IO::File' ); like( "$fh", qr/^IO::File=GLOB\(0x[0-9a-f]+\)$/, '$fh stringifies to a IO::File GLOB' ); is( <$fh>, "abc\n", '1st read on $fh is "abc\n"' ); is( <$fh>, "def\n", '2nd read on $fh is "def\n"' ); is( readline($fh), "ghi\n", '3rd read on $fh via readline is "ghi\n"' ); is( <$fh>, undef, '4th read on $fh undef at EOF' ); is( <$fh>, undef, '5th read on $fh undef at EOF' ); is( <$fh>, undef, '6th read on $fh undef at EOF' ); is( $bar->contents, "abc\ndef\nghi\n", '$foo->contents' ); $bar->contents( join( "\n", qw/abc def jkl mno pqr/ ) ); is( <$fh>, "mno\n", '7th read on $fh is "mno\n"' ); is( <$fh>, "pqr", '7th read on $fh is "pqr"' ); is( <$fh>, undef, '8th read on $fh undef at EOF' ); is( <$fh>, undef, '9th read on $fh undef at EOF' ); { my $warn_msg; local $SIG{__WARN__} = sub { $warn_msg = shift }; is( print( {$fh} "TEST" ), undef, "Fails to write to a read handle in mock mode." ); is( $! + 0, EBADF, q{$! when the file is written to and it's a read file handle.} ); like( $warn_msg, qr{^Filehandle .+? opened only for input at .+? line \d+\.$}, "Warns about writing to a read file handle" ); } close $fh; ok( !exists $Test::MockFile::files_being_mocked{$filename}->{'fh'}, "file handle clears from files_being_mocked hash when it goes out of scope." ); undef $bar; is( scalar %Test::MockFile::files_being_mocked, 0, "files_being_mocked empties when \$bar is cleared" ); note "-------------- REAL MODE --------------"; is( open( $fh_real, '<', $filename ), 1, "Once the mock file object is cleared, the next open reverts to the file on disk." ); like( "$fh_real", qr/^GLOB\(0x[0-9a-f]+\)$/, '$fh2 stringifies to a GLOB' ); is( <$fh_real>, "not\n", " ... line 1" ); is( <$fh_real>, "mocked\n", " ... line 1" ); close $fh_real; # Missing file handling { local $!; unlink $filename; } undef $fh; is( open( $fh, '<', $filename ), undef, qq{Can't open a missing file "$filename"} ); is( $! + 0, ENOENT, 'What $! looks like when failing to open the missing file.' ); { note "-------------- MOCK MODE --------------"; my $baz = Test::MockFile->file($filename); is( open( my $fh, '<', $filename ), undef, qq{Can't open a missing file "$filename"} ); is( $! + 0, ENOENT, 'What $! looks like when failing to open the missing file.' ); } #### Slurp my $multiline = "abc\ndef\nghi\r\ndhdbhjdb\r"; my $mock_multiline = reverse "abc\ndef\nghi\r\ndhdbhjdb\r"; open( $fh, ">", $filename ) or die; print $fh $multiline; close $fh; sub slurp { open( my $fh, '<', $filename ) or die("Failed to open slurp file: $!"); my $content = do { local $/; <$fh> }; close $fh; return $content; } { note "---------------------------------------"; is( slurp(), $multiline, "REAL multiline do slurp works" ); my $baz = Test::MockFile->file( $filename, $mock_multiline ); is( slurp(), $mock_multiline, "MOCK multiline do slurp works" ); } { note "readline array."; my $baz = Test::MockFile->file( $filename, $multiline ); open( my $fh, '<', $filename ); my @read = <$fh>; is( \@read, [ "abc\n", "def\n", "ghi\r\n", "dhdbhjdb\r" ], "readline reads in an array of stuff." ); } done_testing(); exit; Test-MockFile-0.037/t/file_from_disk.t0000644000000000000000000000210014341720311016220 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Test::More; use File::Temp qw/tempfile/; use File::Slurper (); use Test::MockFile qw< nostrict >; # Everything below this can have its open overridden. my $fake_file_contents = "abc\n" . ( "x" x 20 ) . "\n"; my ( $fh_real, $file_on_disk ) = tempfile(); print $fh_real $fake_file_contents; close $fh_real; my ( undef, $fake_file_name ) = tempfile(); unlink $fake_file_name; my $mock = Test::MockFile->file_from_disk( $fake_file_name, $file_on_disk ); is( open( my $fh, "<", $fake_file_name ), 1, "open fake file for read" ); is( <$fh>, "abc\n", "Read line 1." ); is( <$fh>, ( "x" x 20 ) . "\n", "Read line 2." ); close $fh; undef $fh; is( open( $fh, ">", $fake_file_name ), 1, "open fake file for write" ); print $fh "def"; close $fh; undef $fh; is( $mock->contents, "def", "file is written to" ); undef $mock; is( File::Slurper::read_binary($file_on_disk), $fake_file_contents, "The original file was unmodified" ); done_testing(); Test-MockFile-0.037/t/touch.t0000644000000000000000000000533714341720311014405 0ustar rootroot#!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Errno qw/ENOENT EISDIR EPERM/; use File::Temp qw/tempfile tempdir/; note "-------------- REAL MODE --------------"; my $temp_dir = tempdir( CLEANUP => 1 ); ok( -d $temp_dir, "$temp_dir is there" ); $! = 0; is( unlink($temp_dir), 0, "unlink on a dir fails" ); my $unlink_dir_errorno = $! + 0; SKIP: { skip q{This docker container doesn't emit $! failures reliably.}, 1 if on_broken_docker(); ok( $unlink_dir_errorno, "unlink /dir is non-zero ($unlink_dir_errorno)" ); } use Test::MockFile qw< nostrict >; note "-------------- MOCK MODE --------------"; my @mock; my $file = Test::MockFile->file( '/file', "" ); my $dir = Test::MockFile->dir('/dir'); my $link = Test::MockFile->symlink( '/link', '/tonowhere' ); ok( !-d '/dir', 'Directory does not exist yet' ); ok( mkdir('/dir'), 'Successfully created /dir' ); ok( -d '/dir', 'Directory now exists' ); is( $link->unlink, 1, "unlink /link works." ); is( $link->exists, 0, "/link is now gone" ); SKIP: { skip q{This docker container doesn't emit $! failures reliably.}, 2 if on_broken_docker(); local $!; is( $dir->unlink, 0, "unlink /dir doesn't work." ); is( $! + 0, $unlink_dir_errorno, " ... and throws a \$\!" ); } like( dies { $dir->touch }, qr/^touch only supports files at \S/, "touch /dir doesn't work." ); like( dies { $link->touch }, qr/^touch only supports files at \S/, "touch /link doesn't work." ); is( $file->mtime(5), 5, "Set mtime to 1970" ); is( $file->ctime(5), 5, "Set ctime to 1970" ); is( $file->atime(5), 5, "Set atime to 1970" ); my $now = time; is( $file->touch, 1, "Touch a missing file." ); ok( $file->mtime >= $now, "mtime is set." ) or diag $file->mtime; ok( $file->ctime >= $now, "ctime is set." ) or diag $file->ctime; ok( $file->atime >= $now, "atime is set." ) or diag $file->atime; ok( -e "/file", "/file exists with -e" ); is( $file->unlink, 1, "/file is removed via unlink method" ); is( $file->contents, undef, "/file is missing via contents check" ); is( $file->size, undef, "/file is missing via size method" ); ok( !-e "/file", "/file is removed via -e check" ); is( $file->contents("ABC"), "ABC", "Set file to have stuff in it." ); is( $file->touch(1234), 1, "Touch an existing file." ); is( $file->mtime, 1234, "mtime is set to 1234." ) or diag $file->mtime; is( $file->ctime, 1234, "ctime is set to 1234." ) or diag $file->ctime; is( $file->atime, 1234, "atime is set to 1234." ) or diag $file->atime; done_testing(); exit; sub on_broken_docker { return 0 if $] > 5.019; return 0 unless -f '/.dockerenv'; return 1; } Test-MockFile-0.037/lib/0000755000000000000000000000000015011451313013367 5ustar rootrootTest-MockFile-0.037/lib/Test/0000755000000000000000000000000015011451313014306 5ustar rootrootTest-MockFile-0.037/lib/Test/MockFile/0000755000000000000000000000000015011451313015777 5ustar rootrootTest-MockFile-0.037/lib/Test/MockFile/Plugin/0000755000000000000000000000000015011451313017235 5ustar rootrootTest-MockFile-0.037/lib/Test/MockFile/Plugin/FileTemp.pm0000644000000000000000000000527015011451051021303 0ustar rootrootpackage Test::MockFile::Plugin::FileTemp; use strict; use warnings; use parent 'Test::MockFile::Plugin'; use Test::MockModule qw{strict}; use Carp qw(croak); our $VERSION = '0.037'; sub register { my ($self) = @_; if ( $^V lt 5.28.0 ) { croak( __PACKAGE__ . " is only supported for Perl >= 5.28" ); } foreach my $pkg (qw{ File::Temp File::Temp::Dir File::Temp::END File::Temp::Dir::DESTROY }) { Test::MockFile::authorized_strict_mode_for_package($pkg); } Test::MockFile::add_strict_rule_generic( \&_allow_file_temp_calls ); my $mock = Test::MockModule->new('File::Temp'); # tempfile $mock->redefine( tempfile => sub { my (@in) = @_; my @out = $mock->original('tempfile')->(@in); Test::MockFile::add_strict_rule_for_filename( $out[1] => 1 ); return @out if wantarray; File::Temp::unlink0( $out[0], $out[1] ); return $out[0]; } ); # tempdir $mock->redefine( tempdir => sub { my (@in) = @_; my $out = $mock->original('tempdir')->(@in); my $dir = "$out"; Test::MockFile::add_strict_rule_for_filename( [ $dir, qr{^${dir}/} ] => 1 ); return $out; } ); # newdir $mock->redefine( newdir => sub { my (@args) = @_; my $out = $mock->original('newdir')->(@args); my $dir = "$out"; Test::MockFile::add_strict_rule_for_filename( [ $dir, qr{^$dir/} ] => 1 ); return $out; } ); $self->{mock} = $mock; return $self; } sub _allow_file_temp_calls { my ($ctx) = @_; foreach my $stack_level ( 1 .. Test::MockFile::_STACK_ITERATION_MAX() ) { my @stack = caller($stack_level); last if !scalar @stack; last if !defined $stack[0]; # We don't know when this would ever happen. return 1 if $stack[0] eq 'File::Temp' # || $stack[0] eq 'File::Temp::Dir'; } return; } 1; =encoding utf8 =head1 NAME Test::MockFile::Plugin::FileTemp - Plugin to allow File::Temp calls =head1 SYNOPSIS use Test::MockFile 'strict', plugin => 'FileTemp'; # using FileTemp plugin, all calls from FileTemp bypass the Test::MockFile strict mode my $dir = File::Temp->newdir(); ok opendir( my $dh, "$dir" ); ok open( my $f, '>', "$dir/myfile.txt" ); =head1 DESCRIPTION L provides plugin to Test::MockFile to authorize any calls from File::Temp package. =head1 METHODS =head2 register( $self ) Public method to register the plugin. =head1 SEE ALSO L, L, L =cut Test-MockFile-0.037/lib/Test/MockFile/Plugin.pm0000644000000000000000000000203715011451051017574 0ustar rootrootpackage Test::MockFile::Plugin; use strict; use warnings; use Carp qw(croak); require Test::MockFile; # load Test::MockFile without setting the strict mode our $VERSION = '0.037'; sub new { my ( $class, %opts ) = @_; my $self = bless {%opts}, $class; return $self; } sub register { my ($self) = @_; croak('Method "register" not implemented by plugin'); } 1; =encoding utf8 =head1 NAME Test::MockFile::Plugin - Plugin base class =head1 SYNOPSIS package Test::MockFile::Plugin::YourCustomPlugin; use base 'Test::MockFile::Plugin'; sub register { my ( $self ) = @_; # Code to setup your plugin here ... } =head1 DESCRIPTION L is an abstract base class for L plugins. =head1 METHODS =head2 new( %opts ) Constructor provided to all Plugin packages so they have a location to store their internal data. =head2 register $plugin->register(); This method will be called by L on imports. =head1 SEE ALSO L =cut Test-MockFile-0.037/lib/Test/MockFile/DirHandle.pm0000644000000000000000000000453115011451051020171 0ustar rootroot# Copyright (c) 2018, cPanel, LLC. # All rights reserved. # http://cpanel.net # # This is free software; you can redistribute it and/or modify it under the # same terms as Perl itself. See L. package Test::MockFile::DirHandle; use strict; use warnings; our $VERSION = '0.037'; =head1 NAME Test::MockFile::DirHandle - Provides a class object for L to give out for opendir calls. =head1 VERSION Version 0.037 =cut =head1 SYNOPSIS This is a helper class for L its only purpose is to provide a object to recognize that a the passed handle is a mocked handle. L has to mock the other calls since there is no tie for B handles. # This is what Test::MockFile does. You really shouldn't be doing it directly. use Test::MockFile::DirHandle; my $handle = Test::MockFile::DirHandle->new("/fake/path", [qw/. .. a bbb ccc dd/]); =head1 EXPORT No exports are provided by this module. =head1 SUBROUTINES/METHODS =head2 new Args: ($class, $dir, $files_array_ref) Returns a blessed object for Test::MockFile::DirHandle. There are no error conditions handled here. B the permanent directory contents are stored in a hash in Test::MockFile. However when opendir is called, a copy is stored here. This is because through experimentation, we've determined that adding files in a dir during a opendir/readdir does not affect the return of readdir. See L. =cut sub new { my ( $class, $dir, $files_in_readdir ) = @_; return bless { files_in_readdir => $files_in_readdir, 'dir' => $dir, 'tell' => 0, }, $class; } =head1 AUTHOR Todd Rinaldo, C<< >> =head1 BUGS Please report any bugs or feature requests to L. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Test::MockFile::DirHandle You can also look for information at: =over 4 =item * CPAN Ratings L =item * Search CPAN L =back =head1 LICENSE AND COPYRIGHT Copyright 2018 cPanel L.L.C. All rights reserved. L This is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =cut 1; Test-MockFile-0.037/lib/Test/MockFile/Plugins.pm0000644000000000000000000000260415011451051017757 0ustar rootrootpackage Test::MockFile::Plugins; use strict; use warnings; our $VERSION = '0.037'; our @NAMESPACES = (q[Test::MockFile::Plugin]); sub load_plugin { my ($name_or_array) = @_; my $list = ref $name_or_array ? $name_or_array : [$name_or_array]; my @plugins; foreach my $name (@$list) { push @plugins, _load_plugin($name); } return @plugins; } sub _load_plugin { my ($name) = @_; my @candidates = map { "${_}::$name" } @NAMESPACES; foreach my $c (@candidates) { next unless _load($c); my $plugin = $c->new(); return $plugin->register; } die qq[Cannot find a Test::MockFile plugin for $name]; } sub _load { my ($pkg) = @_; return unless eval qq{ require $pkg; 1 }; return $pkg->isa('Test::MockFile::Plugin'); } 1; =encoding utf8 =head1 NAME Test::MockFile::Plugins - Plugin loader =head1 SYNOPSIS use Test::MockFile::Plugins; unshift @Test::MockFile::Plugins::NAMESPACES, q[Your::NameSpace]; Test::MockFile::Plugins::load_plugins( 'YourPlugin' ); =head1 DESCRIPTION L is responsible for loading plugins. BETA WARNING: This is a preliminary plugins implementation. It might change in the future. =head1 METHODS =head2 load_plugin( $plugin_name ) Test::MockFile::Plugins::load_plugin( 'YourPlugin' ); =head1 SEE ALSO L, L =cut Test-MockFile-0.037/lib/Test/MockFile/FileHandle.pm0000644000000000000000000002374015011451051020335 0ustar rootroot# Copyright (c) 2018, cPanel, LLC. # All rights reserved. # http://cpanel.net # # This is free software; you can redistribute it and/or modify it under the # same terms as Perl itself. See L. package Test::MockFile::FileHandle; use strict; use warnings; use Errno qw/EBADF/; use Scalar::Util (); our $VERSION = '0.037'; my $files_being_mocked; { no warnings 'once'; $files_being_mocked = \%Test::MockFile::files_being_mocked; } =head1 NAME Test::MockFile::FileHandle - Provides a class for L to tie to on B or B. =head1 VERSION Version 0.037 =cut =head1 SYNOPSIS This is a helper class for L. It leverages data in the Test::MockFile namespace but lives in its own package since it is the class that file handles are tied to when created in L use Test::MockFile::FileHandle; tie *{ $_[0] }, 'Test::MockFile::FileHandle', $abs_path, $rw; =head1 EXPORT No exports are provided by this module. =head1 SUBROUTINES/METHODS =head2 TIEHANDLE Args: ($class, $file, $mode) Returns a blessed object for L to tie against. There are no error conditions handled here. One of the object variables tracked here is a pointer to the file contents in C<%Test::MockFile::files_being_mocked>. In order to allow MockFiles to be DESTROYED when they go out of scope, we have to weaken this pointer. See L for more info. =cut sub TIEHANDLE { my ( $class, $file, $mode ) = @_; length $file or die("No file name passed!"); my $self = bless { 'file' => $file, 'data' => $files_being_mocked->{$file}, 'tell' => 0, 'read' => $mode =~ m/r/ ? 1 : 0, 'write' => $mode =~ m/w/ ? 1 : 0, }, $class; # This ref count can't hold the object from getting released. Scalar::Util::weaken( $self->{'data'} ); return $self; } =head2 PRINT This method will be triggered every time the tied handle is printed to with the print() or say() functions. Beyond its self reference it also expects the list that was passed to the print function. We append to C<$Test::MockFile::files_being_mocked{$file}->{'contents'}> with what was sent. If the file handle wasn't opened in a read mode, then this call with throw EBADF via $! =cut sub PRINT { my ( $self, @list ) = @_; if ( !$self->{'write'} ) { # Filehandle $fh opened only for input at t/readline.t line 27, <$fh> line 2. # https://github.com/CpanelInc/Test-MockFile/issues/1 CORE::warn("Filehandle ???? opened only for input at ???? line ???, line ???."); $! = EBADF; return; } my $starting_bytes = length $self->{'data'}->{'contents'}; foreach my $line (@list) { next if !defined $line; $self->{'data'}->{'contents'} .= $line; } return length( $self->{'data'}->{'contents'} ) - $starting_bytes; } =head2 PRINTF This method will be triggered every time the tied handle is printed to with the printf() function. Beyond its self reference it also expects the format and list that was passed to the printf function. We use sprintf to format the output and then it is sent to L =cut sub PRINTF { my $self = shift; my $format = shift; return $self->PRINT( sprintf( $format, @_ ) ); } =head2 WRITE This method will be called when the handle is written to via the syswrite function. Arguments passed are:C<( $self, $buf, $len, $offset )> This is one of the more complicated functions to mimic properly because $len and $offset have to be taken into account. Reviewing how syswrite works reveals there are all sorts of weird corner cases. =cut sub WRITE { my ( $self, $buf, $len, $offset ) = @_; unless ( $len =~ m/^-?[0-9.]+$/ ) { $! = qq{Argument "$len" isn't numeric in syswrite at ??}; return 0; } $len = int($len); # Perl seems to do this to floats. if ( $len < 0 ) { $! = qq{Negative length at ???}; return 0; } my $strlen = length($buf); $offset //= 0; if ( $strlen - $offset < abs($len) ) { $! = q{Offset outside string at ???.}; return 0; } $offset //= 0; if ( $offset < 0 ) { $offset = $strlen + $offset; } return $self->PRINT( substr( $buf, $offset, $len ) ); } =head2 READLINE This method is called when the handle is read via or readline HANDLE. Based on the numeric location we are in the file (tell), we read until the EOF separator (C<$/>) is seen. tell is updated after the line is read. undef is returned if tell is already at EOF. =cut sub _READLINE_ONE_LINE { my ($self) = @_; my $tell = $self->{'tell'}; my $rs = $/ // ''; my $new_tell = index( $self->{'data'}->{'contents'}, $rs, $tell ) + length($rs); if ( $new_tell == 0 ) { $new_tell = length( $self->{'data'}->{'contents'} ); } return undef if ( $new_tell == $tell ); # EOF my $str = substr( $self->{'data'}->{'contents'}, $tell, $new_tell - $tell ); $self->{'tell'} = $new_tell; return $str; } sub READLINE { my ($self) = @_; return if $self->EOF; if (wantarray) { my @all; my $line = _READLINE_ONE_LINE($self); while ( defined $line ) { push @all, $line; $line = _READLINE_ONE_LINE($self); } return @all; } return _READLINE_ONE_LINE($self); } =head2 GETC B: Open a ticket in L if you need this feature. This method will be called when the getc function is called. It reads 1 character out of contents and adds 1 to tell. The character is returned. =cut sub GETC { my ($self) = @_; die('Unimplemented'); } =head2 READ Arguments passed are:C<( $self, $file_handle, $len, $offset )> This method will be called when the handle is read from via the read or sysread functions. Based on C<$offset> and C<$len>, it's possible to end up with some really weird strings with null bytes in them. =cut sub READ { my ( $self, undef, $len, $offset ) = @_; # If the caller's buffer is undef, we need to make it a string of 0 length to start out with. $_[1] = '' if !defined $_[1]; # TODO: test me my $contents_len = length $self->{'data'}->{'contents'}; my $buf_len = length $_[1]; $offset //= 0; if ( $offset > $buf_len ) { $_[1] .= "\0" x ( $offset - $buf_len ); } my $tell = $self->{'tell'}; my $read_len = ( $contents_len - $tell < $len ) ? $contents_len - $tell : $len; substr( $_[1], $offset ) = substr( $self->{'data'}->{'contents'}, $tell, $read_len ); $self->{'tell'} += $read_len; return $read_len; } =head2 CLOSE This method will be called when the handle is closed via the close function. The object is untied and the file contents (weak reference) is removed. Further calls to this object should fail. =cut sub CLOSE { my ($self) = @_; delete $self->{'data'}->{'fh'}; untie $self; return 1; } =head2 UNTIE As with the other types of ties, this method will be called when untie happens. It may be appropriate to "auto CLOSE" when this occurs. See The untie Gotcha below. What's strange about the development of this class is that we were unable to determine how to trigger this call. At the moment, the call is just redirected to CLOSE. =cut sub UNTIE { my $self = shift; #print STDERR "# UNTIE!\n"; return $self->CLOSE; } =head2 DESTROY As with the other types of ties, this method will be called when the tied handle is about to be destroyed. This is useful for debugging and possibly cleaning up. At the moment, the call is just redirected to CLOSE. =cut sub DESTROY { my ($self) = @_; return $self->CLOSE; } =head2 EOF This method will be called when the eof function is called. Based on C<$self-E{'tell'}>, we determine if we're at EOF. =cut sub EOF { my ($self) = @_; if ( !$self->{'read'} ) { CORE::warn(q{Filehandle STDOUT opened only for output}); } return $self->{'tell'} == length $self->{'data'}->{'contents'}; } =head2 BINMODE Binmode does nothing as whatever format you put the data into the file as is how it will come out. Possibly we could decode the SV if this was done but then we'd have to do it every time contents are altered. Please open a ticket if you want this to do something. No L exists on this method. =cut sub BINMODE { my ($self) = @_; return; } =head2 OPEN B: Open a ticket in L if you need this feature. No L exists on this method. =cut sub OPEN { my ($self) = @_; die('Unimplemented'); } =head2 FILENO B: Open a ticket in L if you need this feature. No L exists on this method. =cut sub FILENO { my ($self) = @_; die 'fileno is purposefully unsupported'; } =head2 SEEK Arguments passed are:C<( $self, $pos, $whence )> Moves the location of our current tell location. B<$whence is UNIMPLEMENTED>: Open a ticket in L if you need this feature. No L exists on this method. =cut sub SEEK { my ( $self, $pos, $whence ) = @_; if ($whence) { die('Unimplemented'); } my $file_size = length $self->{'data'}->{'contents'}; return if $file_size < $pos; $self->{'tell'} = $pos; return $pos == 0 ? '0 but true' : $pos; } =head2 TELL Returns the numeric location we are in the file. The C tells us where we are in the file contents. No L exists on this method. =cut sub TELL { my ($self) = @_; return $self->{'tell'}; } 1; Test-MockFile-0.037/lib/Test/MockFile.pm0000644000000000000000000021035615011451051016343 0ustar rootroot# Copyright (c) 2018, cPanel, LLC. # All rights reserved. # http://cpanel.net # # This is free software; you can redistribute it and/or modify it under the # same terms as Perl itself. See L. package Test::MockFile; use strict; use warnings; # perl -MFcntl -E'eval "say q{$_: } . $_" foreach sort {eval "$a" <=> eval "$b"} qw/O_RDONLY O_WRONLY O_RDWR O_CREAT O_EXCL O_NOCTTY O_TRUNC O_APPEND O_NONBLOCK O_NDELAY O_EXLOCK O_SHLOCK O_DIRECTORY O_NOFOLLOW O_SYNC O_BINARY O_LARGEFILE/' use Fcntl; # O_RDONLY, etc. use constant SUPPORTED_SYSOPEN_MODES => O_RDONLY | O_WRONLY | O_RDWR | O_APPEND | O_TRUNC | O_EXCL | O_CREAT | O_NOFOLLOW; use constant BROKEN_SYMLINK => bless {}, "A::BROKEN::SYMLINK"; use constant CIRCULAR_SYMLINK => bless {}, "A::CIRCULAR::SYMLINK"; # we're going to use carp but the errors should come from outside of our package. use Carp qw(carp confess croak); BEGIN { $Carp::Internal{ (__PACKAGE__) }++; $Carp::Internal{'Overload::FileCheck'}++; } use Cwd (); use IO::File (); use Test::MockFile::FileHandle (); use Test::MockFile::DirHandle (); use Text::Glob (); use Scalar::Util (); use Symbol; use Overload::FileCheck '-from-stat' => \&_mock_stat, q{:check}; use Errno qw/EPERM ENOENT ELOOP EEXIST EISDIR ENOTDIR EINVAL/; use constant FOLLOW_LINK_MAX_DEPTH => 10; =head1 NAME Test::MockFile - Allows tests to validate code that can interact with files without touching the file system. =head1 VERSION Version 0.037 =cut our $VERSION = '0.037'; our %files_being_mocked; # From http://man7.org/linux/man-pages/man7/inode.7.html use constant S_IFMT => 0170000; # bit mask for the file type bit field use constant S_IFPERMS => 07777; # bit mask for file perms. use constant S_IFSOCK => 0140000; # socket use constant S_IFLNK => 0120000; # symbolic link use constant S_IFREG => 0100000; # regular file use constant S_IFBLK => 0060000; # block device use constant S_IFDIR => 0040000; # directory use constant S_IFCHR => 0020000; # character device use constant S_IFIFO => 0010000; # FIFO =head1 SYNOPSIS Intercepts file system calls for specific files so unit testing can take place without any files being altered on disk. This is useful for L where file interaction is discouraged. A strict mode is even provided (and turned on by default) which can throw a die when files are accessed during your tests! # Loaded before Test::MockFile so uses the core perl functions without any hooks. use Module::I::Dont::Want::To::Alter; # strict mode by default use Test::MockFile (); # non-strict mode use Test::MockFile qw< nostrict >; # Load with one or more plugins use Test::MockFile plugin => 'FileTemp'; use Test::MockFile plugin => [ 'FileTemp', ... ]; # Be sure to assign the output of mocks, they disappear when they go out of scope my $foobar = Test::MockFile->file( "/foo/bar", "contents\ngo\nhere" ); open my $fh, '<', '/foo/bar' or die; # Does not actually open the file on disk say '/foo/bar exists' if -e $fh; close $fh; say '/foo/bar is a file' if -f '/foo/bar'; say '/foo/bar is THIS BIG: ' . -s '/foo/bar'; my $foobaz = Test::MockFile->file('/foo/baz'); # File starts out missing my $opened = open my $baz_fh, '<', '/foo/baz'; # File reports as missing so fails say '/foo/baz does not exist yet' if !-e '/foo/baz'; open $baz_fh, '>', '/foo/baz' or die; # open for writing print {$baz_fh} "first line\n"; open $baz_fh, '>>', '/foo/baz' or die; # open for append. print {$baz_fh} "second line"; close $baz_fh; say "Contents of /foo/baz:\n>>" . $foobaz->contents() . '<<'; # Unmock your file. # (same as the variable going out of scope undef $foobaz; # The file check will now happen on file system now the file is no longer mocked. say '/foo/baz is missing again (no longer mocked)' if !-e '/foo/baz'; my $quux = Test::MockFile->file( '/foo/bar/quux.txt', '' ); my @matches = ; # ( '/foo/bar/quux.txt' ) say "Contents of /foo/bar directory: " . join "\n", @matches; @matches = glob('/foo/bar/*.txt'); # same as above say "Contents of /foo/bar directory (using glob()): " . join "\n", @matches; =head1 IMPORT When the module is loaded with no parameters, strict mode is turned on. Any file checks, C, C, C, C, or C will throw a die. For example: use Test::MockFile; # This will not die. my $file = Test::MockFile->file("/bar", "..."); my $symlink = Test::MockFile->symlink("/foo", "/bar"); -l '/foo' or print "ok\n"; open my $fh, '>', '/foo'; # All of these will die open my $fh, '>', '/unmocked/file'; # Dies sysopen my $fh, '/other/file', O_RDONLY; opendir my $fh, '/dir'; -e '/file'; -l '/file'; If we want to load the module without strict mode: use Test::MockFile qw< nostrict >; Relative paths are not supported: use Test::MockFile; # Checking relative vs absolute paths $file = Test::MockFile->file( '/foo/../bar', '...' ); # not ok - relative path $file = Test::MockFile->file( '/bar', '...' ); # ok - absolute path $file = Test::MockFile->file( 'bar', '...' ); # ok - current dir =cut use constant STRICT_MODE_DISABLED => 1; use constant STRICT_MODE_ENABLED => 2; use constant STRICT_MODE_UNSET => 4; use constant STRICT_MODE_DEFAULT => STRICT_MODE_ENABLED | STRICT_MODE_UNSET; # default state when unset by user our $STRICT_MODE_STATUS; BEGIN { $STRICT_MODE_STATUS = STRICT_MODE_DEFAULT; } # Perl understands barewords are filehandles during compilation and # parsing. If we override the functions, Perl will not show these as # filehandles, but as strings # We can try to convert it to the typeglob in the right namespace sub _upgrade_barewords { my @args = @_; my $caller = caller(1); # Add bareword information to the args # Default: no unshift @args, 0; # Ignore variables # Barewords are provided as strings, which means they're read-only # (Of course, readonly scalars here will fool us...) Internals::SvREADONLY( $_[0] ) or return @args; # Upgrade the handle my $handle; { no strict 'refs'; my $caller_pkg = caller(1); $handle = *{"$caller_pkg\::$args[1]"}; } # Check that the upgrading worked ref \$handle eq 'GLOB' or return @args; # Set to bareword $args[0] = 1; # Override original handle variable/string $args[1] = $handle; return @args; } =head2 authorized_strict_mode_for_package( $pkg ) Add a package namespace to the list of authorize namespaces. authorized_strict_mode_for_package( 'Your::Package' ); =cut our %authorized_strict_mode_packages; sub authorized_strict_mode_for_package { my ($pkg) = @_; $authorized_strict_mode_packages{$pkg} = 1; return; } BEGIN { authorized_strict_mode_for_package($_) for qw{ DynaLoader lib }; } =head2 file_arg_position_for_command Args: ($command) Provides a hint with the position of the argument most likely holding the file name for the current C<$command> call. This is used internaly to provide better error messages. This can be used when plugging hooks to know what's the filename we currently try to access. =cut my $_file_arg_post; sub file_arg_position_for_command { # can also be used by user hooks my ( $command, $at_under_ref ) = @_; $_file_arg_post //= { 'chmod' => 1, 'chown' => 2, 'lstat' => 0, 'mkdir' => 0, 'open' => 2, 'opendir' => 1, 'readlink' => 0, 'rmdir' => 0, 'stat' => 0, 'sysopen' => 1, 'unlink' => 0, 'readdir' => 0, }; return -1 unless defined $command && defined $_file_arg_post->{$command}; # exception for open return 1 if $command eq 'open' && ref $at_under_ref && scalar @$at_under_ref == 2; return $_file_arg_post->{$command}; } use constant _STACK_ITERATION_MAX => 100; sub _get_stack { my @stack; foreach my $stack_level ( 1 .. _STACK_ITERATION_MAX ) { @stack = caller($stack_level); last if !scalar @stack; last if !defined $stack[0]; # We don't know when this would ever happen. next if $stack[0] eq __PACKAGE__; next if $stack[0] eq 'Overload::FileCheck'; # companion package return if $authorized_strict_mode_packages{ $stack[0] }; last; } return @stack; } =head2 add_strict_rule( $command_rule, $file_rule, $action ) Args: ($command_rule, $file_rule, $action) Add a custom rule to validate strictness mode. This is the fundation to add strict rules. You should use it, when none of the other helper to add rules work for you. =over =item C<$command_rule> a string or regexp or list of any to indicate which command to match =itemC<$file_rule> a string or regexp or undef or list of any to indicate which files your rules apply to. =item C<$action> a CODE ref or scalar to handle the exception. Returning '1' skip all other rules and indicate an exception. =back # Check open() on /this/file add_strict_rule( 'open', '/this/file', sub { ... } ); # always bypass the strict rule add_strict_rule( 'open', '/this/file', 1 ); # all available options add_strict_rule( 'open', '/this/file', sub { my ($context) = @_; return; # Skip this rule and continue from the next one return 0; # Strict violation, stop testing rules and die return 1; # Strict passing, stop testing rules } ); # Disallow open(), close() on everything in /tmp/ add_strict_rule( [ qw< open close > ], qr{^/tmp}xms, 0, ); # Disallow open(), close() on everything (ignore filenames) # Use add_strict_rule_for_command() instead! add_strict_rule( [ qw< open close > ], undef, 0, ); =cut my @STRICT_RULES; sub add_strict_rule { my ( $command_rule, $file_rule, $action ) = @_; defined $command_rule or croak("add_strict_rule( COMMAND, PATH, ACTION )"); croak("Invalid rule: missing action code") unless defined $action; my @commands = ref $command_rule eq 'ARRAY' ? @{$command_rule} : ($command_rule); my @files = ref $file_rule eq 'ARRAY' ? @{$file_rule} : ($file_rule); foreach my $c_rule (@commands) { foreach my $f_rule (@files) { push @STRICT_RULES, { 'command_rule' => ref $c_rule eq 'Regexp' ? $c_rule : qr/^\Q$c_rule\E$/, 'file_rule' => ( ref $f_rule eq 'Regexp' || !defined $f_rule ) ? $f_rule : qr/^\Q$f_rule\E$/, 'action' => $action, }; } } return; } =head2 clear_strict_rules() Args: none Clear all previously defined rules. (Mainly used for testing purpose) =cut sub clear_strict_rules { @STRICT_RULES = (); return; } =head2 add_strict_rule_for_filename( $file_rule, $action ) Args: ($file_rule, $action) Prefer using that helper when trying to add strict rules targeting files. Apply a rule to one or more files. add_strict_rule_for_filename( '/that/file' => sub { ... } ); add_strict_rule_for_filename( [ qw{list of files} ] => sub { ... } ); add_strict_rule_for_filename( qr{*\.t$} => sub { ... } ); add_strict_rule_for_filename( [ $dir, qr{^${dir}/} ] => 1 ); =cut sub add_strict_rule_for_filename { my ( $file_rule, $action ) = @_; return add_strict_rule( qr/.*/, $file_rule, $action ); } =head2 add_strict_rule_for_command( $command_rule, $action ) Args: ($command_rule, $action) Prefer using that helper when trying to add strict rules targeting specici commands. Apply a rule to one or more files. add_strict_rule_for_command( 'open' => sub { ... } ); add_strict_rule_for_command( [ qw{open readdir} ] => sub { ... } ); add_strict_rule_for_command( qr{open.*} => sub { ... } ); Test::MockFile::add_strict_rule_for_command( [qw{ readdir closedir readlink }], sub { my ($ctx) = @_; my $command = $ctx->{command} // 'unknown'; warn( "Ignoring strict mode violation for $command" ); return 1; } ); =cut sub add_strict_rule_for_command { my ( $command_rule, $action, $extra ) = @_; if ($extra) { die q[Syntax not supported (extra arg) for 'add_strict_rule_for_command', please consider using 'add_strict_rule' instead.]; } return add_strict_rule( $command_rule, undef, $action ); } =head2 add_strict_rule_generic( $action ) Args: ($action) Prefer using that helper when adding a rule which is global and does not apply to a specific command or file. Apply a rule to one or more files. add_strict_rule_generic( sub { ... } ); add_strict_rule_generic( sub { my ($ctx) = @_; my $filename = $ctx->{filename}; return unless defined $filename; return 1 if UNIVERSAL::isa( $filename, 'GLOB' ); return; } ); =cut sub add_strict_rule_generic { my ($action) = @_; return add_strict_rule( qr/.*/, undef, $action ); } =head2 is_strict_mode Boolean helper to determine if strict mode is currently enabled. =cut sub is_strict_mode { return $STRICT_MODE_STATUS & STRICT_MODE_ENABLED ? 1 : 0; } sub _strict_mode_violation { my ( $command, $at_under_ref ) = @_; return unless is_strict_mode(); # These commands deal with dir handles we should have already been in violation when we opened the thing originally. return if grep { $command eq $_ } qw/readdir telldir rewinddir seekdir closedir/; my @stack = _get_stack(); return unless scalar @stack; # skip the package my $filename; # check it later so we give priority to authorized_strict_mode_packages my $file_arg = file_arg_position_for_command( $command, $at_under_ref ); if ( $file_arg >= 0 ) { $filename = scalar @$at_under_ref <= $file_arg ? '' : $at_under_ref->[$file_arg]; } # Ignore stats on STDIN, STDOUT, STDERR return if defined $filename && $filename =~ m/^\*?(?:main::)?[<*&+>]*STD(?:OUT|IN|ERR)$/; # The filename passed is actually a handle. This means that, usually, # we don't need to check if it's a violation since something else should # have opened it first. open and sysopen, though, require special care. # if ( UNIVERSAL::isa( $filename, 'GLOB' ) ) { return if $command ne 'open' && $command ne 'sysopen'; } # open >& is for file dups. this isn't a real file access. return if $command eq 'open' && $at_under_ref->[1] && $at_under_ref->[1] =~ m/&/; my $path = _abs_path_to_file($filename); my $context = { command => $command, filename => $path, at_under_ref => $at_under_ref }; # object my $pass = _validate_strict_rules($context); return if $pass; croak("Unknown strict mode violation for $command") if $file_arg == -1; confess("Use of $command to access unmocked file or directory '$filename' in strict mode at $stack[1] line $stack[2]"); } sub _validate_strict_rules { my ($context) = @_; # rules dispatch foreach my $rule (@STRICT_RULES) { # This is when a rule was added without a filename at all # intending to match whether there's a filename available or not # (open() can be used on a scalar, for example) if ( defined $rule->{'file_rule'} ) { defined $context->{'filename'} && $context->{'filename'} =~ $rule->{'file_rule'} or next; } $context->{'command'} =~ $rule->{'command_rule'} or next; my $answer = ref $rule->{'action'} ? $rule->{'action'}->($context) : $rule->{'action'}; defined $answer and return $answer; } # We say it failed even though it didn't # It's because we want to test the internal violation rule check return; } my @plugins; sub import { my ( $class, @args ) = @_; my $strict_mode = ( grep { $_ eq 'nostrict' } @args ) ? STRICT_MODE_DISABLED : STRICT_MODE_ENABLED; if ( defined $STRICT_MODE_STATUS && !( $STRICT_MODE_STATUS & STRICT_MODE_UNSET ) # mode is set by user && $STRICT_MODE_STATUS != $strict_mode ) { # could consider using authorized_strict_mode_packages for all packages die q[Test::MockFile is imported multiple times with different strict modes (not currently supported) ] . $class; } $STRICT_MODE_STATUS = $strict_mode; while ( my $opt = shift @args ) { next unless defined $opt && $opt eq 'plugin'; my $what = shift @args; require Test::MockFile::Plugins; push @plugins, Test::MockFile::Plugins::load_plugin($what); } return; } =head1 SUBROUTINES/METHODS =head2 file Args: ($file, $contents, $stats) This will make cause $file to be mocked in all file checks, opens, etc. C contents means that the file should act like it's not there. You can only set the stats if you provide content. If you give file content, the directory inside it will be mocked as well. my $f = Test::MockFile->file( '/foo/bar' ); -d '/foo' # not ok my $f = Test::MockFile->file( '/foo/bar', 'some content' ); -d '/foo' # ok See L for what goes into the stats hashref. =cut sub file { my ( $class, $file, $contents, @stats ) = @_; ( defined $file && length $file ) or confess("No file provided to instantiate $class"); _is_path_mocked($file) and confess("It looks like $file is already being mocked. We don't support double mocking yet."); my $path = _abs_path_to_file($file); _validate_path($_) for $file, $path; if ( @stats > 1 ) { confess( sprintf 'Unkownn arguments (%s) passed to file() as stats', join ', ', @stats ); } !defined $contents && @stats and confess("You cannot set stats for non-existent file '$path'"); my %stats; if (@stats) { ref $stats[0] eq 'HASH' or confess('->file( FILE_NAME, FILE_CONTENT, { STAT_INFORMATION } )'); %stats = %{ $stats[0] }; } my $perms = S_IFPERMS & ( defined $stats{'mode'} ? int( $stats{'mode'} ) : 0666 ); $stats{'mode'} = ( $perms ^ umask ) | S_IFREG; # Check if directory for this file is an object we're mocking # If so, mark it now as having content # which is this file or - if this file is undef, . and .. ( my $dirname = $path ) =~ s{ / [^/]+ $ }{}xms; if ( defined $contents && $files_being_mocked{$dirname} ) { $files_being_mocked{$dirname}{'has_content'} = 1; } return $class->new( { 'path' => $path, 'contents' => $contents, %stats } ); } =head2 file_from_disk Args: C<($file_to_mock, $file_on_disk, $stats)> This will make cause C<$file> to be mocked in all file checks, opens, etc. If C isn't present, then this will die. See L for what goes into the stats hashref. =cut sub file_from_disk { my ( $class, $file, $file_on_disk, @stats ) = @_; my $fh; local $!; if ( !CORE::open( $fh, '<', $file_on_disk ) ) { $file_on_disk //= ''; confess("Sorry, I cannot read from $file_on_disk to mock $file. It doesn't appear to be present ($!)"); } local $/; my $contents = <$fh>; # Slurp! close $fh; return __PACKAGE__->file( $file, $contents, @stats ); } =head2 symlink Args: ($readlink, $file ) This will cause $file to be mocked in all file checks, opens, etc. C<$readlink> indicates what "fake" file it points to. If the file C<$readlink> points to is not mocked, it will act like a broken link, regardless of what's on disk. If C<$readlink> is undef, then the symlink is mocked but not present.(lstat $file is empty.) Stats are not able to be specified on instantiation but can in theory be altered after the object is created. People don't normally mess with the permissions on a symlink. =cut sub symlink { my ( $class, $readlink, $file ) = @_; ( defined $file && length $file ) or confess("No file provided to instantiate $class"); ( !defined $readlink || length $readlink ) or confess("No file provided for $file to point to in $class"); _is_path_mocked($file) and confess("It looks like $file is already being mocked. We don't support double mocking yet."); # Check if directory for this file is an object we're mocking # If so, mark it now as having content # which is this file or - if this file is undef, . and .. ( my $dirname = $file ) =~ s{ / [^/]+ $ }{}xms; if ( $files_being_mocked{$dirname} ) { $files_being_mocked{$dirname}{'has_content'} = 1; } return $class->new( { 'path' => $file, 'contents' => undef, 'readlink' => $readlink, 'mode' => 07777 | S_IFLNK, } ); } sub _validate_path { my $path = shift; # Reject the following: # ./ ../ /. /.. /./ /../ if ( $path =~ m{ ( ^ | / ) \.{2} ( / | $ ) }xms ) { confess('Relative paths are not supported'); } return; } =head2 dir Args: ($dir) This will cause $dir to be mocked in all file checks, and C interactions. The directory name is normalized so any trailing slash is removed. $dir = Test::MockFile->dir( 'mydir/', ... ); # ok $dir->path(); # mydir If there were previously mocked files (within the same scope), the directory will exist. Otherwise, the directory will be nonexistent. my $dir = Test::MockFile->dir('/etc'); -d $dir; # not ok since directory wasn't created yet $dir->contents(); # undef # Now we can create an empty directory mkdir '/etc'; $dir_etc->contents(); # . .. # Alternatively, we can already create files with ->file() $dir_log = Test::MockFile->dir('/var'); $file_log = Test::MockFile->file( '/var/log/access_log', $some_content ); $dir_log->contents(); # . .. access_log # If you create a nonexistent file but then give it content, it will create # the directory for you my $file = Test::MockFile->file('/foo/bar'); my $dir = Test::MockFile->dir('/foo'); -d '/foo' # false -e '/foo/bar'; # false $dir->contents(); # undef $file->contents('hello'); -e '/foo/bar'; # true -d '/foo'; # true $dir->contents(); # . .. bar NOTE: Because C<.> and C<..> will always be the first things C returns, These files are automatically inserted at the front of the array. The order of files is sorted. If you want to affect the stat information of a directory, you need to use the available core Perl keywords. (We might introduce a special helper method for it in the future.) $d = Test::MockFile->dir( '/foo', [], { 'mode' => 0755 } ); # dies $d = Test::MockFile->dir( '/foo', undef, { 'mode' => 0755 } ); # dies $d = Test::MockFile->dir('/foo'); mkdir $d, 0755; # ok =cut sub dir { my ( $class, $dirname ) = @_; ( defined $dirname && length $dirname ) or confess("No directory name provided to instantiate $class"); _is_path_mocked($dirname) and confess("It looks like $dirname is already being mocked. We don't support double mocking yet."); my $path = _abs_path_to_file($dirname); _validate_path($_) for $dirname, $path; # Cleanup trailing forward slashes $path ne '/' and $path =~ s{[/\\]$}{}xmsg; @_ > 2 and confess("You cannot set stats for nonexistent dir '$path'"); my $perms = S_IFPERMS & 0777; my %stats = ( 'mode' => ( $perms ^ umask ) | S_IFDIR ); # TODO: Add stat information # FIXME: Quick and dirty: provide a helper method? my $has_content = grep m{^\Q$path/\E}xms, %files_being_mocked; return $class->new( { 'path' => $path, 'has_content' => $has_content, %stats } ); } =head2 new_dir # short form $new_dir = Test::MockFile->new_dir( '/path' ); $new_dir = Test::MockFile->new_dir( '/path', { 'mode' => 0755 } ); # longer form 1 $dir = Test::MockFile->dir('/path'); mkdir $dir->path(), 0755; # longer form 2 $dir = Test::MockFile->dir('/path'); mkdir $dir->path(); chmod $dir->path(); This creates a new directory with an optional mode. This is a short-hand that might be removed in the future when a stable, new interface is introduced. =cut sub new_dir { my ( $class, $dirname, $opts ) = @_; my $mode; my @args = $opts ? $opts : (); if ( ref $opts eq 'HASH' && $opts->{'mode'} ) { $mode = delete $opts->{'mode'}; # This is to make sure the error checking still happens as expected if ( keys %{$opts} == 0 ) { @args = (); } } my $dir = $class->dir( $dirname, @args ); if ($mode) { __mkdir( $dirname, $mode ); } else { __mkdir($dirname); } return $dir; } =head2 Mock Stats When creating mocked files or directories, we default their stats to: my $attrs = Test::MockFile->file( $file, $contents, { 'dev' => 0, # stat[0] 'inode' => 0, # stat[1] 'mode' => $mode, # stat[2] 'nlink' => 0, # stat[3] 'uid' => int $>, # stat[4] 'gid' => int $), # stat[5] 'rdev' => 0, # stat[6] 'atime' => $now, # stat[8] 'mtime' => $now, # stat[9] 'ctime' => $now, # stat[10] 'blksize' => 4096, # stat[11] 'fileno' => undef, # fileno() } ); You'll notice that mode, size, and blocks have been left out of this. Mode is set to 666 (for files) or 777 (for directories), xored against the current umask. Size and blocks are calculated based on the size of 'contents' a.k.a. the fake file. When you want to override one of the defaults, all you need to do is specify that when you declare the file or directory. The rest will continue to default. my $mfile = Test::MockFile->file("/root/abc", "...", {inode => 65, uid => 123, mtime => int((2000-1970) * 365.25 * 24 * 60 * 60 })); my $mdir = Test::MockFile->dir("/sbin", "...", { mode => 0700 })); =head2 new This class method is called by file/symlink/dir. There is no good reason to call this directly. =cut sub new { my $class = shift @_; my %opts; if ( scalar @_ == 1 && ref $_[0] ) { %opts = %{ $_[0] }; } elsif ( scalar @_ % 2 ) { confess( sprintf( "Unknown args (%d) passed to new", scalar @_ ) ); } else { %opts = @_; } my $path = $opts{'path'} or confess("Mock file created without a path (filename or dirname)!"); if ( $path !~ m{^/} ) { $path = $opts{'path'} = _abs_path_to_file($path); } my $now = time; my $self = bless { 'dev' => 0, # stat[0] 'inode' => 0, # stat[1] 'mode' => 0, # stat[2] 'nlink' => 0, # stat[3] 'uid' => int $>, # stat[4] 'gid' => int $), # stat[5] 'rdev' => 0, # stat[6] # 'size' => undef, # stat[7] -- Method call 'atime' => $now, # stat[8] 'mtime' => $now, # stat[9] 'ctime' => $now, # stat[10] 'blksize' => 4096, # stat[11] # 'blocks' => 0, # stat[12] -- Method call 'fileno' => undef, # fileno() 'tty' => 0, # possibly this is already provided in mode? 'readlink' => '', # what the symlink points to. 'path' => undef, 'contents' => undef, 'has_content' => undef, }, $class; foreach my $key ( keys %opts ) { # Ignore Stuff that's not a valid key for this class. next unless exists $self->{$key}; # If it's passed in, we override them. $self->{$key} = $opts{$key}; } $self->{'fileno'} //= _unused_fileno(); $files_being_mocked{$path} = $self; Scalar::Util::weaken( $files_being_mocked{$path} ); return $self; } #Overload::FileCheck::mock_stat(\&mock_stat); sub _mock_stat { my ( $type, $file_or_fh ) = @_; $type or confess("_mock_stat called without a stat type"); my $follow_link = $type eq 'stat' ? 1 : $type eq 'lstat' ? 0 : confess("Unexpected stat type '$type'"); # Overload::FileCheck should always send 2 args. if ( scalar @_ != 2 ) { _real_file_access_hook( $type, [$file_or_fh] ); return FALLBACK_TO_REAL_OP(); } # Overload::FileCheck should always send something and be handling undef on its own?? if ( !defined $file_or_fh || !length $file_or_fh ) { _real_file_access_hook( $type, [$file_or_fh] ); return FALLBACK_TO_REAL_OP(); } # Find the path, following the symlink if required. my $file = _find_file_or_fh( $file_or_fh, $follow_link ); return [] if defined $file && defined BROKEN_SYMLINK && $file eq BROKEN_SYMLINK; # Allow an ELOOP to fall through here. return [] if defined $file && defined CIRCULAR_SYMLINK && $file eq CIRCULAR_SYMLINK; # Allow an ELOOP to fall through here. if ( !defined $file or !length $file ) { _real_file_access_hook( $type, [$file_or_fh] ); return FALLBACK_TO_REAL_OP(); } my $file_data = _get_file_object($file); if ( !$file_data ) { _real_file_access_hook( $type, [$file_or_fh] ) unless ref $file_or_fh; return FALLBACK_TO_REAL_OP(); } # File is not present so no stats for you! return [] if !$file_data->is_link && !defined $file_data->contents(); # Make sure the file size is correct in the stats before returning its contents. return [ $file_data->stat ]; } sub _is_path_mocked { my ($file_path) = @_; my $absolute_path_to_file = _find_file_or_fh($file_path) or return; return $files_being_mocked{$absolute_path_to_file} ? 1 : 0; } sub _get_file_object { my ($file_path) = @_; my $file = _find_file_or_fh($file_path) or return; return $files_being_mocked{$file}; } # This subroutine finds the absolute path to a file, returning the absolute path of what it ultimately points to. # If it is a broken link or what was passed in is undef or '', then we return undef. sub _find_file_or_fh { my ( $file_or_fh, $follow_link, $depth ) = @_; # Find the file handle or fall back to just using the abs path of $file_or_fh my $absolute_path_to_file = _fh_to_file($file_or_fh) // _abs_path_to_file($file_or_fh) // ''; $absolute_path_to_file ne '/' and $absolute_path_to_file =~ s{[/\\]$}{}xmsg; # Get the pointer to the object. my $mock_object = $files_being_mocked{$absolute_path_to_file}; # If we're following a symlink and the path we came to is a dead end (broken symlink), then return BROKEN_SYMLINK up the stack. return BROKEN_SYMLINK if $depth and !$mock_object; # If the link we followed isn't a symlink, then return it. return $absolute_path_to_file unless $mock_object && $mock_object->is_link; # ############## # From here on down we're only dealing with symlinks. # ############## # If we weren't told to follow the symlink then SUCCESS! return $absolute_path_to_file unless $follow_link; # This is still a symlink keep going. Bump our depth counter. $depth++; #Protect against circular symlink loops. if ( $depth > FOLLOW_LINK_MAX_DEPTH ) { $! = ELOOP; return CIRCULAR_SYMLINK; } return _find_file_or_fh( $mock_object->readlink, 1, $depth ); } # Tries to find $fh as a open file handle in one of the mocked files. sub _fh_to_file { my ($fh) = @_; return unless defined $fh && length $fh; # See if $fh is a file handle. It might be a path. foreach my $path ( sort keys %files_being_mocked ) { my $mock_fh = $files_being_mocked{$path}->{'fh'}; next unless $mock_fh; # File isn't open. next unless "$mock_fh" eq "$fh"; # This mock doesn't have this file handle open. return $path; } return; } sub _files_in_dir { my $dirname = shift; my @files_in_dir = @files_being_mocked{ grep m{^\Q$dirname/\E}, keys %files_being_mocked }; return @files_in_dir; } sub _abs_path_to_file { my ($path) = shift; return unless defined $path; my $match = 1; while ($match) { $match = 0; $match = 1 if $path =~ s{//+}{/}xmsg; # cleanup multiple slashes $match = 1 if $path =~ s{/\.$}{/}; $match = 1 if $path =~ s{(?:[^/]+)/\.\.(/|$)}{$1}; $match = 1 if $path =~ s{/$}{}; } return q[/] if $path eq q[/..]; return $path if $path =~ m{^/}xms; # ~ # ~/... # ~sawyer if ( $path =~ m{ ^(~ ([^/]+)? ) }xms ) { my $req_homedir = $1; my $username = $2 || getpwuid($<); my $pw_homedir; # Reset iterator so we *definitely* start from the first one # Then reset when done looping over pw entries endpwent; while ( my @pwdata = getpwent ) { if ( $pwdata[0] eq $username ) { $pw_homedir = $pwdata[7]; endpwent; last; } } endpwent; $pw_homedir or die; $path =~ s{\Q$req_homedir\E}{$pw_homedir}; return $path; } my $cwd = Cwd::getcwd(); return $cwd if $path eq '.'; return Cwd::getcwd() . "/$path"; } sub DESTROY { my ($self) = @_; ref $self or return; # This is just a safety. It doesn't make much sense if we get here but # $self doesn't have a path. Either way we can't delete it. my $path = $self->{'path'}; defined $path or return; # If the object survives into global destruction, the object which is # the value of $files_being_mocked{$path} might destroy early. # As a result, don't worry about the self == check just delete the key. if ( defined $files_being_mocked{$path} ) { $self == $files_being_mocked{$path} or confess("Tried to destroy object for $path ($self) but something else is mocking it?"); } delete $files_being_mocked{$path}; } =head2 contents Optional Arg: $contents Retrieves or updates the current contents of the file. Only retrieves the content of the directory (as an arrayref). You can set directory contents with calling the C method described above. Symlinks have no contents. =cut sub contents { my ( $self, $new_contents ) = @_; $self or confess; $self->is_link and confess("checking or setting contents on a symlink is not supported"); # handle directories if ( $self->is_dir() ) { $new_contents and confess('To change the contents of the dir, you must work on its files'); $self->{'has_content'} or return; # TODO: Quick and dirty, but works (maybe provide a ->basename()?) # Retrieve the files in this directory and removes prefix my $dirname = $self->path(); my @existing_files = sort map { # strip directory from the path ( my $basename = $_->path() ) =~ s{^\Q$dirname/\E}{}xms; # Is this content within another directory? strip that out $basename =~ s{^( [^/]+ ) / .*}{$1}xms; defined $_->{'contents'} || $_->is_link() || $_->is_dir() ? ($basename) : (); } _files_in_dir($dirname); my %uniq; $uniq{$_}++ for @existing_files; return [ '.', '..', sort keys %uniq ]; } # handle files if ( $self->is_file() ) { if ( defined $new_contents ) { ref $new_contents and confess('File contents must be a simple string'); # XXX Why use $_[1] directly? $self->{'contents'} = $_[1]; } return $self->{'contents'}; } confess('This seems to be neither a file nor a dir - what is it?'); } =head2 filename Deprecated. Same as C. =cut sub filename { carp('filename() is deprecated, use path() instead'); goto &path; } =head2 path The path (filename or dirname) of the file or directory this mock object is controlling. =cut sub path { my ($self) = @_; $self or confess("path is a method"); return $self->{'path'}; } =head2 unlink Makes the virtual file go away. NOTE: This also works for directories. =cut sub unlink { my ($self) = @_; $self or confess("unlink is a method"); if ( !$self->exists ) { $! = ENOENT; return 0; } if ( $self->is_dir ) { if ( $] < 5.019 && ( $^O eq 'darwin' or $^O =~ m/bsd/i ) ) { $! = EPERM; } else { $! = EISDIR; } return 0; } if ( $self->is_link ) { $self->{'readlink'} = undef; } else { $self->{'has_content'} = undef; $self->{'contents'} = undef; } return 1; } =head2 touch Optional Args: ($epoch_time) This function acts like the UNIX utility touch. It sets atime, mtime, ctime to $epoch_time. If no arguments are passed, $epoch_time is set to time(). If the file does not exist, contents are set to an empty string. =cut sub touch { my ( $self, $now ) = @_; $self or confess("touch is a method"); $now //= time; $self->is_file or confess("touch only supports files"); my $pre_size = $self->size(); if ( !defined $pre_size ) { $self->contents(''); } # TODO: Should this happen any time contents goes from undef to existing? Should we be setting perms? # Normally I'd say yes but it might not matter much for a .005 second test. $self->mtime($now); $self->ctime($now); $self->atime($now); return 1; } =head2 stat Returns the stat of a mocked file (does not follow symlinks.) =cut sub stat { my $self = shift; return ( $self->{'dev'}, # stat[0] $self->{'inode'}, # stat[1] $self->{'mode'}, # stat[2] $self->{'nlink'}, # stat[3] $self->{'uid'}, # stat[4] $self->{'gid'}, # stat[5] $self->{'rdev'}, # stat[6] $self->size, # stat[7] $self->{'atime'}, # stat[8] $self->{'mtime'}, # stat[9] $self->{'ctime'}, # stat[10] $self->{'blksize'}, # stat[11] $self->blocks, # stat[12] ); } sub _unused_fileno { return 900; # TODO } =head2 readlink Optional Arg: $readlink Returns the stat of a mocked file (does not follow symlinks.) You can also use this to change what your symlink is pointing to. =cut sub readlink { my ( $self, $readlink ) = @_; $self->is_link or confess("readlink is only supported for symlinks"); if ( scalar @_ == 2 ) { if ( defined $readlink && ref $readlink ) { confess("readlink can only be set to simple strings."); } $self->{'readlink'} = $readlink; } return $self->{'readlink'}; } =head2 is_link returns true/false, depending on whether this object is a symlink. =cut sub is_link { my ($self) = @_; return ( defined $self->{'readlink'} && length $self->{'readlink'} && $self->{'mode'} & S_IFLNK ) ? 1 : 0; } =head2 is_dir returns true/false, depending on whether this object is a directory. =cut sub is_dir { my ($self) = @_; return ( ( $self->{'mode'} & S_IFMT ) == S_IFDIR ) ? 1 : 0; } =head2 is_file returns true/false, depending on whether this object is a regular file. =cut sub is_file { my ($self) = @_; return ( ( $self->{'mode'} & S_IFMT ) == S_IFREG ) ? 1 : 0; } =head2 size returns the size of the file based on its contents. =cut sub size { my ($self) = @_; # Lstat for a symlink returns 1 for its size. return 1 if $self->is_link; # length undef is 0 not undef in perl 5.10 if ( $] < 5.012 ) { return undef unless $self->exists; } return length $self->contents; } =head2 exists returns true or false based on if the file exists right now. =cut sub exists { my ($self) = @_; $self->is_link() and return defined $self->{'readlink'} ? 1 : 0; $self->is_file() and return defined $self->{'contents'} ? 1 : 0; $self->is_dir() and return $self->{'has_content'} ? 1 : 0; return 0; } =head2 blocks Calculates the block count of the file based on its size. =cut sub blocks { my ($self) = @_; my $blocks = int( $self->size / abs( $self->{'blksize'} ) + 1 ); if ( int($blocks) > $blocks ) { $blocks = int($blocks) + 1; } return $blocks; } =head2 chmod Optional Arg: $perms Allows you to alter the permissions of a file. This only allows you to change the C<07777> bits of the file permissions. The number passed should be the octal C<0755> form, not the alphabetic C<"755"> form =cut sub chmod { my ( $self, $mode ) = @_; $mode = ( int($mode) & S_IFPERMS ) ^ umask; $self->{'mode'} = ( $self->{'mode'} & S_IFMT ) + $mode; return $mode; } =head2 permissions Returns the permissions of the file. =cut sub permissions { my ($self) = @_; return int( $self->{'mode'} ) & S_IFPERMS; } =head2 mtime Optional Arg: $new_epoch_time Returns and optionally sets the mtime of the file if passed as an integer. =cut sub mtime { my ( $self, $time ) = @_; if ( scalar @_ == 2 && defined $time && $time =~ m/^[0-9]+$/ ) { $self->{'mtime'} = $time; } return $self->{'mtime'}; } =head2 ctime Optional Arg: $new_epoch_time Returns and optionally sets the ctime of the file if passed as an integer. =cut sub ctime { my ( $self, $time ) = @_; if ( @_ == 2 && defined $time && $time =~ m/^[0-9]+$/ ) { $self->{'ctime'} = $time; } return $self->{'ctime'}; } =head2 atime Optional Arg: $new_epoch_time Returns and optionally sets the atime of the file if passed as an integer. =cut sub atime { my ( $self, $time ) = @_; if ( @_ == 2 && defined $time && $time =~ m/^[0-9]+$/ ) { $self->{'atime'} = $time; } return $self->{'atime'}; } =head2 add_file_access_hook Args: ( $code_ref ) You can use B to add a code ref that gets called every time a real file (not mocked) operation happens. We use this for strict mode to die if we detect your program is unexpectedly accessing files. You are welcome to use it for whatever you like. Whenever the code ref is called, we pass 2 arguments: C<$code-E($access_type, $at_under_ref)>. Be aware that altering the variables in C<$at_under_ref> will affect the variables passed to open / sysopen, etc. One use might be: Test::MockFile::add_file_access_hook(sub { my $type = shift; print "$type called at: " . Carp::longmess() } ); =cut # always use the _strict_mode_violation my @_public_access_hooks; my @_internal_access_hooks = ( \&_strict_mode_violation ); sub add_file_access_hook { my ($code_ref) = @_; ( $code_ref && ref $code_ref eq 'CODE' ) or confess("add_file_access_hook needs to be passed a code reference."); push @_public_access_hooks, $code_ref; return 1; } =head2 clear_file_access_hooks Calling this subroutine will clear everything that was passed to B =cut sub clear_file_access_hooks { @_public_access_hooks = (); return 1; } # This code is called whenever an unmocked file is accessed. Any hooks that are setup get called from here. sub _real_file_access_hook { my ( $access_type, $at_under_ref ) = @_; foreach my $code ( @_internal_access_hooks, @_public_access_hooks ) { $code->( $access_type, $at_under_ref ); } return 1; } =head2 How this mocking is done: Test::MockFile uses 2 methods to mock file access: =head3 -X via L It is currently not possible in pure perl to override L, L and L<-X operators|http://perldoc.perl.org/functions/-X.html>. In conjunction with this module, we've developed L. This enables us to intercept calls to stat, lstat and -X operators (like -e, -f, -d, -s, etc.) and pass them to our control. If the file is currently being mocked, we return the stat (or lstat) information on the file to be used to determine the answer to whatever check was made. This even works for things like C<-e _>. If we do not control the file in question, we return C which then makes a normal check. =head3 CORE::GLOBAL:: overrides Since 5.10, it has been possible to override function calls by defining them. like: *CORE::GLOBAL::open = sub(*;$@) {...} Any code which is loaded B this happens will use the alternate open. This means you can place your C statement after statements you don't want to be mocked and there is no risk that the code will ever be altered by Test::MockFile. We oveload the following statements and then return tied handles to enable the rest of the IO functions to work properly. Only B / B are needed to address file operations. However B file handles were never setup for tie so we have to override all of B's related functions. =over =item * open =item * sysopen =item * opendir =item * readdir =item * telldir =item * seekdir =item * rewinddir =item * closedir =back =cut # goto doesn't work below 5.16 # # goto messed up refcount between 5.22 and 5.26. # Broken in 7bdb4ff0943cf93297712faf504cdd425426e57f # Fixed in https://rt.perl.org/Public/Bug/Display.html?id=115814 sub _goto_is_available { return 0 if $] < 5.015; return 1 if $] < 5.021; return 1 if $] > 5.027; return 0; # 5. } ############ # KEYWORDS # ############ sub __glob { my $spec = shift; # Text::Glob does not understand multiple patterns my @patterns = split /\s+/xms, $spec; # Text::Glob does not accept directories in globbing # But csh (and thus, Perl) does, so we need to add them my @mocked_files = grep $files_being_mocked{$_}->exists(), keys %files_being_mocked; @mocked_files = map /^(.+)\/[^\/]+$/xms ? ( $_, $1 ) : ($_), @mocked_files; # Might as well be consistent @mocked_files = sort @mocked_files; my @results = map Text::Glob::match_glob( $_, @mocked_files ), @patterns; return @results; } sub __open (*;$@) { my $likely_bareword; my $arg0; if ( defined $_[0] && !ref $_[0] ) { # We need to remember the first arg to override the typeglob for barewords $arg0 = $_[0]; ( $likely_bareword, @_ ) = _upgrade_barewords(@_); } # We need to take out the mode and file # but we must keep using $_[0] for the file-handle to update the caller my ( undef, $mode, $file ) = @_; my $arg_count = @_; # Normalize two-arg to three-arg if ( $arg_count == 2 ) { # The order here matters, so '>>' won't turn into '>' if ( $_[1] =~ /^ ( >> | [+]?> | [+]?< ) (.+) $/xms ) { $mode = $1; $file = $2; } elsif ( $_[1] =~ /^[\.\/\\\w\d\-]+$/xms ) { $mode = '<'; $file = $_[1]; } elsif ( $_[1] =~ /^\|/xms ) { $mode = '|-'; $file = $_[1]; } elsif ( $_[1] =~ /\|$/xms ) { $mode = '-|'; $file = $_[1]; } else { die "Unsupported two-way open: $_[1]\n"; } # We have all args $arg_count++; } # We're not supporting 1 arg opens yet if ( $arg_count != 3 ) { _real_file_access_hook( "open", \@_ ); goto \&CORE::open if _goto_is_available(); if ( @_ == 1 ) { return CORE::open( $_[0] ); } elsif ( @_ == 2 ) { return CORE::open( $_[0], $_[1] ); } elsif ( @_ >= 3 ) { return CORE::open( $_[0], $_[1], @_[ 2 .. $#_ ] ); } } # Allows for scalar file handles. if ( ref $file && ref $file eq 'SCALAR' ) { goto \&CORE::open if _goto_is_available(); return CORE::open( $_[0], $mode, $file ); } my $abs_path = _find_file_or_fh( $file, 1 ); # Follow the link. confess() if !$abs_path && $mode ne '|-' && $mode ne '-|'; confess() if $abs_path eq BROKEN_SYMLINK; my $mock_file = _get_file_object($abs_path); # For now we're going to just strip off the binmode and hope for the best. $mode =~ s/(:.+$)//; my $encoding_mode = $1; # TODO: We don't yet support |- or -| # TODO: We don't yet support modes outside of > < >> +< +> +>> # We just pass through to open if we're not mocking the file right now. if ( ( $mode eq '|-' || $mode eq '-|' ) or !grep { $_ eq $mode } qw/> < >> +< +> +>>/ or !defined $mock_file ) { _real_file_access_hook( "open", \@_ ); goto \&CORE::open if _goto_is_available(); if ( @_ == 1 ) { return CORE::open( $_[0] ); } elsif ( @_ == 2 ) { return CORE::open( $_[0], $_[1] ); } elsif ( @_ >= 3 ) { return CORE::open( $_[0], $_[1], @_[ 2 .. $#_ ] ); } } # At this point we're mocking the file. Let's do it! # If contents is undef, we act like the file isn't there. if ( !defined $mock_file->contents() && grep { $mode eq $_ } qw/< + +>> +>> > >>/; my $filefh = IO::File->new; tie *{$filefh}, 'Test::MockFile::FileHandle', $abs_path, $rw; if ($likely_bareword) { my $caller = caller(); no strict; *{"${caller}::$arg0"} = $filefh; @_ = ( $filefh, $_[1] ? @_[ 1 .. $#_ ] : () ); } else { $_[0] = $filefh; } # This is how we tell if the file is open by something. $mock_file->{'fh'} = $_[0]; Scalar::Util::weaken( $mock_file->{'fh'} ) if ref $_[0]; # Will this make it go out of scope? # Fix tell based on open options. if ( $mode eq '>>' or $mode eq '+>>' ) { $mock_file->{'contents'} //= ''; seek $_[0], length( $mock_file->{'contents'} ), 0; } elsif ( $mode eq '>' or $mode eq '+>' ) { $mock_file->{'contents'} = ''; } return 1; } # sysopen FILEHANDLE, FILENAME, MODE, MASK # sysopen FILEHANDLE, FILENAME, MODE # We curently support: # 1 - O_RDONLY - Read only. # 2 - O_WRONLY - Write only. # 3 - O_RDWR - Read and write. # 6 - O_APPEND - Append to the file. # 7 - O_TRUNC - Truncate the file. # 5 - O_EXCL - Fail if the file already exists. # 4 - O_CREAT - Create the file if it doesn't exist. # 8 - O_NOFOLLOW - Fail if the last path component is a symbolic link. sub __sysopen (*$$;$) { my $mock_file = _get_file_object( $_[1] ); if ( !$mock_file ) { _real_file_access_hook( "sysopen", \@_ ); goto \&CORE::sysopen if _goto_is_available(); return CORE::sysopen( $_[0], $_[1], @_[ 2 .. $#_ ] ); } my $sysopen_mode = $_[2]; # Not supported by my linux vendor: O_EXLOCK | O_SHLOCK if ( ( $sysopen_mode & SUPPORTED_SYSOPEN_MODES ) != $sysopen_mode ) { confess( sprintf( "Sorry, can't open %s with 0x%x permissions. Some of your permissions are not yet supported by %s", $_[1], $sysopen_mode, __PACKAGE__ ) ); } # O_NOFOLLOW if ( ( $sysopen_mode & O_NOFOLLOW ) == O_NOFOLLOW && $mock_file->is_link ) { $! = 40; return undef; } # O_EXCL if ( $sysopen_mode & O_EXCL && $sysopen_mode & O_CREAT && defined $mock_file->{'contents'} ) { $! = EEXIST; return; } # O_CREAT if ( $sysopen_mode & O_CREAT && !defined $mock_file->{'contents'} ) { $mock_file->{'contents'} = ''; } # O_TRUNC if ( $sysopen_mode & O_TRUNC && defined $mock_file->{'contents'} ) { $mock_file->{'contents'} = ''; } my $rd_wr_mode = $sysopen_mode & 3; my $rw = $rd_wr_mode == O_RDONLY ? 'r' : $rd_wr_mode == O_WRONLY ? 'w' : $rd_wr_mode == O_RDWR ? 'rw' : confess("Unexpected sysopen read/write mode ($rd_wr_mode)"); # O_WRONLY| O_RDWR mode makes no sense and we should die. # If contents is undef, we act like the file isn't there. if ( !defined $mock_file->{'contents'} && $rd_wr_mode == O_RDONLY ) { $! = ENOENT; return; } my $abs_path = $mock_file->{'path'}; $_[0] = IO::File->new; tie *{ $_[0] }, 'Test::MockFile::FileHandle', $abs_path, $rw; # This is how we tell if the file is open by something. $files_being_mocked{$abs_path}->{'fh'} = $_[0]; Scalar::Util::weaken( $files_being_mocked{$abs_path}->{'fh'} ) if ref $_[0]; # Will this make it go out of scope? # O_TRUNC if ( $sysopen_mode & O_TRUNC ) { $mock_file->{'contents'} = ''; } # O_APPEND if ( $sysopen_mode & O_APPEND ) { seek $_[0], length $mock_file->{'contents'}, 0; } return 1; } sub __opendir (*$) { # Upgrade but ignore bareword indicator ( undef, @_ ) = _upgrade_barewords(@_) if defined $_[0] && !ref $_[9]; my $mock_dir = _get_file_object( $_[1] ); # 1 arg Opendir doesn't work?? if ( scalar @_ != 2 or !defined $_[1] ) { _real_file_access_hook( "opendir", \@_ ); goto \&CORE::opendir if _goto_is_available(); return CORE::opendir( $_[0], @_[ 1 .. $#_ ] ); } if ( !$mock_dir ) { _real_file_access_hook( "opendir", \@_ ); goto \&CORE::opendir if _goto_is_available(); return CORE::opendir( $_[0], $_[1] ); } if ( !defined $mock_dir->contents ) { $! = ENOENT; return undef; } if ( !( $mock_dir->{'mode'} & S_IFDIR ) ) { $! = ENOTDIR; return undef; } if ( !defined $_[0] ) { $_[0] = Symbol::gensym; } elsif ( ref $_[0] ) { no strict 'refs'; *{ $_[0] } = Symbol::geniosym; } # This is how we tell if the file is open by something. my $abs_path = $mock_dir->{'path'}; $mock_dir->{'obj'} = Test::MockFile::DirHandle->new( $abs_path, $mock_dir->contents() ); $mock_dir->{'fh'} = "$_[0]"; return 1; } sub __readdir (*) { # Upgrade but ignore bareword indicator ( undef, @_ ) = _upgrade_barewords(@_) if defined $_[0] && !ref $_[9]; my $mocked_dir = _get_file_object( $_[0] ); if ( !$mocked_dir ) { _real_file_access_hook( 'readdir', \@_ ); goto \&CORE::readdir if _goto_is_available(); return CORE::readdir( $_[0] ); } my $obj = $mocked_dir->{'obj'}; if ( !$obj ) { confess("Read on a closed handle"); } if ( !defined $obj->{'files_in_readdir'} ) { confess("Did a readdir on an empty dir. This shouldn't have been able to have been opened!"); } if ( !defined $obj->{'tell'} ) { confess("readdir called on a closed dirhandle"); } # At EOF for the dir handle. return undef if $obj->{'tell'} > $#{ $obj->{'files_in_readdir'} }; if (wantarray) { my @return; foreach my $pos ( $obj->{'tell'} .. $#{ $obj->{'files_in_readdir'} } ) { push @return, $obj->{'files_in_readdir'}->[$pos]; } $obj->{'tell'} = $#{ $obj->{'files_in_readdir'} } + 1; return @return; } return $obj->{'files_in_readdir'}->[ $obj->{'tell'}++ ]; } sub __telldir (*) { # Upgrade but ignore bareword indicator ( undef, @_ ) = _upgrade_barewords(@_) if defined $_[0] && !ref $_[9]; my ($fh) = @_; my $mocked_dir = _get_file_object($fh); if ( !$mocked_dir || !$mocked_dir->{'obj'} ) { _real_file_access_hook( 'telldir', \@_ ); goto \&CORE::telldir if _goto_is_available(); return CORE::telldir($fh); } my $obj = $mocked_dir->{'obj'}; if ( !defined $obj->{'files_in_readdir'} ) { confess("Did a telldir on an empty dir. This shouldn't have been able to have been opened!"); } if ( !defined $obj->{'tell'} ) { confess("telldir called on a closed dirhandle"); } return $obj->{'tell'}; } sub __rewinddir (*) { # Upgrade but ignore bareword indicator ( undef, @_ ) = _upgrade_barewords(@_) if defined $_[0] && !ref $_[9]; my ($fh) = @_; my $mocked_dir = _get_file_object($fh); if ( !$mocked_dir || !$mocked_dir->{'obj'} ) { _real_file_access_hook( 'rewinddir', \@_ ); goto \&CORE::rewinddir if _goto_is_available(); return CORE::rewinddir( $_[0] ); } my $obj = $mocked_dir->{'obj'}; if ( !defined $obj->{'files_in_readdir'} ) { confess("Did a rewinddir on an empty dir. This shouldn't have been able to have been opened!"); } if ( !defined $obj->{'tell'} ) { confess("rewinddir called on a closed dirhandle"); } $obj->{'tell'} = 0; return 1; } sub __seekdir (*$) { # Upgrade but ignore bareword indicator ( undef, @_ ) = _upgrade_barewords(@_) if defined $_[0] && !ref $_[9]; my ( $fh, $goto ) = @_; my $mocked_dir = _get_file_object($fh); if ( !$mocked_dir || !$mocked_dir->{'obj'} ) { _real_file_access_hook( 'seekdir', \@_ ); goto \&CORE::seekdir if _goto_is_available(); return CORE::seekdir( $fh, $goto ); } my $obj = $mocked_dir->{'obj'}; if ( !defined $obj->{'files_in_readdir'} ) { confess("Did a seekdir on an empty dir. This shouldn't have been able to have been opened!"); } if ( !defined $obj->{'tell'} ) { confess("seekdir called on a closed dirhandle"); } return $obj->{'tell'} = $goto; } sub __closedir (*) { # Upgrade but ignore bareword indicator ( undef, @_ ) = _upgrade_barewords(@_) if defined $_[0] && !ref $_[9]; my ($fh) = @_; my $mocked_dir = _get_file_object($fh); if ( !$mocked_dir || !$mocked_dir->{'obj'} ) { _real_file_access_hook( 'closedir', \@_ ); goto \&CORE::closedir if _goto_is_available(); return CORE::closedir($fh); } delete $mocked_dir->{'obj'}; delete $mocked_dir->{'fh'}; return 1; } sub __unlink (@) { my @files_to_unlink = @_; my $files_deleted = 0; foreach my $file (@files_to_unlink) { my $mock = _get_file_object($file); if ( !$mock ) { _real_file_access_hook( "unlink", [$file] ); $files_deleted += CORE::unlink($file); } else { $files_deleted += $mock->unlink; } } return $files_deleted; } sub __readlink (_) { my ($file) = @_; if ( !defined $file ) { carp('Use of uninitialized value in readlink'); if ( $^O eq 'freebsd' ) { $! = EINVAL; } else { $! = ENOENT; } return; } my $mock_object = _get_file_object($file); if ( !$mock_object ) { _real_file_access_hook( 'readlink', \@_ ); goto \&CORE::readlink if _goto_is_available(); return CORE::readlink($file); } if ( !$mock_object->is_link ) { $! = EINVAL; return; } return $mock_object->readlink; } # $file is always passed because of the prototype. sub __mkdir (_;$) { my ( $file, $perms ) = @_; $perms = ( $perms // 0777 ) & S_IFPERMS; if ( !defined $file ) { # mkdir warns if $file is undef carp("Use of uninitialized value in mkdir"); $! = ENOENT; return 0; } my $mock = _get_file_object($file); if ( !$mock ) { _real_file_access_hook( 'mkdir', \@_ ); goto \&CORE::mkdir if _goto_is_available(); return CORE::mkdir(@_); } # File or directory, this exists and should fail if ( $mock->exists ) { $! = EEXIST; return 0; } # If the mock was a symlink or a file, we've just made it a dir. $mock->{'mode'} = ( $perms ^ umask ) | S_IFDIR; delete $mock->{'readlink'}; # This should now start returning content $mock->{'has_content'} = 1; return 1; } # $file is always passed because of the prototype. sub __rmdir (_) { my ($file) = @_; # technically this is a minor variation from core. We don't seem to be able to # detect when they didn't pass an arg like core can. # Core sometimes warns: 'Use of uninitialized value $_ in rmdir' if ( !defined $file ) { carp('Use of uninitialized value in rmdir'); return 0; } my $mock = _get_file_object($file); if ( !$mock ) { _real_file_access_hook( 'rmdir', \@_ ); goto \&CORE::rmdir if _goto_is_available(); return CORE::rmdir($file); } # Because we've mocked this to be a file and it doesn't exist we are going to die here. # The tester needs to fix this presumably. if ( $mock->exists ) { if ( $mock->is_file ) { $! = ENOTDIR; return 0; } if ( $mock->is_link ) { $! = ENOTDIR; return 0; } } if ( !$mock->exists ) { $! = ENOENT; return 0; } if ( _files_in_dir($file) ) { $! = 39; return 0; } $mock->{'has_content'} = undef; return 1; } sub __chown (@) { my ( $uid, $gid, @files ) = @_; $^O eq 'MSWin32' and return 0; # does nothing on Windows # Not an error, report we changed zero files @files or return 0; my %mocked_files = map +( $_ => _get_file_object($_) ), @files; my @unmocked_files = grep !$mocked_files{$_}, @files; my @mocked_files = map ref $_ ? $_->{'path'} : (), values %mocked_files; # The idea is that if some are mocked and some are not, # it's probably a mistake if ( @mocked_files && @mocked_files != @files ) { confess( sprintf 'You called chown() on a mix of mocked (%s) and unmocked files (%s) ' . ' - this is very likely a bug on your side', ( join ', ', @mocked_files ), ( join ', ', @unmocked_files ), ); } # -1 means "keep as is" $uid == -1 and $uid = $>; $gid == -1 and $gid = $); my $is_root = $> == 0 || $) =~ /( ^ | \s ) 0 ( \s | $)/xms; my $is_in_group = grep /(^ | \s ) \Q$gid\E ( \s | $ )/xms, $); # TODO: Perl has an odd behavior that -1, -1 on a file that isn't owned by you still works # Not sure how to write a test for it though... my $set_error; my $num_changed = 0; foreach my $file (@files) { my $mock = $mocked_files{$file}; # If this file is not mocked, none of the files are # which means we can send them all and let the CORE function handle it if ( !$mock ) { _real_file_access_hook( 'chown', \@_ ); goto \&CORE::chown if _goto_is_available(); return CORE::chown(@files); } # Even if you're root, nonexistent file is nonexistent if ( !$mock->exists() ) { # Only set the error once $set_error or $! = ENOENT; next; } # root can do anything, but you can't # and if we are here, no point in keep trying if ( !$is_root ) { if ( $> != $uid || !$is_in_group ) { $set_error or $! = EPERM; last; } } $mock->{'uid'} = $uid; $mock->{'gid'} = $gid; $num_changed++; } return $num_changed; } sub __chmod (@) { my ( $mode, @files ) = @_; # Not an error, report we changed zero files @files or return 0; # Grab numbers - nothing means "0" (which is the behavior of CORE::chmod) # (This will issue a warning, that's also the expected behavior) { no warnings; $mode =~ /^[0-9]+/xms or warn "Argument \"$mode\" isn't numeric in chmod"; $mode = int $mode; } my %mocked_files = map +( $_ => _get_file_object($_) ), @files; my @unmocked_files = grep !$mocked_files{$_}, @files; my @mocked_files = map ref $_ ? $_->{'path'} : (), values %mocked_files; # The idea is that if some are mocked and some are not, # it's probably a mistake if ( @mocked_files && @mocked_files != @files ) { confess( sprintf 'You called chmod() on a mix of mocked (%s) and unmocked files (%s) ' . ' - this is very likely a bug on your side', ( join ', ', @mocked_files ), ( join ', ', @unmocked_files ), ); } my $num_changed = 0; foreach my $file (@files) { my $mock = $mocked_files{$file}; if ( !$mock ) { _real_file_access_hook( 'chmod', \@_ ); goto \&CORE::chmod if _goto_is_available(); return CORE::chmod(@files); } # chmod is less specific in such errors # chmod $mode, '/foo/' still yields ENOENT if ( !$mock->exists() ) { $! = ENOENT; next; } $mock->{'mode'} = ( $mock->{'mode'} & S_IFMT ) + $mode; $num_changed++; } return $num_changed; } BEGIN { *CORE::GLOBAL::glob = !$^V || $^V lt 5.18.0 ? sub { pop; goto &__glob; } : sub (_;) { goto &__glob; }; *CORE::GLOBAL::open = \&__open; *CORE::GLOBAL::sysopen = \&__sysopen; *CORE::GLOBAL::opendir = \&__opendir; *CORE::GLOBAL::readdir = \&__readdir; *CORE::GLOBAL::telldir = \&__telldir; *CORE::GLOBAL::rewinddir = \&__rewinddir; *CORE::GLOBAL::seekdir = \&__seekdir; *CORE::GLOBAL::closedir = \&__closedir; *CORE::GLOBAL::unlink = \&__unlink; *CORE::GLOBAL::readlink = \&__readlink; *CORE::GLOBAL::mkdir = \&__mkdir; *CORE::GLOBAL::rmdir = \&__rmdir; *CORE::GLOBAL::chown = \&__chown; *CORE::GLOBAL::chmod = \&__chmod; } =head1 CAEATS AND LIMITATIONS =head2 DEBUGGER UNDER STRICT MODE If you want to use the Perl debugger (L) on any code that uses L in strict mode, you will need to load L beforehand, because it loads a file. Under the debugger, the debugger will load the module after L and get mad. # Load it from the command line perl -MTerm::ReadLine -d code.pl # Or alternatively, add this to the top of your code: use Term::ReadLine =head2 FILENO IS UNSUPPORTED Filehandles can provide the file descriptor (in number) using the C keyword but this is purposefully unsupported in L. The reaosn is that by mocking a file, we're creating an alternative file system. Returning a C (file descriptor number) would require creating file descriptor numbers that would possibly conflict with the file desciptors you receive from the real filesystem. In short, this is a recipe for buggy tests or worse - truly destructive behavior. If you have a need for a real file, we suggest L. =head2 BAREWORD FILEHANDLE FAILURES There is a particular type of bareword filehandle failures that cannot be fixed. These errors occur because there's compile-time code that uses bareword filehandles in a function call that cannot be expressed by this module's prototypes for core functions. The only solution to these is loading `Test::MockFile` after the other code: This will fail: # This will fail because Test2::V0 will eventually load Term::Table::Util # which calls open() with a bareword filehandle that is misparsed by this module's # opendir prototypes use Test::MockFile (); use Test2::V0; This will succeed: # This will succeed because open() will be parsed by perl # and only then we override those functions use Test2::V0; use Test::MockFile (); (Using strict-mode will not fix it, even though you should use it.) =head1 AUTHOR Todd Rinaldo, C<< >> =head1 BUGS Please report any bugs or feature requests to L. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Test::MockFile You can also look for information at: =over 4 =item * CPAN Ratings L =item * Search CPAN L =back =head1 ACKNOWLEDGEMENTS Thanks to Nicolas R., C<< >> for help with L. This module could not have been completed without it. =head1 LICENSE AND COPYRIGHT Copyright 2018 cPanel L.L.C. All rights reserved. L This is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =cut 1; # End of Test::MockFile Test-MockFile-0.037/MANIFEST0000644000000000000000000000213015011451314013747 0ustar rootrootChanges eg/examples.pl lib/Test/MockFile.pm lib/Test/MockFile/DirHandle.pm lib/Test/MockFile/FileHandle.pm lib/Test/MockFile/Plugin.pm lib/Test/MockFile/Plugin/FileTemp.pm lib/Test/MockFile/Plugins.pm Makefile.PL MANIFEST This list of files README t/00-load.t t/chmod-filetemp.t t/chmod.t t/chown-chmod-nostrict.t t/chown.t t/detect-common-mistakes.t t/dir_interface.t t/file_access_hooks.t t/file_from_disk.t t/fileno.t t/globbing.t t/goto_is_available.t t/handle-corruption.t t/import.t t/lib/Test/TMF.pm t/manifest.t t/mkdir.t t/mock_stat.t t/new_dir_interface.t t/open-noclose.t t/open.t t/open_strict.t t/opendir.t t/path.t t/plugin-filetemp.t t/plugin.t t/pod-coverage.t t/pod.t t/readline.t t/readlink.t t/rmdir.t t/runtime-bareword-filehandles.t t/stat-x.t t/strict-rules.t t/strict-rules_file-temp-example.t t/strict-rules_scalar.t t/symlink.t t/sysopen.t t/sysopen_strict.t t/Test-MockFile_file.t t/touch.t t/unlink.t t/writeline.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Test-MockFile-0.037/Changes0000644000000000000000000002053315011451137014123 0ustar rootrootRevision history for Test-MockFile 0.037 4/15/2025 - Fix unit test broken in perl 5.41.4 0.036 7/26/2023 - GH #181 - Detect incorrect usage of add_strict_rule_for_command 0.035 11/30/2022 - GH #180 - Prevent open() and sysopen() from opening GLOB(..)-like paths. 0.034 4/25/2022 - GH #176: Add file handle support for BINMODE. This does nothing at this time but at least it doesn't die. - support for ~/foo and ~user/foo in mocking and access (globs) 0.033 3/7/2022 - Request last Overload::FileCheck release - 0.013 - Correct chown parameter position for file name - Fixup Plugin for File::Temp tempfile in scalar context logic. - Track File::Temp version in unit tests. 0.032 2/24/2022 - Less strict mode - Don't complain about commands not opening or directly interacting with a file. 0.031 2/24/2022 - Fix for Plugin::FileTemp when calling tempfile in scalar context 0.030 2/22/2022 - Simplify _strict_mode_violation - Introduce new_dir() to allow older dir() syntax. - Provide a mechanism to setup custom strict rules - Make is_strict_mode a helper - Do not call _get_file_object when all we're trying to determine is if the file is mocked or not. - Add Test::MockFile::Plugins - We support "undef" as filename in strict rules to ignore filenames - Block Plugin::FileTemp < 5.28 - Update MANIFEST 0.029 2/16/2022 - Fix broken link to small test documentation - Ensure strict mode is enabled by default and prevent import conflicts. - Fix warnings during global destruction - Additional rules for _abs_path_to_file - GH #103 - Update eg/example.pl: - Add rmdir, mkdir and unlink default position - Postpone file arg check during strict mode analysis - Fixup hook args and teach for mkdir filename pos - Perltidy policy changes. - Use carp in filename and readlink - Fix broken link to small test documentation 0.028 2/12/2022 - Update test for our FreeBSD results - GH #122 - Support two-arg open, read/write, and understand pipes - Add strict guards for additional keywords: readdir, telldir, rewinddir, seekdir, closedir, readlink, mkdir, rmdir - Revert to old symbol resolution technique. 0.027 2/10/2022 - GH #75 - Strict mode is now on by default - GH #45 - Provide a helpful error message and document fileno unsupported. - GH #90 - Normalize forward slashes. - GH #126 - Document using debugger under strict mode. - Do not hard-code values of $! - Try to get more data when t/runtime-bareword-filehandles.t fails on cpan testers. - GH #64 - Do not overwrite the error code when checking for Docker - GH #63 - FreeBSD's readlink() returns EINVAL for readlink(undef): - Add more data for debugging test failures on OpenBSD 0.026 2/3/2022 - Fix support for mocking the top-level directory. - Symlinks should appear in readdir - Fix directory instantiation when creating a symlink. - GH #105: Show directories in readdir - Improve relative path management - Don't let stat() get confused with trailing forward slash - GH #118: Do not get confused by inner directory files. - GH #85: Do not corrupt blessed handles. 0.025 1/26/2022 - Fix typo in chmod mock. Was accidentally calling chown. - Fix dependency on Text::Glob. It is now a runtime requirement. 0.024 1/24/2022 - Prefer Carp::confess to die - Do not use "$!" in tests as it's not consistent across platforms - GH #78: Do not allow rmdir on a populated directory. - GH #73: Prefer the term ->path to ->filename as it is more clear between file/dir - chown $fh now works. - Only warn about mixed files when using mocked files 0.024_01 - GH #83: Get Solaris testers passing. - Remove all use of "$!" in tests as this has tranlation problems. 0.023 1/14/2022 - GH #58: Fix synopsis typos - GH #65: Fix typos in the typo fixes. - GH #34: Support open() with barewords - GH #59: Detect and reject common path mistakes when mocking - GH #69: Redesigned dir() (and some file()) interface <--- breaks previous interface - GH #40: Support glob() - GH #15: Implement chown/chmod 0.022 12/27/2021 - GH #47: Manage bareword filehandles in runtime: 0.021 1/30/2020 - Emit ENOTDIR on opendir when appropriate - Switch to github actions for CI testing 0.020 10/14/2019 - GH #51 - Basic introduction of file ownership. Set default uid/gid to current user when not set - GH #49 - Make sysseek return position when called while allowing seek to return a true value. 0.19 5/21/2019 - Fix POD for stat example in POD. - Allow scalar file handles on open. We don't care about those - Provide better guidance about keeping your mocks in scope in examples - Disable Test::CheckManifest due to break in Test-CheckManifest - Fix seek bug in sysopen(... O_APPEND) 0.018 1/24/2019 - Properly handle open and sysopen file handles going out of scope. - Provide a helper method to mock objects to determine the file name. GH #31 - Do not throw a file access hook when statting a file handle that is not under MockFile control. GH #30 - Read multiple lines via readline when wantarray is true. GH #29 0.017 1/2/2019 - Require a newer Test2::Bundle::Extended (0.000084) to support named isa_ok 0.016 1/2/2019 - Bump Overload::FileCheck to 0.007 to address stack bug - Try to get EISDIR handling for BSD working. Apparently something changed in perl 5.20? - Do not do access hooks on filehandle interactions. 0.015 12/21/2018 - Remove errant debug messages from open - Pass 3 to fix t/touch.t on BSD. 0.014 12/20/2018 - Re-factor _find_file_or_fh to handle symlink following logic better. GH #26 - Make more standard use of _get_file_object when looking up a file path so we properly handle abs path and symlink following 0.013 12/20/2018 - Add a helper to determine if goto can be used. Where it's available is complicated - First pass at bareword file handles for opendir and friends - Fix errant docs for making a symlink mock - Follow links for stat but not lstat - Add support for readlink - Try 2 to fix BSD issues with GH #20 0.012 11/16/2018 - Fix for #21 - length undef on perl 5.10 - GH #20 - Add EPERM support for freebsd when unlinking directories - Fix for print $fh undef throwing a warning - Remove faulty OS level test of readdir after opendir. 0.011 11/08/2018 - Fix for my $file_contents = do { local $/; <$fh> }; - Mock CORE::GLOBAL::unlink and support directories for unlink - Mock CORE::GLOBAL::mkdir - Mock CORE::GLOBAL::rmdir - MockFile->symlink now follows the symlink norm of ($target, $file), not the reverse. - New mock helper 'exists' to check if the file is there. - New mock helper 'permissions' tells you the current permissions of the mocked file. 0.010 10/31/2018 - Add .perltidyrc policy - When reporting strict mode violations, be sure to report the a stack location outside of our modules. - Report a stack trace for strict mode violations to determine the source of the problem. - Add an ignore hash for modules (like DynaLoader) which are allowed to open files. - Ignore STDIN/STDERR/STDOUT since tests often have to manipulate them and that's not really IO. - Autovivify a sysread where the buffer passed in is undef. 0.009 10/29/2018 - Add unlink and touch as helpers when testing - Depend on new Overload::FileCheck 0.006 which does not call MockFile to determine _ stats 0.008 10/26/2018 - Depend on newest Overload::FileCheck version. Depending on older versions was breaking unit tests. 0.007 10/25/2018 - More POD fixups - Support for unmocked file access hooks. - Implement strict mode to error any time an unmocked file access happens. 0.006 10/25/2018 - Fix for Locale-dependent failures on perl < 5.22 https://github.com/CpanelInc/Test-MockFile/issues/10 - Minor pod fixups. 0.005 10/24/2018 - Complete basic documentation for all public methods. 0.004 10/24/2018 - Raise the Test::More requirement to address an issue with Test2::Formatter::TAP Fixes https://github.com/CpanelInc/Test-MockFile/issues/6 0.003 10/24/2018 - Correct bug in use constant statement. 0.002 was broken on release. - Changes to code to give basic support for Perl 5.10+. Ideally you should be on perl 5.16 to run this code but it'll mostly work below that. 0.002 10/24/2018 - Set bug tracker to github - Fix Fcntl bug when you use unsupported constants. 0.001 10/23/2018 - First release with basic support for open/sysopen/opendir - Support is limited to Perl 5.20 until we address this error: Error: Invalid CODE attribute: prototype(*;$@) at lib/Test/MockFile.pm Test-MockFile-0.037/eg/0000755000000000000000000000000015011451313013214 5ustar rootrootTest-MockFile-0.037/eg/examples.pl0000644000000000000000000000313514206030441015371 0ustar rootroot#!perl use strict; use warnings; use feature qw< say >; use lib 'lib'; # This is straight from the SYNOPSIS # strict mode by default use Test::MockFile (); # non-strict mode # use Test::MockFile qw< nostrict >; # Be sure to assign the output of mocks, they disappear when they go out of scope my $foobar = Test::MockFile->file( "/foo/bar", "contents\ngo\nhere" ); open my $fh, '<', '/foo/bar' or die; # Does not actually open the file on disk say '/foo/bar exists' if -e $fh; close $fh; say '/foo/bar is a file' if -f '/foo/bar'; say '/foo/bar is THIS BIG: ' . -s '/foo/bar'; my $foobaz = Test::MockFile->file('/foo/baz'); # File starts out missing my $opened = open my $baz_fh, '<', '/foo/baz'; # File reports as missing so fails say '/foo/baz does not exist yet' if !-e '/foo/baz'; open $baz_fh, '>', '/foo/baz' or die; # open for writing print {$baz_fh} "first line\n"; open $baz_fh, '>>', '/foo/baz' or die; # open for append. print {$baz_fh} "second line"; close $baz_fh; say "Contents of /foo/baz:\n>>" . $foobaz->contents() . '<<'; # Unmock your file. # (same as the variable going out of scope undef $foobaz; # The file check will now happen on file system now the file is no longer mocked. say '/foo/baz is missing again (no longer mocked)' if !-e '/foo/baz'; my $quux = Test::MockFile->file( '/foo/bar/quux.txt', '' ); my @matches = ; # ( '/foo/bar/quux.txt' ) say "Contents of /foo/bar directory: " . join "\n", @matches; @matches = glob('/foo/bar/*.txt'); # same as above say "Contents of /foo/bar directory (using glob()): " . join "\n", @matches; Test-MockFile-0.037/README0000644000000000000000000004044714206030441013512 0ustar rootrootNAME Test::MockFile - Allows tests to validate code that can interact with files without touching the file system. VERSION Version 0.029 SYNOPSIS Intercepts file system calls for specific files so unit testing can take place without any files being altered on disk. This is useful for small tests where file interaction is discouraged. A strict mode is even provided (and turned on by default) which can throw a die when files are accessed during your tests! # Loaded before Test::MockFile so uses the core perl functions without any hooks. use Module::I::Dont::Want::To::Alter; # strict mode by default use Test::MockFile (); # non-strict mode use Test::MockFile qw< nostrict >; # Be sure to assign the output of mocks, they disappear when they go out of scope my $foobar = Test::MockFile->file( "/foo/bar", "contents\ngo\nhere" ); open my $fh, '<', '/foo/bar' or die; # Does not actually open the file on disk say '/foo/bar exists' if -e $fh; close $fh; say '/foo/bar is a file' if -f '/foo/bar'; say '/foo/bar is THIS BIG: ' . -s '/foo/bar'; my $foobaz = Test::MockFile->file('/foo/baz'); # File starts out missing my $opened = open my $baz_fh, '<', '/foo/baz'; # File reports as missing so fails say '/foo/baz does not exist yet' if !-e '/foo/baz'; open $baz_fh, '>', '/foo/baz' or die; # open for writing print {$baz_fh} "first line\n"; open $baz_fh, '>>', '/foo/baz' or die; # open for append. print {$baz_fh} "second line"; close $baz_fh; say "Contents of /foo/baz:\n>>" . $foobaz->contents() . '<<'; # Unmock your file. # (same as the variable going out of scope undef $foobaz; # The file check will now happen on file system now the file is no longer mocked. say '/foo/baz is missing again (no longer mocked)' if !-e '/foo/baz'; my $quux = Test::MockFile->file( '/foo/bar/quux.txt', '' ); my @matches = ; # ( '/foo/bar/quux.txt' ) say "Contents of /foo/bar directory: " . join "\n", @matches; @matches = glob('/foo/bar/*.txt'); # same as above say "Contents of /foo/bar directory (using glob()): " . join "\n", @matches; IMPORT When the module is loaded with no parameters, strict mode is turned on. Any file checks, "open", "sysopen", "opendir", "stat", or "lstat" will throw a die. For example: use Test::MockFile; # This will not die. my $file = Test::MockFile->file("/bar", "..."); my $symlink = Test::MockFile->symlink("/foo", "/bar"); -l '/foo' or print "ok\n"; open my $fh, '>', '/foo'; # All of these will die open my $fh, '>', '/unmocked/file'; # Dies sysopen my $fh, '/other/file', O_RDONLY; opendir my $fh, '/dir'; -e '/file'; -l '/file'; If we want to load the module without strict mode: use Test::MockFile qw< nostrict >; Relative paths are not supported: use Test::MockFile; # Checking relative vs absolute paths $file = Test::MockFile->file( '/foo/../bar', '...' ); # not ok - relative path $file = Test::MockFile->file( '/bar', '...' ); # ok - absolute path $file = Test::MockFile->file( 'bar', '...' ); # ok - current dir file_arg_position_for_command Args: ($command) Provides a hint with the position of the argument most likely holding the file name for the current $command call. This is used internaly to provide better error messages. This can be used when plugging hooks to know what's the filename we currently try to access. SUBROUTINES/METHODS file Args: ($file, $contents, $stats) This will make cause $file to be mocked in all file checks, opens, etc. "undef" contents means that the file should act like it's not there. You can only set the stats if you provide content. If you give file content, the directory inside it will be mocked as well. my $f = Test::MockFile->file( '/foo/bar' ); -d '/foo' # not ok my $f = Test::MockFile->file( '/foo/bar', 'some content' ); -d '/foo' # ok See "Mock Stats" for what goes into the stats hashref. file_from_disk Args: "($file_to_mock, $file_on_disk, $stats)" This will make cause $file to be mocked in all file checks, opens, etc. If "file_on_disk" isn't present, then this will die. See "Mock Stats" for what goes into the stats hashref. symlink Args: ($readlink, $file ) This will cause $file to be mocked in all file checks, opens, etc. $readlink indicates what "fake" file it points to. If the file $readlink points to is not mocked, it will act like a broken link, regardless of what's on disk. If $readlink is undef, then the symlink is mocked but not present.(lstat $file is empty.) Stats are not able to be specified on instantiation but can in theory be altered after the object is created. People don't normally mess with the permissions on a symlink. dir Args: ($dir) This will cause $dir to be mocked in all file checks, and "opendir" interactions. The directory name is normalized so any trailing slash is removed. $dir = Test::MockFile->dir( 'mydir/', ... ); # ok $dir->path(); # mydir If there were previously mocked files (within the same scope), the directory will exist. Otherwise, the directory will be nonexistent. my $dir = Test::MockFile->dir('/etc'); -d $dir; # not ok since directory wasn't created yet $dir->contents(); # undef # Now we can create an empty directory mkdir '/etc'; $dir_etc->contents(); # . .. # Alternatively, we can already create files with ->file() $dir_log = Test::MockFile->dir('/var'); $file_log = Test::MockFile->file( '/var/log/access_log', $some_content ); $dir_log->contents(); # . .. access_log # If you create a nonexistent file but then give it content, it will create # the directory for you my $file = Test::MockFile->file('/foo/bar'); my $dir = Test::MockFile->dir('/foo'); -d '/foo' # false -e '/foo/bar'; # false $dir->contents(); # undef $file->contents('hello'); -e '/foo/bar'; # true -d '/foo'; # true $dir->contents(); # . .. bar NOTE: Because "." and ".." will always be the first things "readdir" returns, These files are automatically inserted at the front of the array. The order of files is sorted. If you want to affect the stat information of a directory, you need to use the available core Perl keywords. (We might introduce a special helper method for it in the future.) $d = Test::MockFile->dir( '/foo', [], { 'mode' => 0755 } ); # dies $d = Test::MockFile->dir( '/foo', undef, { 'mode' => 0755 } ); # dies $d = Test::MockFile->dir('/foo'); mkdir $d, 0755; # ok Mock Stats When creating mocked files or directories, we default their stats to: my $attrs = Test::MockFile->file( $file, $contents, { 'dev' => 0, # stat[0] 'inode' => 0, # stat[1] 'mode' => $mode, # stat[2] 'nlink' => 0, # stat[3] 'uid' => int $>, # stat[4] 'gid' => int $), # stat[5] 'rdev' => 0, # stat[6] 'atime' => $now, # stat[8] 'mtime' => $now, # stat[9] 'ctime' => $now, # stat[10] 'blksize' => 4096, # stat[11] 'fileno' => undef, # fileno() } ); You'll notice that mode, size, and blocks have been left out of this. Mode is set to 666 (for files) or 777 (for directories), xored against the current umask. Size and blocks are calculated based on the size of 'contents' a.k.a. the fake file. When you want to override one of the defaults, all you need to do is specify that when you declare the file or directory. The rest will continue to default. my $mfile = Test::MockFile->file("/root/abc", "...", {inode => 65, uid => 123, mtime => int((2000-1970) * 365.25 * 24 * 60 * 60 })); my $mdir = Test::MockFile->dir("/sbin", "...", { mode => 0700 })); new This class method is called by file/symlink/dir. There is no good reason to call this directly. contents Optional Arg: $contents Retrieves or updates the current contents of the file. Only retrieves the content of the directory (as an arrayref). You can set directory contents with calling the "file()" method described above. Symlinks have no contents. filename Deprecated. Same as "path". path The path (filename or dirname) of the file or directory this mock object is controlling. unlink Makes the virtual file go away. NOTE: This also works for directories. touch Optional Args: ($epoch_time) This function acts like the UNIX utility touch. It sets atime, mtime, ctime to $epoch_time. If no arguments are passed, $epoch_time is set to time(). If the file does not exist, contents are set to an empty string. stat Returns the stat of a mocked file (does not follow symlinks.) readlink Optional Arg: $readlink Returns the stat of a mocked file (does not follow symlinks.) You can also use this to change what your symlink is pointing to. is_link returns true/false, depending on whether this object is a symlink. is_dir returns true/false, depending on whether this object is a directory. is_file returns true/false, depending on whether this object is a regular file. size returns the size of the file based on its contents. exists returns true or false based on if the file exists right now. blocks Calculates the block count of the file based on its size. chmod Optional Arg: $perms Allows you to alter the permissions of a file. This only allows you to change the 07777 bits of the file permissions. The number passed should be the octal 0755 form, not the alphabetic "755" form permissions Returns the permissions of the file. mtime Optional Arg: $new_epoch_time Returns and optionally sets the mtime of the file if passed as an integer. ctime Optional Arg: $new_epoch_time Returns and optionally sets the ctime of the file if passed as an integer. atime Optional Arg: $new_epoch_time Returns and optionally sets the atime of the file if passed as an integer. add_file_access_hook Args: ( $code_ref ) You can use add_file_access_hook to add a code ref that gets called every time a real file (not mocked) operation happens. We use this for strict mode to die if we detect your program is unexpectedly accessing files. You are welcome to use it for whatever you like. Whenever the code ref is called, we pass 2 arguments: "$code->($access_type, $at_under_ref)". Be aware that altering the variables in $at_under_ref will affect the variables passed to open / sysopen, etc. One use might be: Test::MockFile::add_file_access_hook(sub { my $type = shift; print "$type called at: " . Carp::longmess() } ); clear_file_access_hooks Calling this subroutine will clear everything that was passed to add_file_access_hook How this mocking is done: Test::MockFile uses 2 methods to mock file access: -X via Overload::FileCheck It is currently not possible in pure perl to override stat , lstat and -X operators . In conjunction with this module, we've developed Overload::FileCheck. This enables us to intercept calls to stat, lstat and -X operators (like -e, -f, -d, -s, etc.) and pass them to our control. If the file is currently being mocked, we return the stat (or lstat) information on the file to be used to determine the answer to whatever check was made. This even works for things like "-e _". If we do not control the file in question, we return "FALLBACK_TO_REAL_OP()" which then makes a normal check. CORE::GLOBAL:: overrides Since 5.10, it has been possible to override function calls by defining them. like: *CORE::GLOBAL::open = sub(*;$@) {...} Any code which is loaded AFTER this happens will use the alternate open. This means you can place your "use Test::MockFile" statement after statements you don't want to be mocked and there is no risk that the code will ever be altered by Test::MockFile. We oveload the following statements and then return tied handles to enable the rest of the IO functions to work properly. Only open / sysopen are needed to address file operations. However opendir file handles were never setup for tie so we have to override all of opendir's related functions. * open * sysopen * opendir * readdir * telldir * seekdir * rewinddir * closedir CAEATS AND LIMITATIONS DEBUGGER UNDER STRICT MODE If you want to use the Perl debugger (perldebug) on any code that uses Test::MockFile in strict mode, you will need to load Term::ReadLine beforehand, because it loads a file. Under the debugger, the debugger will load the module after Test::MockFile and get mad. # Load it from the command line perl -MTerm::ReadLine -d code.pl # Or alternatively, add this to the top of your code: use Term::ReadLine FILENO IS UNSUPPORTED Filehandles can provide the file descriptor (in number) using the "fileno" keyword but this is purposefully unsupported in Test::MockFile. The reaosn is that by mocking a file, we're creating an alternative file system. Returning a "fileno" (file descriptor number) would require creating file descriptor numbers that would possibly conflict with the file desciptors you receive from the real filesystem. In short, this is a recipe for buggy tests or worse - truly destructive behavior. If you have a need for a real file, we suggest File::Temp. BAREWORD FILEHANDLE FAILURES There is a particular type of bareword filehandle failures that cannot be fixed. These errors occur because there's compile-time code that uses bareword filehandles in a function call that cannot be expressed by this module's prototypes for core functions. The only solution to these is loading `Test::MockFile` after the other code: This will fail: # This will fail because Test2::V0 will eventually load Term::Table::Util # which calls open() with a bareword filehandle that is misparsed by this module's # opendir prototypes use Test::MockFile (); use Test2::V0; This will succeed: # This will succeed because open() will be parsed by perl # and only then we override those functions use Test2::V0; use Test::MockFile (); (Using strict-mode will not fix it, even though you should use it.) AUTHOR Todd Rinaldo, "" BUGS Please report any bugs or feature requests to . SUPPORT You can find documentation for this module with the perldoc command. perldoc Test::MockFile You can also look for information at: * CPAN Ratings * Search CPAN ACKNOWLEDGEMENTS Thanks to Nicolas R., "" for help with Overload::FileCheck. This module could not have been completed without it. LICENSE AND COPYRIGHT Copyright 2018 cPanel L.L.C. All rights reserved. This is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See perlartistic. Test-MockFile-0.037/Makefile.PL0000644000000000000000000000267414211507432014611 0ustar rootrootuse 5.010; use strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'Test::MockFile', AUTHOR => q{Todd Rinaldo }, VERSION_FROM => 'lib/Test/MockFile.pm', ABSTRACT_FROM => 'lib/Test/MockFile.pm', LICENSE => 'artistic_2', PL_FILES => {}, MIN_PERL_VERSION => '5.006', CONFIGURE_REQUIRES => { 'ExtUtils::MakeMaker' => '0', }, BUILD_REQUIRES => { 'Test::More' => '1.302133', 'Test2::Bundle::Extended' => '0.000084', # Oldest version provided on CPAN isa_ok changed in 0.000035 and we need that. 'Test2::Tools::Explain' => '0', 'Test2::Plugin::NoWarnings' => '0', 'File::Slurper' => 0, 'File::Temp' => 0, 'File::Basename' => 0, 'Test2::Harness::Util::IPC' => 0, 'Test::MockModule' => 0, }, PREREQ_PM => { 'Overload::FileCheck' => '0.013', 'Text::Glob' => 0, }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'Test-MockFile-*' }, META_MERGE => { resources => { license => 'http://dev.perl.org/licenses/', bugtracker => 'https://github.com/cpanelinc/Test-MockFile/issues', repository => 'https://github.com/cpanelinc/Test-MockFile', } }, ); Test-MockFile-0.037/META.yml0000644000000000000000000000204715011451313014075 0ustar rootroot--- abstract: 'Allows tests to validate code that can interact with files without touching the file system.' author: - 'Todd Rinaldo ' build_requires: File::Basename: '0' File::Slurper: '0' File::Temp: '0' Test2::Bundle::Extended: '0.000084' Test2::Harness::Util::IPC: '0' Test2::Plugin::NoWarnings: '0' Test2::Tools::Explain: '0' Test::MockModule: '0' Test::More: '1.302133' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.64, CPAN::Meta::Converter version 2.150010' license: artistic_2 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Test-MockFile no_index: directory: - t - inc requires: Overload::FileCheck: '0.013' Text::Glob: '0' perl: '5.006' resources: bugtracker: https://github.com/cpanelinc/Test-MockFile/issues license: http://dev.perl.org/licenses/ repository: https://github.com/cpanelinc/Test-MockFile version: '0.037' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Test-MockFile-0.037/META.json0000644000000000000000000000323315011451313014243 0ustar rootroot{ "abstract" : "Allows tests to validate code that can interact with files without touching the file system.", "author" : [ "Todd Rinaldo " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.64, CPAN::Meta::Converter version 2.150010", "license" : [ "artistic_2" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Test-MockFile", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "File::Basename" : "0", "File::Slurper" : "0", "File::Temp" : "0", "Test2::Bundle::Extended" : "0.000084", "Test2::Harness::Util::IPC" : "0", "Test2::Plugin::NoWarnings" : "0", "Test2::Tools::Explain" : "0", "Test::MockModule" : "0", "Test::More" : "1.302133" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Overload::FileCheck" : "0.013", "Text::Glob" : "0", "perl" : "5.006" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/cpanelinc/Test-MockFile/issues" }, "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "https://github.com/cpanelinc/Test-MockFile" } }, "version" : "0.037", "x_serialization_backend" : "JSON::PP version 4.07" }