Test-MockFile-0.039/000755 000765 000024 00000000000 15160070576 015666 5ustar00todd.rinaldostaff000000 000000 Test-MockFile-0.039/Changes000644 000765 000024 00000034712 15160070426 017162 0ustar00todd.rinaldostaff000000 000000 Revision history for Test-MockFile 0.039 3/22/2026 [Bug Fixes] - GH #292 - Return EPERM for unlink on directory on Solaris, matching macOS/BSD behavior. PR #307 - GH #292 - Add 'no strict refs' to all dir operation CORE:: fallbacks to fix bareword filehandle failures on Perl < 5.016. PR #307 - GH #298 - Don't apply umask to explicitly provided mode in file() and new_dir() constructors. Fixes CPAN smoker failures with restrictive umasks. PR #299 - GH #297 - Skip real-file flock test when filesystem lacks flock support (e.g. NFS on FreeBSD). PR #300 - Propagate nlink to all same-inode mocks in link() so 3+ hard links get consistent nlink values. PR #290 - Fix chown permission check for uid-only and gid-only changes that previously skipped validation entirely. PR #290 [Maintenance] - Modernize CI workflow with dynamic Perl versions, disttest job, and macOS cross-platform coverage. PR #306 - Bump minimum Perl version to 5.16 and remove dead pre-5.16 code paths. PR #305 0.038 3/20/2026 [Improvements] - GH #70 - Auto-update stat timestamps (atime/mtime/ctime) during file operations. PR #288 - GH #186 - Auto-update parent directory mtime on content changes. PR #288 - GH #3 - Add permission checking via set_user/clear_user. PR #281 - GH #44 - Add autodie compatibility with proper exception throwing. - GH #16 - Add symlink() and link() overrides for mocked files. - GH #24 - Add warnstrict mode for non-fatal strict violations. - GH #39 - Override IO::File::open for mocked file compatibility. - GH #135 - Add autovivify option for directory mocks. - GH #139 - Override Cwd::abs_path to resolve mocked symlinks. - GH #112 - Add flock() override for mocked files. - GH #221 - Add truncate() override for mocked files. - GH #111 - Add read(), write(), and append() helper methods. - GH #27 - Support multiple file handles to the same mocked file. - GH #158 - glob() now falls back to real filesystem for unmocked paths. - GH #108 - Resolve . and .. in middle of paths. - Add utime() override for mocked files. - Add rename() override for mocked files. - Implement SEEK whence support (SEEK_SET, SEEK_CUR, SEEK_END). - Rewrite READLINE to support all $/ modes and implement GETC. - Add :trace import tag for logging unmocked file accesses. - Add file_passthrough() for strict-mode-compatible real filesystem access with glob pattern support. PR #280 [Bug Fixes] - GH #175 - Accept both EINVAL and ENOENT for readlink(undef). - GH #179 - Fix filehandle reference leak. PR #276 - PRINT/PRINTF return false when weakened data ref is gone. PR #283 - Decrement nlink on unlink and preserve inode/nlink on rename. PR #276 - Set realistic nlink and unique inode defaults for mocked files. - chmod/chown/utime/truncate now follow symlinks per POSIX. PR #287 - Use & ~umask instead of ^ umask for permission masking (multiple locations). - chown -1 now preserves per-file uid/gid instead of replacing with process identity. - Mask chmod mode with S_IFPERMS to prevent file type corruption. - Use proper S_IFMT mask in is_link() to avoid false positives. - Broken symlink stat sets ENOENT, not ELOOP. - Use Errno constants instead of hardcoded errno values. - PRINT writes at tell position instead of always appending. - PRINT returns boolean 1, not byte count. - Handle output record separator ($\) in PRINT for say() support. - Update tell position after PRINT/WRITE/PRINTF operations. - syswrite/printf must not inherit $\ from PRINT delegation. - 2-arg open no longer dies on filenames with special characters. - 2-arg open +>> mode parsing and opendir symlink following. - readdir returns empty list (not undef) at EOF in list context. - FileHandle CLOSE/DESTROY crash, WRITE negative offset, READ EBADF. - Guard weakened data ref in tied filehandle methods. - readline and getc on write-only handles now warn and return undef. - READ returns EBADF on write-only handles, symlink size() returns target length. - sysopen without O_CREAT returns ENOENT for all modes. - Allow seek past EOF and correct eof() behavior. - seekdir with negative position no longer corrupts readdir. - closedir double-close returns EBADF instead of passing to CORE. - Dir ops on closed mock dirhandle warn instead of dying. - Rename directory now re-keys children in mock registry. - Rename directory over non-empty directory returns ENOTEMPTY. - Rename to self no longer destroys file contents. - Directory size() returns blksize instead of stringified arrayref. - dir() constructor counts non-existent child mocks as content. - rmdir ignores non-existent mock entries in directory. - Set errno in __rmdir for undef path argument. - unlink with no args now uses $_ for mocked files. - Absolutify paths in _files_in_dir and _update_parent_dir_times. - readlink returns ENOENT for non-existent mocks. - lstat on unlinked symlink now returns ENOENT instead of stale stat. - IO::File open on directory mocks returns EISDIR, append mode preserved. - open/sysopen through broken symlink creates target file. - Validate sysread length and return EINVAL on invalid seek whence. - Correct blocks() calculation and remove dead code. - Define S_IFPERMS locally instead of importing from Fcntl. - Capture -s result before passing to is() for Perl < 5.16 compat. - Apply permissions from sysopen O_CREAT 4th argument. - Correct bareword check typo $_[9] -> $_[0] in dir functions. - Pass missing args in chmod/chown passthrough to CORE. - chown/chmod with broken symlinks no longer confess on multi-file lists. - Use return undef in failure paths for correct list context. - Truncate via read-only filehandle returns EINVAL. - Add EISDIR checks, sysopen symlink following, and O_TRUNC dedup. [Maintenance] - Modernize CI workflow: upgrade checkout action and add Perl 5.40-5.42. - Fix CI workflow permissions for code scanning. PR #284 - Refactor: improve readability and reduce duplication in MockFile.pm. PR #284 - Add syswrite/sysread edge case test coverage. PR #282 - Correct MIN_PERL_VERSION and stale GitHub org URLs. - Fix typos in error message and POD. 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.039/MANIFEST000644 000765 000024 00000003745 15160070576 017030 0ustar00todd.rinaldostaff000000 000000 Changes 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/autodie_all_functions.t t/autodie_compat.t t/autodie_compat_reverse.t t/autodie_eisdir.t t/autodie_filesys.t t/autodie_sysopen.t t/autodie_sysopen_reverse.t t/autovivify.t t/blocks.t t/chmod-chown-passthrough.t t/chmod-filetemp.t t/chmod.t t/chown-chmod-nostrict.t t/chown.t t/creation_timestamps.t t/cwd_abs_path.t t/detect-common-mistakes.t t/dir_interface.t t/dir_mtime.t t/enoent_on_nonexistent.t t/fh-ref-leak.t t/file_access_hooks.t t/file_from_disk.t t/file_passthrough.t t/filehandle_cleanup.t t/filehandle_weakref.t t/fileno.t t/flock.t t/glob_real_files.t t/globbing.t t/goto_is_available.t t/handle-corruption.t t/import.t t/io_file_compat.t t/lib/Test/TMF.pm t/manifest.t t/mkdir.t t/mock_stat.t t/multi_handle.t t/new_dir_interface.t t/open-noclose.t t/open.t t/open_broken_symlink_create.t t/open_dir_symlink.t t/open_edge_cases.t t/open_return_undef.t t/open_strict.t t/open_two_arg_special_chars.t t/opendir.t t/path.t t/perms.t t/plugin-filetemp.t t/plugin.t t/pod-coverage.t t/pod.t t/portability_errno.t t/print_separators.t t/read_write_helpers.t t/read_write_perms.t t/readline.t t/readline_modes.t t/readlink.t t/relative_paths.t t/rename.t t/rmdir.t t/runtime-bareword-filehandles.t t/seek.t t/stat-x.t t/stat_defaults.t t/stat_timestamps.t t/strict-rules.t t/strict-rules_file-temp-example.t t/strict-rules_scalar.t t/symlink.t t/symlink_follow_ops.t t/symlink_link.t t/sysopen.t t/sysopen_strict.t t/sysreadwrite_edge_cases.t t/Test-MockFile_file.t t/touch.t t/trace.t t/truncate.t t/unlink.t t/utime.t t/utime_strict.t t/warnstrict.t t/write_tell.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.039/t/000755 000765 000024 00000000000 15160070576 016131 5ustar00todd.rinaldostaff000000 000000 Test-MockFile-0.039/README000644 000765 000024 00000040444 15157362227 016557 0ustar00todd.rinaldostaff000000 000000 NAME 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.039/META.yml000644 000765 000024 00000002041 15160070576 017134 0ustar00todd.rinaldostaff000000 000000 --- 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.76, 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.014' Text::Glob: '0' perl: '5.016' resources: bugtracker: https://github.com/cpanel/Test-MockFile/issues license: http://dev.perl.org/licenses/ repository: https://github.com/cpanel/Test-MockFile version: '0.039' x_serialization_backend: 'CPAN::Meta::YAML version 0.020' Test-MockFile-0.039/lib/000755 000765 000024 00000000000 15160070576 016434 5ustar00todd.rinaldostaff000000 000000 Test-MockFile-0.039/Makefile.PL000644 000765 000024 00000002666 15160070345 017644 0ustar00todd.rinaldostaff000000 000000 use 5.016; 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.016', 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.014', '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/cpanel/Test-MockFile/issues', repository => 'https://github.com/cpanel/Test-MockFile', } }, ); Test-MockFile-0.039/eg/000755 000765 000024 00000000000 15160070576 016261 5ustar00todd.rinaldostaff000000 000000 Test-MockFile-0.039/META.json000644 000765 000024 00000003225 15160070576 017311 0ustar00todd.rinaldostaff000000 000000 { "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.76, 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.014", "Text::Glob" : "0", "perl" : "5.016" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/cpanel/Test-MockFile/issues" }, "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "https://github.com/cpanel/Test-MockFile" } }, "version" : "0.039", "x_serialization_backend" : "JSON::PP version 4.16" } Test-MockFile-0.039/eg/examples.pl000644 000765 000024 00000003135 15157362227 020441 0ustar00todd.rinaldostaff000000 000000 #!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.039/lib/Test/000755 000765 000024 00000000000 15160070576 017353 5ustar00todd.rinaldostaff000000 000000 Test-MockFile-0.039/lib/Test/MockFile.pm000644 000765 000024 00000405534 15160070473 021411 0ustar00todd.rinaldostaff000000 000000 # 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 5.016; 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 File::Glob (); use Scalar::Util (); use Symbol; use Overload::FileCheck '-from-stat' => \&_mock_stat, q{:check}; use Errno qw/EPERM EACCES ENOENT EBADF ELOOP ENOTEMPTY EEXIST EISDIR ENOTDIR EINVAL EXDEV/; 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.039 =cut our $VERSION = '0.039'; our %files_being_mocked; # Original Cwd functions saved before override my $_original_cwd_abs_path; # Tracks directories with autovivify enabled: path => mock object (weak ref) my %_autovivify_dirs; # Auto-incrementing inode counter for unique inode assignment my $_next_inode = 1; # 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 >; # trace mode - logs unmocked file accesses to STDERR use Test::MockFile qw< :trace >; # warn mode (like strict, but warns instead of dying) use Test::MockFile qw< warnstrict >; # 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; # Create a symlink using the builtin my $target_mock = Test::MockFile->file('/foo/target', "data"); my $link_mock = Test::MockFile->file('/foo/mylink'); # start as non-existent symlink('/foo/target', '/foo/mylink'); # now it's a symlink say 'is a symlink!' if -l '/foo/mylink'; # Create a hard link using the builtin my $orig_mock = Test::MockFile->file('/foo/original', "shared data"); my $hard_mock = Test::MockFile->file('/foo/hardlink'); link('/foo/original', '/foo/hardlink'); say 'hard link exists!' if -f '/foo/hardlink'; =head1 IMPORT When the module is loaded with no parameters, strict mode is turned on. Any file checks, C, C, 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 >; =head3 Trace mode Trace mode logs all unmocked file access operations to STDERR. This is useful during development to discover which files your code touches, so you know what to mock. use Test::MockFile qw< :trace >; Each unmocked file operation produces a line like: [trace] open('/etc/hosts') at t/mytest.t line 42 Trace mode can be combined with nostrict to log all accesses without dying: use Test::MockFile qw< :trace :nostrict >; Tags may also be used without the colon prefix for backwards compatibility: use Test::MockFile qw< trace nostrict >; If we want to be warned about unmocked file access without dying: use Test::MockFile qw< warnstrict >; This is useful when migrating an existing test suite to strict mode. It allows you to discover all unmocked file accesses at once, rather than fixing them one at a time. 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_WARN => 8; 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, 'link' => 0, 'readlink' => 0, 'rename' => 0, 'rmdir' => 0, 'stat' => 0, 'symlink' => 1, 'sysopen' => 1, 'truncate' => 0, 'unlink' => 0, 'utime' => 2, '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 =item C<$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; } =head2 is_warn_mode Boolean helper to determine if warn mode is currently enabled. When warn mode is active, strict mode violations produce warnings instead of fatal errors. =cut sub is_warn_mode { return ( $STRICT_MODE_STATUS & STRICT_MODE_ENABLED && $STRICT_MODE_STATUS & STRICT_MODE_WARN ) ? 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; if ( $file_arg == -1 ) { if ( $STRICT_MODE_STATUS & STRICT_MODE_WARN ) { carp("Unknown strict mode violation for $command"); return; } croak("Unknown strict mode violation for $command"); } my $msg = "Use of $command to access unmocked file or directory '$filename' in strict mode at $stack[1] line $stack[2]"; if ( $STRICT_MODE_STATUS & STRICT_MODE_WARN ) { carp($msg); return; } confess($msg); } 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; # Mock user identity for permission checks (GH #3) # When set, file operations check Unix permissions against this identity. # When undef, no permission checks are performed (backward compatible). my $_mock_uid; my @_mock_gids; =head2 set_user Args: ($uid, @gids) Sets a mock user identity for permission checking. When set, all mocked file operations will check Unix permissions (owner/group/other) against this identity instead of the real process credentials. The first gid in C<@gids> is the primary group. If no gids are provided, the primary group defaults to 0. Test::MockFile->set_user(1000, 1000); # uid=1000, gid=1000 my $f = Test::MockFile->file('/foo', 'bar', { mode => 0600, uid => 0 }); open(my $fh, '<', '/foo') or die; # dies: EACCES (not owner) Test::MockFile->set_user(0, 0); # root can read anything open(my $fh, '<', '/foo') or die; # succeeds =cut sub set_user { my ( $class, $uid, @gids ) = @_; defined $uid or croak("set_user() requires a uid argument"); $_mock_uid = int $uid; @_mock_gids = @gids ? map { int $_ } @gids : (0); return; } =head2 clear_user Clears the mock user identity, disabling permission checks. File operations will succeed regardless of mode bits (the default behavior). Test::MockFile->clear_user(); =cut sub clear_user { $_mock_uid = undef; @_mock_gids = (); return; } # _check_perms($mock, $access) # Checks Unix permission bits on a mock file object. # $access is a bitmask: 4=read, 2=write, 1=execute (same as R_OK/W_OK/X_OK) # Returns 1 if access is allowed, 0 if denied. # When no mock user is set ($_mock_uid is undef), always returns 1. sub _check_perms { my ( $mock, $access ) = @_; return 1 unless defined $_mock_uid; my $mode = $mock->{'mode'} & S_IFPERMS; # Root bypass: root can read/write anything. # For execute, root needs at least one x bit set. if ( $_mock_uid == 0 ) { return ( $access & 1 ) ? ( $mode & 0111 ? 1 : 0 ) : 1; } # Determine which permission triad applies my $bits; if ( $_mock_uid == $mock->{'uid'} ) { $bits = ( $mode >> 6 ) & 07; } elsif ( grep { $_ == $mock->{'gid'} } @_mock_gids ) { $bits = ( $mode >> 3 ) & 07; } else { $bits = $mode & 07; } return ( $bits & $access ) == $access ? 1 : 0; } # _check_parent_perms($path, $access) # Checks permissions on the parent directory of $path. # Used for operations that modify directory contents (unlink, mkdir, rmdir). # Returns 1 if allowed, 0 if denied. sub _check_parent_perms { my ( $path, $access ) = @_; return 1 unless defined $_mock_uid; ( my $parent = $path ) =~ s{ / [^/]+ $ }{}xms; $parent = '/' if $parent eq ''; my $parent_mock = _get_file_object($parent); return 1 unless $parent_mock; # Parent not mocked, skip check return _check_perms( $parent_mock, $access ); } my @_tmf_callers; # Packages where autodie was active when T::MF was imported. # Used as a fallback for Perl versions where caller(N)[10] hints # may not be reliable after goto &sub. my %_autodie_callers; # Declared before import() which references them for :trace support my @_public_access_hooks; my @_internal_access_hooks = ( \&_strict_mode_violation ); my $TRACE_ENABLED; sub import { my ( $class, @args ) = @_; my $strict_mode; if ( grep { $_ eq 'nostrict' || $_ eq ':nostrict' } @args ) { $strict_mode = STRICT_MODE_DISABLED; } elsif ( grep { $_ eq 'warnstrict' || $_ eq ':warnstrict' } @args ) { $strict_mode = STRICT_MODE_ENABLED | STRICT_MODE_WARN; } else { $strict_mode = 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; if ( grep { $_ eq 'trace' || $_ eq ':trace' } @args ) { if ( !$TRACE_ENABLED ) { $TRACE_ENABLED = 1; # Insert before _strict_mode_violation so trace fires even when strict mode will die unshift @_internal_access_hooks, \&_trace_hook; } } 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); } # Install per-package overrides to handle autodie compatibility. # autodie installs per-package wrappers that call CORE:: directly, # bypassing CORE::GLOBAL::. By also installing into the caller's # namespace, we ensure our overrides take precedence. my $caller = scalar caller; _install_package_overrides($caller); # Cache autodie state at import time as a fallback for Perl versions # where caller(N)[10] hints after goto &sub may not be reliable. if ( $INC{'autodie.pm'} || $INC{'Fatal.pm'} ) { my $hints = ( caller(0) )[10]; if ( ref $hints eq 'HASH' && grep { /^(?:autodie|Fatal::)/ } keys %$hints ) { $_autodie_callers{$caller} = 1; } } return; } # Install a sub into a package, replicating the delete-glob trick used by # autodie/Fatal.pm's install_subs. Simple glob assignment (*pkg::func = \&sub) # does not override builtins when autodie has already installed its wrapper — # the glob entry must be deleted and recreated for Perl to pick up the new sub. sub _install_sub { my ( $pkg, $name, $ref ) = @_; no strict 'refs'; no warnings qw(redefine once); my $full_name = "${pkg}::${name}"; my $pkg_sym = "${pkg}::"; my $old_glob = *$full_name; # Delete the stash entry so Perl re-resolves the symbol. delete $pkg_sym->{$name}; # Restore non-CODE slots (SCALAR, ARRAY, HASH, IO) from the old glob # so we don't clobber unrelated data in the same symbol. local *alias = *$full_name; foreach my $slot (qw( SCALAR ARRAY HASH IO )) { next unless defined( *$old_glob{$slot} ); *alias = *$old_glob{$slot}; } *$full_name = $ref; } # Install goto-transparent wrappers into the caller's package namespace. # These use goto to preserve @_ aliasing and caller() transparency. # Uses the delete-glob technique so that Perl properly picks up our # overrides even when autodie/Fatal.pm has already installed wrappers. sub _install_package_overrides { my ($caller) = @_; return if $caller eq __PACKAGE__; return if $caller eq 'Test::MockFile::FileHandle'; return if $caller eq 'Test::MockFile::DirHandle'; push @_tmf_callers, $caller unless grep { $_ eq $caller } @_tmf_callers; my %subs = ( 'open' => sub (*;$@) { goto \&__open }, 'sysopen' => sub (*$$;$) { goto \&__sysopen }, 'opendir' => sub (*$) { goto \&__opendir }, 'readdir' => sub (*) { goto \&__readdir }, 'telldir' => sub (*) { goto \&__telldir }, 'rewinddir' => sub (*) { goto \&__rewinddir }, 'seekdir' => sub (*$) { goto \&__seekdir }, 'closedir' => sub (*) { goto \&__closedir }, 'unlink' => sub (@) { goto \&__unlink }, 'readlink' => sub (_) { goto \&__readlink }, 'mkdir' => sub (_;$) { goto \&__mkdir }, 'rmdir' => sub (_) { goto \&__rmdir }, 'chown' => sub (@) { goto \&__chown }, 'chmod' => sub (@) { goto \&__chmod }, 'rename' => sub ($$) { goto \&__rename }, 'link' => sub ($$) { goto \&__link }, 'symlink' => sub ($$) { goto \&__symlink }, 'truncate' => sub ($$) { goto \&__truncate }, 'flock' => sub (*$) { goto \&__flock }, 'utime' => sub (@) { goto \&__utime }, ); _install_sub( $caller, $_, $subs{$_} ) for keys %subs; } # Check if autodie is active for a given function in the caller's scope. # autodie stores its state in the lexical hints hash (%^H), # accessible via (caller($depth))[10]. The keys vary by version. sub _caller_has_autodie_for { my ($func) = @_; return unless $INC{'autodie.pm'} || $INC{'Fatal.pm'}; # Primary: walk the caller stack for lexical hints set by autodie. for my $depth ( 1 .. 10 ) { my @c = caller($depth); last unless @c; my $hints = $c[10]; next unless ref $hints eq 'HASH'; return 1 if $hints->{'autodie'} || $hints->{"Fatal::$func"} || $hints->{"autodie::$func"}; } # Fallback: check if the calling package had autodie active at import # time. On some Perl versions, caller(N)[10] hints may not propagate # reliably through goto &sub. This is less precise (doesn't respect # "no autodie" sub-scopes) but catches the common case. my $caller_pkg = caller(1); return $_autodie_callers{$caller_pkg} if $caller_pkg; return; } # Check-and-throw for autodie: combines _caller_has_autodie_for + _throw_autodie # into a single call to reduce boilerplate at every error return site. sub _maybe_throw_autodie { my ($func, @args) = @_; _throw_autodie($func, @args) if _caller_has_autodie_for($func); } # Throw an autodie-compatible exception for a failed CORE function. # Creates a real autodie::exception if available, otherwise a plain die. # $! must be saved before the eval since eval can clobber it. sub _throw_autodie { my ($func, @args) = @_; my $saved_errno = int($!); my $saved_errstr = "$!"; if ( eval { require autodie::exception; 1 } ) { local $! = $saved_errno; die autodie::exception->new( function => "CORE::$func", args => \@args, errno => $saved_errstr, context => 'scalar', return => undef, ); } die sprintf( "Can't %s '%s': '%s'", $func, $args[0] // '', $saved_errstr ); } # Re-install after all compilation to handle the case where # autodie is loaded after Test::MockFile (autodie's import() # would overwrite our per-package overrides during compilation). # Wrapped in BEGIN+eval to avoid "Too late to run CHECK block" # warning when the module is loaded at runtime via require. BEGIN { eval 'CHECK { _install_package_overrides($_) for @_tmf_callers; # If autodie was loaded during compilation (possibly after T::MF), # mark all T::MF callers for the autodie fallback detection. if ($INC{"autodie.pm"} || $INC{"Fatal.pm"}) { $_autodie_callers{$_} = 1 for @_tmf_callers; } }' unless ${^GLOBAL_PHASE} eq 'RUN'; } =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 'Unknown 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; _update_parent_dir_times($path); } 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 file_passthrough Args: C<($file_or_glob)> Registers a path (or shell glob pattern) with Test::MockFile but delegates B file operations (C, C, C<-f>, etc.) to the real filesystem. The path is not actually mocked: it is simply allowed through strict mode so that XS-based modules (e.g. L, L) that perform C-level I/O can create and use the file while Perl-level checks remain consistent. A glob pattern (containing C<*>, C or C<[>C<]>) matches any path that fits the pattern. This is useful for modules like L that create auxiliary files alongside the main database (e.g. C<.db-wal>, C<.db-shm>): use Test::MockFile; # strict mode by default use DBI; # Allow the SQLite database and any auxiliary files it creates. my $mock = Test::MockFile->file_passthrough('/tmp/test.db*'); my $dbh = DBI->connect("dbi:SQLite:dbname=/tmp/test.db", "", ""); ok $dbh->ping, 'ping works'; ok -f '/tmp/test.db', 'file exists on disk'; For a single, exact path: my $mock = Test::MockFile->file_passthrough('/tmp/test.db'); When the returned object goes out of scope, the strict-mode rule is removed but the real file is B deleted. Clean up the file yourself if needed: undef $mock; unlink '/tmp/test.db'; =cut sub file_passthrough { my ( $class, $file ) = @_; ( defined $file && length $file ) or confess("No file provided to instantiate $class"); my $path = _abs_path_to_file($file); # If the pattern contains glob metacharacters, build a regex from it. # Otherwise use a literal match. my $file_rule; if ( $path =~ /[*?\[\{]/ ) { $file_rule = Text::Glob::glob_to_regex($path); } else { $file_rule = qr/^\Q$path\E$/; } # Build a strict-mode rule that allows all operations on matching paths. my $rule = { 'command_rule' => qr/.*/, 'file_rule' => $file_rule, 'action' => 1, }; push @STRICT_RULES, $rule; # We intentionally do NOT register in %files_being_mocked. # This means _mock_stat, __open, etc. will all fall through to the # real filesystem via FALLBACK_TO_REAL_OP / goto &CORE::*. return bless { 'path' => $path, '_passthrough' => 1, '_passthrough_rule' => $rule, }, $class; } =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; _update_parent_dir_times($file) if defined $readlink; } 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 =head3 autovivify When C is enabled, any file operation (open, stat, rename, mkdir, etc.) on a path under the directory will automatically create a mocked file entry. This supports the common pattern of writing to a temp file and renaming it into place. my $dir = Test::MockFile->new_dir( '/data', { 'autovivify' => 1 } ); # Files are auto-mocked when accessed -- no need to declare them open my $fh, '>', '/data/.tmp.cfg' or die; print $fh $config; close $fh; rename '/data/.tmp.cfg', '/data/config.ini'; -e '/data/config.ini'; # true Auto-vivified files are tied to the parent directory's lifetime: when the directory mock goes out of scope, all auto-vivified children are cleaned up. =cut sub dir { my ( $class, $dirname, $opts ) = @_; ( 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; my $autovivify; if ( ref $opts eq 'HASH' ) { $autovivify = delete $opts->{'autovivify'}; confess("You cannot set stats for nonexistent dir '$path'") if keys %{$opts}; } elsif ( @_ > 2 ) { 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 # Only count children that actually exist (not non-existent placeholders) my $has_content = grep { my $m = $files_being_mocked{$_}; $m && $m->exists } grep m{^\Q$path/\E}xms, keys %files_being_mocked; my $self = $class->new( { 'path' => $path, 'has_content' => $has_content, 'autovivify' => $autovivify ? 1 : 0, %stats } ); if ($autovivify) { $_autovivify_dirs{$path} = $self; Scalar::Util::weaken( $_autovivify_dirs{$path} ); } return $self; } =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 %stat_overrides; my @args = $opts ? $opts : (); if ( ref $opts eq 'HASH' ) { $mode = delete $opts->{'mode'} if $opts->{'mode'}; # Extract stat overrides that dir() doesn't accept for my $key (qw(uid gid)) { $stat_overrides{$key} = delete $opts->{$key} if exists $opts->{$key}; } # 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); } # Apply stat overrides after mkdir has created the directory for my $key ( keys %stat_overrides ) { $dir->{$key} = $stat_overrides{$key}; } 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' => $next_inode, # stat[1] - auto-assigned unique value 'mode' => $mode, # stat[2] 'nlink' => 1, # stat[3] - 1 for files/symlinks, 2 for dirs '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. Each mock is assigned a unique inode number, and nlink defaults to 1 for files and symlinks, 2 for directories. 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 # Returns the default attribute hash for a new mock object. # Centralizes defaults so new(), _create_file_through_broken_symlink(), # and _maybe_autovivify() stay in sync. sub _default_mock_attrs { my $now = time; return ( '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] 'atime' => $now, # stat[8] 'mtime' => $now, # stat[9] 'ctime' => $now, # stat[10] 'blksize' => 4096, # stat[11] 'fileno' => undef, # fileno() 'tty' => 0, 'readlink' => '', 'path' => undef, 'contents' => undef, 'has_content' => undef, 'autovivify' => 0, '_autovivified_children' => undef, ); } # Creates a non-existent file mock (contents=undef) with default attrs. # Used by _create_file_through_broken_symlink and _maybe_autovivify. # The caller is responsible for registering the mock in %files_being_mocked # and attaching it to a parent (for strong-ref lifetime management). sub _new_nonexistent_file_mock { my ($abs_path) = @_; my $perms = S_IFPERMS & 0666; return bless { _default_mock_attrs(), 'inode' => $_next_inode++, 'mode' => ( $perms & ~umask ) | S_IFREG, 'nlink' => 1, 'path' => $abs_path, }, __PACKAGE__; } 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 $self = bless { _default_mock_attrs(), }, $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}; } # Assign a unique inode if the user didn't provide one if ( !$self->{'inode'} ) { $self->{'inode'} = $_next_inode++; } # Set realistic nlink defaults if the user didn't provide one. # Real filesystems: files/symlinks have nlink=1, directories have nlink=2 # (for the directory itself and its '.' entry). if ( !$self->{'nlink'} ) { $self->{'nlink'} = ( $self->{'mode'} & S_IFMT ) == S_IFDIR ? 2 : 1; } $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 ); # Broken symlink: target doesn't exist → ENOENT if ( defined $file && defined BROKEN_SYMLINK && $file eq BROKEN_SYMLINK ) { $! = ENOENT; return 0; } # Circular symlink: too many levels of indirection → ELOOP if ( defined $file && defined CIRCULAR_SYMLINK && $file eq CIRCULAR_SYMLINK ) { $! = ELOOP; return 0; } 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 ) { $file_data = _maybe_autovivify($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! if ( !$file_data->exists() ) { $! = ENOENT; return 0; } # 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}; } # Like _get_file_object but follows symlinks (for chmod, chown, utime, truncate). # Returns BROKEN_SYMLINK or CIRCULAR_SYMLINK sentinels on symlink errors, # the mock object on success, or undef if not mocked. sub _get_file_object_follow_link { my ($file_path) = @_; my $resolved = _find_file_or_fh( $file_path, 1 ); # follow symlinks # Propagate symlink error sentinels return $resolved if ref $resolved && ( $resolved == BROKEN_SYMLINK || $resolved == CIRCULAR_SYMLINK ); return unless $resolved; return $files_being_mocked{$resolved}; } # Creates a file mock at the target of a broken symlink chain. # Used when open/sysopen with a create-capable mode needs to create the target. # The new mock is attached to the last symlink in the chain (which holds the # strong ref) so it stays alive as long as the symlink mock does. # Returns the absolute path of the newly created mock, or undef on failure. sub _create_file_through_broken_symlink { my ($path) = @_; my $abs = _abs_path_to_file($path); return unless defined $abs; my $depth = 0; my $last_link_abs; while ( my $mock = $files_being_mocked{$abs} ) { return unless $mock->is_link; # Not a symlink — nothing to resolve $last_link_abs = $abs; my $target = $mock->readlink; return unless defined $target && length $target; $abs = _abs_path_to_file($target); return unless defined $abs; return if ++$depth > FOLLOW_LINK_MAX_DEPTH; # Circular — give up last unless $files_being_mocked{$abs}; # Found the broken end } return unless $last_link_abs; # Original path wasn't a symlink # If autovivify can handle it, prefer that path my $mock = _maybe_autovivify($abs); return $abs if $mock; # Create a non-existent file mock at the target path $mock = _new_nonexistent_file_mock($abs); $files_being_mocked{$abs} = $mock; Scalar::Util::weaken( $files_being_mocked{$abs} ); # The last symlink in the chain holds the strong ref my $symlink_mock = $files_being_mocked{$last_link_abs}; $symlink_mock->{'_autovivified_children'} //= []; push @{ $symlink_mock->{'_autovivified_children'} }, $mock; return $abs; } # 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 = $files_being_mocked{$path}; # Check file handles (multiple handles per file) my $fhs = $mock->{'fhs'}; if ( $fhs && @{$fhs} ) { @{$fhs} = grep { defined $_ } @{$fhs}; foreach my $mock_fh ( @{$fhs} ) { return $path if "$mock_fh" eq "$fh"; } } # Check dir handle (stored as stringified handle) if ( $mock->{'fh'} && $mock->{'fh'} eq "$fh" ) { return $path; } } return; } sub _files_in_dir { my $dirname = shift; $dirname = _abs_path_to_file($dirname) if defined $dirname && $dirname !~ m{^/}; my @files_in_dir = @files_being_mocked{ grep m{^\Q$dirname/\E}, keys %files_being_mocked }; return @files_in_dir; } # Walk up the path to find the nearest ancestor directory with autovivify enabled. # Returns the mock object if found, undef otherwise. sub _find_autovivify_parent { my ($abs_path) = @_; return unless %_autovivify_dirs; my $dir = $abs_path; while ( $dir =~ s{/[^/]+$}{} && length $dir ) { if ( my $mock = $_autovivify_dirs{$dir} ) { return $mock; } } return; } # If $abs_path is under an autovivify directory, create a non-existent file mock # for it and return the mock. Otherwise return undef. sub _maybe_autovivify { my ($abs_path) = @_; return unless defined $abs_path && length $abs_path; # Already mocked? Nothing to do. return $files_being_mocked{$abs_path} if $files_being_mocked{$abs_path}; my $parent = _find_autovivify_parent($abs_path) or return; # Create a non-existent file mock (contents=undef means "not there yet") my $mock = _new_nonexistent_file_mock($abs_path); # Store in global hash (weak ref, as usual) $files_being_mocked{$abs_path} = $mock; Scalar::Util::weaken( $files_being_mocked{$abs_path} ); # Parent holds the strong ref so it stays alive until parent is destroyed $parent->{'_autovivified_children'} //= []; push @{ $parent->{'_autovivified_children'} }, $mock; return $mock; } sub _abs_path_to_file { my ($path) = shift; return unless defined $path; # Tilde expansion must happen before making the path absolute # ~ # ~/... # ~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}; } # Make path absolute if relative if ( $path !~ m{^/}xms ) { $path = Cwd::getcwd() . "/$path"; } # Resolve path components: remove ".", resolve "..", collapse slashes my @resolved; for my $part ( split m{/}, $path ) { next if $part eq '' || $part eq '.'; if ( $part eq '..' ) { pop @resolved; next; } push @resolved, $part; } return '/' . join( '/', @resolved ); } # Override for Cwd::abs_path / Cwd::realpath that resolves mocked symlinks. # When a path (or any component of it) involves a mocked symlink, we resolve # the symlinks ourselves. Otherwise, we delegate to the original implementation. sub __cwd_abs_path { my ($path) = @_; $path = '.' unless defined $path && length $path; # Make absolute without collapsing .. (symlink-aware resolution does that) if ( $path !~ m{^/} ) { $path = Cwd::getcwd() . "/$path"; } my @remaining = grep { $_ ne '' && $_ ne '.' } split( m{/}, $path ); my $resolved = ''; my $depth = 0; my $involves_mock = 0; while (@remaining) { my $component = shift @remaining; if ( $component eq '..' ) { $resolved =~ s{/[^/]+$}{}; next; } my $candidate = "$resolved/$component"; my $mock_obj = $files_being_mocked{$candidate}; if ( $mock_obj && $mock_obj->is_link ) { $involves_mock = 1; $depth++; if ( $depth > FOLLOW_LINK_MAX_DEPTH ) { $! = ELOOP; return undef; } my $target = $mock_obj->readlink; # Broken symlink: undefined or empty target return undef unless defined $target && length $target; my @target_parts = grep { $_ ne '' && $_ ne '.' } split( m{/}, $target ); if ( $target =~ m{^/} ) { # Absolute target: restart from root $resolved = ''; } # Relative target: stays at current $resolved unshift @remaining, @target_parts; } elsif ($mock_obj) { $involves_mock = 1; $resolved = $candidate; } else { $resolved = $candidate; } } # If no mocked paths were involved, delegate to original return $_original_cwd_abs_path->($path) unless $involves_mock; return $resolved || '/'; } 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; # Passthrough mocks are not in %files_being_mocked — just remove # the strict-mode rule that was created for them. if ( $self->{'_passthrough'} ) { my $rule = $self->{'_passthrough_rule'}; @STRICT_RULES = grep { $_ != $rule } @STRICT_RULES if $rule; return; } # Clean up autovivify tracking delete $_autovivify_dirs{$path}; # Destroy auto-vivified children (dropping strong refs triggers their DESTROY) if ( $self->{'_autovivified_children'} ) { delete $self->{'_autovivified_children'}; } # 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; # Symlinks have no contents — return undef. return if $self->is_link; # 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; $_->exists() ? ($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 read Returns the contents of a mocked file. Dies if called on a directory or symlink. In scalar context, returns the entire file contents as a single string. In list context, splits the contents into lines using C<$/> as the input record separator (preserving the separator in each element), consistent with Perl's C behavior. Returns C in scalar context (or an empty list in list context) if the file does not currently exist. my $bar = Test::MockFile->file( '/foo/bar', "line1\nline2\n" ); my $text = $bar->read; # "line1\nline2\n" my @lines = $bar->read; # ( "line1\n", "line2\n" ) =cut sub read { my ($self) = @_; $self or confess("read is a method"); $self->is_link and confess("read is not supported for symlinks"); $self->is_dir and confess("read is not supported for directories"); my $contents = $self->{'contents'}; return $contents unless wantarray; return () unless defined $contents; # If $/ is undef, slurp mode — return single element return ($contents) unless defined $/; # Split keeping the separator, like readline my @lines; while ( length $contents ) { my $idx = index( $contents, $/ ); if ( $idx == -1 ) { push @lines, $contents; last; } push @lines, substr( $contents, 0, $idx + length($/) ); $contents = substr( $contents, $idx + length($/) ); } return @lines; } =head2 write Sets the contents of a mocked file. Dies if called on a directory or symlink. Multiple arguments are concatenated. If the file does not currently exist, calling C brings it into existence. Returns the mock object for chaining. my $bar = Test::MockFile->file( '/foo/bar' ); # non-existent file $bar->write("hello world"); # now exists $bar->write("line1\n", "line2\n"); # concatenated =cut sub write { my ( $self, @args ) = @_; $self or confess("write is a method"); $self->is_link and confess("write is not supported for symlinks"); $self->is_dir and confess("write is not supported for directories"); my $data = join '', @args; $self->{'contents'} = $data; my $now = time; $self->{'mtime'} = $now; $self->{'ctime'} = $now; return $self; } =head2 append Appends to the contents of a mocked file. Dies if called on a directory or symlink. Multiple arguments are concatenated before appending. If the file does not currently exist, calling C brings it into existence (as if writing to an empty file). Returns the mock object for chaining. my $bar = Test::MockFile->file( '/foo/bar', "first\n" ); $bar->append("second\n"); # "first\nsecond\n" $bar->append("third\n", "fourth\n"); # concatenated =cut sub append { my ( $self, @args ) = @_; $self or confess("append is a method"); $self->is_link and confess("append is not supported for symlinks"); $self->is_dir and confess("append is not supported for directories"); my $data = join '', @args; $self->{'contents'} //= ''; $self->{'contents'} .= $data; my $now = time; $self->{'mtime'} = $now; $self->{'ctime'} = $now; return $self; } =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 or $^O eq 'solaris' ) ) { $! = EPERM; } else { $! = EISDIR; } return 0; } if ( $self->is_link ) { $self->{'readlink'} = undef; } else { $self->{'has_content'} = undef; $self->{'contents'} = undef; } # Decrement nlink on this mock and any other hard links sharing the same inode if ( $self->{'nlink'} > 0 ) { my $inode = $self->{'inode'}; if ( $inode && $self->{'nlink'} > 1 ) { for my $path ( keys %files_being_mocked ) { my $m = $files_being_mocked{$path}; next if !$m || $m == $self; next if !$m->exists; if ( defined $m->{'inode'} && $m->{'inode'} == $inode ) { $m->{'nlink'}-- if $m->{'nlink'} > 0; } } } $self->{'nlink'}--; } _update_parent_dir_times( $self->path ); 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 ( ( $self->{'mode'} & S_IFMT ) == 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 the length of the target path. return length( $self->{'readlink'} ) if $self->is_link; # Directories have a fixed size (typically one filesystem block). # Previously, length($arrayref) stringified the contents() return, # producing a nonsensical ~20-byte value. return $self->{'blksize'} if $self->is_dir; 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 $size = $self->size; return 0 unless $size; my $blksize = abs( $self->{'blksize'} ); return int( ( $size + $blksize - 1 ) / $blksize ); } =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; $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 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; } # Update the parent directory's mtime and ctime when its contents change. # This mirrors real filesystem behavior: adding or removing entries in a # directory updates the directory's mtime and ctime. sub _update_parent_dir_times { my ($path) = @_; $path = _abs_path_to_file($path) if defined $path && $path !~ m{^/}; ( my $dirname = $path ) =~ s{ / [^/]+ $ }{}xms; return unless length $dirname; my $parent = $files_being_mocked{$dirname}; return unless $parent && $parent->is_dir(); my $now = time; $parent->{'mtime'} = $now; $parent->{'ctime'} = $now; return 1; } sub _trace_hook { my ( $access_type, $at_under_ref ) = @_; my $file_arg = file_arg_position_for_command( $access_type, $at_under_ref ); my $filename = ( $file_arg >= 0 && defined $at_under_ref->[$file_arg] ) ? $at_under_ref->[$file_arg] : ''; my @caller; foreach my $level ( 1 .. _STACK_ITERATION_MAX ) { @caller = caller($level); last if !@caller; next if $caller[0] eq __PACKAGE__; next if $caller[0] eq 'Overload::FileCheck'; last; } my $location = @caller ? "$caller[1] line $caller[2]" : 'unknown'; # Use print STDERR rather than warn to avoid triggering Test2::Plugin::NoWarnings print STDERR "[trace] $access_type('$filename') at $location\n"; return; } =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 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 1 if $] < 5.021; return 1 if $] > 5.027; return 0; } ################ # IO::File # ################ # IO::File::open() uses CORE::open internally, which bypasses CORE::GLOBAL::open. # This means IO::File->new($mocked_file) would NOT use the mock. # Fix: override IO::File::open to check for mocked files first. my $_orig_io_file_open; sub _io_file_mock_open { my ( $fh, $abs_path, $mode ) = @_; my $mock_file = _get_file_object($abs_path); # Can't open a directory as a file if ( $mock_file->is_dir ) { $! = EISDIR; return; } # If contents is undef and reading, file doesn't exist if ( !defined $mock_file->contents() && grep { $mode eq $_ } qw/< + +>> +>> > >>/; $rw .= 'a' if grep { $_ eq $mode } qw/>> +>>/; # Permission check (GH #3) if ( defined $_mock_uid ) { if ( defined $mock_file->contents() ) { # Existing file: check file permissions my $need = 0; $need |= 4 if $rw =~ /r/; $need |= 2 if $rw =~ /w/; if ( !_check_perms( $mock_file, $need ) ) { $! = EACCES; _throw_autodie( 'open', @_ ) if _caller_has_autodie_for('open'); return undef; } } elsif ( $rw =~ /w/ ) { # Creating new file: check parent dir write+execute if ( !_check_parent_perms( $abs_path, 2 | 1 ) ) { $! = EACCES; _throw_autodie( 'open', @_ ) if _caller_has_autodie_for('open'); return undef; } } } # Tie the existing IO::File glob directly (don't create a new one) tie *{$fh}, 'Test::MockFile::FileHandle', $abs_path, $rw; # Track the handle $mock_file->{'fh'} = $fh; Scalar::Util::weaken( $mock_file->{'fh'} ) if ref $fh; # Handle append/truncate modes if ( $mode eq '>>' or $mode eq '+>>' ) { $mock_file->{'contents'} //= ''; seek $fh, length( $mock_file->{'contents'} ), 0; } elsif ( $mode eq '>' or $mode eq '+>' ) { $mock_file->{'contents'} = ''; } return 1; } sub _io_file_open_override { @_ >= 2 && @_ <= 4 or croak('usage: $fh->open(FILENAME [,MODE [,PERMS]])'); my $fh = $_[0]; my $file = $_[1]; # Numeric mode (sysopen flags) if ( @_ > 2 && $_[2] =~ /^\d+$/ ) { my $sysmode = $_[2]; my $abs_path = _find_file_or_fh( $file, 1 ); my $mock_file; if ( $abs_path && !ref $abs_path ) { $mock_file = _get_file_object($abs_path); } if ( !$mock_file ) { # Not mocked — fall through to real sysopen my $perms = defined $_[3] ? $_[3] : 0666; return sysopen( $fh, $file, $sysmode, $perms ); } # Can't open a directory as a file if ( $mock_file->is_dir ) { $! = EISDIR; return; } # Handle O_CREAT / O_TRUNC / O_EXCL on the mock if ( $sysmode & Fcntl::O_EXCL && $sysmode & Fcntl::O_CREAT && defined $mock_file->{'contents'} ) { $! = EEXIST; return; } if ( $sysmode & Fcntl::O_CREAT && !defined $mock_file->{'contents'} ) { $mock_file->{'contents'} = ''; } if ( !defined $mock_file->{'contents'} ) { $! = ENOENT; return; } # Convert sysopen flags to string mode for _io_file_mock_open my $rd_wr = $sysmode & 3; my $mode = $rd_wr == Fcntl::O_RDONLY ? '<' : $rd_wr == Fcntl::O_WRONLY ? '>' : $rd_wr == Fcntl::O_RDWR ? '+<' : '<'; if ( $sysmode & Fcntl::O_TRUNC ) { $mock_file->{'contents'} = ''; } if ( $sysmode & Fcntl::O_APPEND ) { $mode = '>>' if $rd_wr == Fcntl::O_WRONLY; $mode = '+>>' if $rd_wr == Fcntl::O_RDWR; } return _io_file_mock_open( $fh, $abs_path, $mode ); } my $mode; if ( @_ > 2 ) { if ( $_[2] =~ /:/ ) { # IO layer mode like "<:utf8" — extract base mode if ( $_[2] =~ /^([+]?[<>]{1,2})/ ) { $mode = $1; } else { # Pure layer spec without mode prefix — default to read $mode = '<'; } } else { $mode = IO::Handle::_open_mode_string( $_[2] ); } } else { # 2-arg form: mode may be embedded in filename if ( $file =~ /^\s*(>>|[+]?[<>])\s*(.+)\s*$/ ) { $mode = $1; $file = $2; } else { $mode = '<'; } } # Pipe opens — not mockable if ( $mode eq '|-' || $mode eq '-|' ) { goto &$_orig_io_file_open; } # Check if file is mocked my $abs_path = _find_file_or_fh( $file, 1 ); if ( !$abs_path || ( ref $abs_path && ( $abs_path eq BROKEN_SYMLINK || $abs_path eq CIRCULAR_SYMLINK ) ) ) { goto &$_orig_io_file_open; } my $mock_file = _get_file_object($abs_path); if ( !$mock_file ) { goto &$_orig_io_file_open; } # File is mocked — handle via mock layer return _io_file_mock_open( $fh, $abs_path, $mode ); } ############ # KEYWORDS # ############ 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; # In nostrict mode, also return real filesystem matches (issue #158). # In strict mode, only mocked files are visible — no real FS access. if ( !is_strict_mode() ) { my @real_results = File::Glob::bsd_glob($spec); # Merge real results, excluding any paths that are being mocked # (mocked paths take precedence whether they exist or not) my %seen = map { $_ => 1 } @results; foreach my $real_path (@real_results) { my $abs = _abs_path_to_file($real_path); next if $files_being_mocked{$abs}; next if $seen{$real_path}++; push @results, $real_path; } } return sort @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: try +>> and >> before +> and > if ( $_[1] =~ /^ ( [+]?>> | [+]?> | [+]?< ) (.+) $/xms ) { $mode = $1; $file = $2; } elsif ( $_[1] =~ /^\|/xms ) { $mode = '|-'; $file = $_[1]; } elsif ( $_[1] =~ /\|$/xms ) { $mode = '-|'; $file = $_[1]; } else { # Any filename without a mode prefix defaults to read. # This handles filenames with spaces, special chars, etc. $mode = '<'; $file = $_[1]; } # 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 '-|'; # Broken symlinks: write-capable modes create the target (like real FS), # read-only modes return ENOENT. # Circular symlinks → ELOOP (too many levels of symlinks). if ( $abs_path eq BROKEN_SYMLINK ) { my $base_mode = $mode; $base_mode =~ s/:.+$//; # strip encoding suffix for mode check if ( grep { $base_mode eq $_ } qw/> >> +> +>>/ ) { my $target = _create_file_through_broken_symlink($file); if ($target) { $abs_path = $target; # Fall through — new mock will be found by _get_file_object below } else { $! = ENOENT; _maybe_throw_autodie( 'open', @_ ); return undef; } } else { $! = ENOENT; _maybe_throw_autodie( 'open', @_ ); return undef; } } if ( $abs_path eq CIRCULAR_SYMLINK ) { $! = ELOOP; _maybe_throw_autodie( 'open', @_ ); return undef; } my $mock_file = _get_file_object($abs_path); # Try autovivify if not mocked if ( !$mock_file ) { $mock_file = _maybe_autovivify($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! # Directories cannot be opened as regular files. if ( $mock_file->is_dir() ) { $! = EISDIR; _maybe_throw_autodie( 'open', @_ ); return undef; } # If contents is undef, we act like the file isn't there. if ( !defined $mock_file->contents() && grep { $mode eq $_ } qw/< + +>> +>> > >>/; $rw .= 'a' if grep { $_ eq $mode } qw/>> +>>/; # Permission check (GH #3) — IO::File path must match __open if ( defined $_mock_uid ) { if ( defined $mock_file->contents() ) { my $need = 0; $need |= 4 if $rw =~ /r/; $need |= 2 if $rw =~ /w/; if ( !_check_perms( $mock_file, $need ) ) { $! = EACCES; _throw_autodie( 'open', @_ ) if _caller_has_autodie_for('open'); return undef; } } elsif ( $rw =~ /w/ ) { if ( !_check_parent_perms( $abs_path, 2 | 1 ) ) { $! = EACCES; _throw_autodie( 'open', @_ ) if _caller_has_autodie_for('open'); return undef; } } } 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; } # Track all open file handles for this mock (supports multiple handles to same file). $mock_file->{'fhs'} //= []; push @{ $mock_file->{'fhs'} }, $_[0]; Scalar::Util::weaken( $mock_file->{'fhs'}[-1] ) if ref $_[0]; # Fix tell based on open options. # Track whether this open creates the file (transitions from non-existent). my $was_new = !defined $mock_file->{'contents'}; 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'} = ''; # Truncating an existing file updates mtime/ctime (like real truncate(2)). if ( !$was_new ) { my $now = time; $mock_file->{'mtime'} = $now; $mock_file->{'ctime'} = $now; } } # POSIX open(2): creating a new file sets atime, mtime, and ctime. if ( $was_new && defined $mock_file->{'contents'} ) { my $now = time; $mock_file->{'atime'} = $now; $mock_file->{'mtime'} = $now; $mock_file->{'ctime'} = $now; } # Creating a new file in a directory updates the directory's mtime. _update_parent_dir_times($abs_path) if $was_new && defined $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 $sysopen_mode = $_[2]; # Resolve the path, following symlinks unless O_NOFOLLOW is set. my $mock_file; my $abs_path; if ( $sysopen_mode & O_NOFOLLOW ) { $mock_file = _get_file_object( $_[1] ); if ( $mock_file && $mock_file->is_link ) { $! = ELOOP; _maybe_throw_autodie( 'sysopen', @_ ); return undef; } } else { $abs_path = _find_file_or_fh( $_[1], 1 ); if ( $abs_path && $abs_path eq BROKEN_SYMLINK ) { # O_CREAT through a broken symlink should create the target file if ( $sysopen_mode & O_CREAT ) { my $target = _create_file_through_broken_symlink( $_[1] ); if ($target) { $abs_path = $target; # Fall through — new mock continues below } else { $! = ENOENT; _maybe_throw_autodie( 'sysopen', @_ ); return undef; } } else { $! = ENOENT; _maybe_throw_autodie( 'sysopen', @_ ); return undef; } } if ( $abs_path && $abs_path eq CIRCULAR_SYMLINK ) { $! = ELOOP; _maybe_throw_autodie( 'sysopen', @_ ); return undef; } $mock_file = $abs_path ? $files_being_mocked{$abs_path} : undef; } if ( !$mock_file ) { $mock_file = _maybe_autovivify( _abs_path_to_file( $_[1] ) ); } if ( !$mock_file ) { _real_file_access_hook( "sysopen", \@_ ); goto \&CORE::sysopen if _goto_is_available(); return CORE::sysopen( $_[0], $_[1], @_[ 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__ ) ); } # Directories cannot be opened as regular files. if ( $mock_file->is_dir() ) { $! = EISDIR; _maybe_throw_autodie( 'sysopen', @_ ); return undef; } # O_EXCL if ( $sysopen_mode & O_EXCL && $sysopen_mode & O_CREAT && defined $mock_file->{'contents'} ) { $! = EEXIST; _maybe_throw_autodie( 'sysopen', @_ ); return undef; } # O_CREAT — POSIX open(2): creating a new file sets atime, mtime, and ctime. if ( $sysopen_mode & O_CREAT && !defined $mock_file->{'contents'} ) { $mock_file->{'contents'} = ''; my $now = time; $mock_file->{'atime'} = $now; $mock_file->{'mtime'} = $now; $mock_file->{'ctime'} = $now; _update_parent_dir_times( $_[1] ); # Apply permissions from sysopen's 4th argument (mode/mask) # On a real filesystem, sysopen(FH, $file, O_CREAT|..., $perms) # creates the file with permissions ($perms & ~umask). if ( defined $_[3] ) { my $perms = int( $_[3] ) & S_IFPERMS; $mock_file->{'mode'} = ( $perms & ~umask ) | S_IFREG; } } # O_TRUNC if ( $sysopen_mode & O_TRUNC && defined $mock_file->{'contents'} ) { $mock_file->{'contents'} = ''; my $now = time; $mock_file->{'mtime'} = $now; $mock_file->{'ctime'} = $now; } 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. $rw .= 'a' if $sysopen_mode & O_APPEND; # If contents is undef, we act like the file isn't there. # This applies to ALL modes (O_RDONLY, O_WRONLY, O_RDWR) when O_CREAT is not set. # O_CREAT would have already populated contents above if it was requested. if ( !defined $mock_file->{'contents'} ) { $! = ENOENT; _maybe_throw_autodie( 'sysopen', @_ ); return undef; } # Permission check (GH #3) if ( defined $_mock_uid ) { if ( defined $mock_file->{'contents'} ) { my $need = 0; $need |= 4 if $rw =~ /r/; $need |= 2 if $rw =~ /w/; if ( !_check_perms( $mock_file, $need ) ) { $! = EACCES; _throw_autodie( 'sysopen', @_ ) if _caller_has_autodie_for('sysopen'); return undef; } } elsif ( $rw =~ /w/ ) { if ( !_check_parent_perms( $mock_file->{'path'}, 2 | 1 ) ) { $! = EACCES; _throw_autodie( 'sysopen', @_ ) if _caller_has_autodie_for('sysopen'); return undef; } } } $abs_path //= $mock_file->{'path'}; $_[0] = IO::File->new; tie *{ $_[0] }, 'Test::MockFile::FileHandle', $abs_path, $rw; # Track all open file handles for this mock (supports multiple handles to same file). $files_being_mocked{$abs_path}->{'fhs'} //= []; push @{ $files_being_mocked{$abs_path}->{'fhs'} }, $_[0]; Scalar::Util::weaken( $files_being_mocked{$abs_path}->{'fhs'}[-1] ) if ref $_[0]; # 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 $_[0]; # 1 arg Opendir doesn't work?? if ( scalar @_ != 2 or !defined $_[1] ) { _real_file_access_hook( "opendir", \@_ ); goto \&CORE::opendir if _goto_is_available(); no strict 'refs'; ## no critic - bareword filehandles need symbolic refs return CORE::opendir( $_[0], @_[ 1 .. $#_ ] ); } # Follow symlinks — opendir resolves symlinks like stat does my $abs_path = _find_file_or_fh( $_[1], 1 ); if ( defined $abs_path && $abs_path eq BROKEN_SYMLINK ) { $! = ENOENT; _maybe_throw_autodie( 'opendir', @_ ); return undef; } if ( defined $abs_path && $abs_path eq CIRCULAR_SYMLINK ) { $! = ELOOP; _maybe_throw_autodie( 'opendir', @_ ); return undef; } my $mock_dir = defined $abs_path ? $files_being_mocked{$abs_path} : undef; if ( !$mock_dir ) { _real_file_access_hook( "opendir", \@_ ); goto \&CORE::opendir if _goto_is_available(); no strict 'refs'; ## no critic - bareword filehandles need symbolic refs return CORE::opendir( $_[0], $_[1] ); } if ( !defined $mock_dir->contents ) { $! = ENOENT; _maybe_throw_autodie( 'opendir', @_ ); return undef; } if ( !( $mock_dir->{'mode'} & S_IFDIR ) ) { $! = ENOTDIR; _maybe_throw_autodie( 'opendir', @_ ); return undef; } # Permission check: opendir needs read permission on directory (GH #3) if ( defined $_mock_uid && !_check_perms( $mock_dir, 4 ) ) { $! = EACCES; _throw_autodie( 'opendir', @_ ) if _caller_has_autodie_for('opendir'); 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. # $abs_path already holds the resolved path from _find_file_or_fh above. $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 $_[0]; my $mocked_dir = _get_file_object( $_[0] ); if ( !$mocked_dir ) { _real_file_access_hook( 'readdir', \@_ ); goto \&CORE::readdir if _goto_is_available(); no strict 'refs'; ## no critic - bareword filehandles need symbolic refs return CORE::readdir( $_[0] ); } my $obj = $mocked_dir->{'obj'}; if ( !$obj ) { warnings::warnif( 'io', "readdir() attempted on invalid dirhandle $_[0]" ); return; } 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. # Must use bare return (not "return undef") so list context gets () # instead of (undef). Otherwise while(@e = readdir $dh) never terminates. return 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 $_[0]; my ($fh) = @_; my $mocked_dir = _get_file_object($fh); if ( !$mocked_dir ) { _real_file_access_hook( 'telldir', \@_ ); goto \&CORE::telldir if _goto_is_available(); no strict 'refs'; ## no critic - bareword filehandles need symbolic refs return CORE::telldir($fh); } if ( !$mocked_dir->{'obj'} ) { warnings::warnif( 'io', "telldir() attempted on invalid dirhandle $fh" ); return undef; } 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 $_[0]; my ($fh) = @_; my $mocked_dir = _get_file_object($fh); if ( !$mocked_dir ) { _real_file_access_hook( 'rewinddir', \@_ ); goto \&CORE::rewinddir if _goto_is_available(); no strict 'refs'; ## no critic - bareword filehandles need symbolic refs return CORE::rewinddir( $_[0] ); } if ( !$mocked_dir->{'obj'} ) { warnings::warnif( 'io', "rewinddir() attempted on invalid dirhandle $fh" ); return; } 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 $_[0]; my ( $fh, $goto ) = @_; my $mocked_dir = _get_file_object($fh); if ( !$mocked_dir ) { _real_file_access_hook( 'seekdir', \@_ ); goto \&CORE::seekdir if _goto_is_available(); no strict 'refs'; ## no critic - bareword filehandles need symbolic refs return CORE::seekdir( $fh, $goto ); } if ( !$mocked_dir->{'obj'} ) { warnings::warnif( 'io', "seekdir() attempted on invalid dirhandle $fh" ); return; } 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"); } # Clamp negative positions to 0. POSIX says behavior is undefined for # invalid positions; without this guard, Perl's negative-array-indexing # causes readdir to return entries from the end of the list. $obj->{'tell'} = $goto < 0 ? 0 : $goto; return 1; } sub __closedir (*) { # Upgrade but ignore bareword indicator ( undef, @_ ) = _upgrade_barewords(@_) if defined $_[0] && !ref $_[0]; my ($fh) = @_; my $mocked_dir = _get_file_object($fh); if ( !$mocked_dir ) { _real_file_access_hook( 'closedir', \@_ ); goto \&CORE::closedir if _goto_is_available(); no strict 'refs'; ## no critic - bareword filehandles need symbolic refs return CORE::closedir($fh); } # Already closed — warn and return EBADF like real closedir if ( !$mocked_dir->{'obj'} ) { warnings::warnif( 'io', "closedir() attempted on invalid dirhandle $fh" ); $! = EBADF; _maybe_throw_autodie( 'closedir', @_ ); return undef; } delete $mocked_dir->{'obj'}; # Keep $mocked_dir->{'fh'} so double-close is detected as mock, not CORE 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 { # Permission check: unlink needs write+execute on parent dir (GH #3) if ( defined $_mock_uid && !_check_parent_perms( $mock->{'path'}, 2 | 1 ) ) { $! = EACCES; next; } $files_deleted += $mock->unlink; } } if ( $files_deleted < scalar(@files_to_unlink) ) { _maybe_throw_autodie( '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; } _maybe_throw_autodie( 'readlink', @_ ); return undef; } 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->exists() ) { $! = ENOENT; _maybe_throw_autodie( 'readlink', @_ ); return undef; } if ( !$mock_object->is_link ) { $! = EINVAL; _maybe_throw_autodie( 'readlink', @_ ); return undef; } return $mock_object->readlink; } sub __symlink ($$) { my ( $oldname, $newname ) = @_; if ( !defined $newname ) { carp('Use of uninitialized value in symlink'); $! = ENOENT; _maybe_throw_autodie( 'symlink', @_ ); return 0; } my $mock = _get_file_object($newname); if ( !$mock ) { _real_file_access_hook( 'symlink', \@_ ); goto \&CORE::symlink if _goto_is_available(); return CORE::symlink( $oldname, $newname ); } if ( $mock->exists ) { $! = EEXIST; _maybe_throw_autodie( 'symlink', @_ ); return 0; } # Convert the mock to a symlink pointing to $oldname $mock->{'readlink'} = $oldname; $mock->{'mode'} = 07777 | S_IFLNK; # POSIX symlink(2): creating a symlink sets atime, mtime, and ctime. my $now = time; $mock->{'atime'} = $now; $mock->{'mtime'} = $now; $mock->{'ctime'} = $now; # Mark parent directory as having content and update timestamps ( my $dirname = $mock->{'path'} ) =~ s{ / [^/]+ $ }{}xms; if ( $files_being_mocked{$dirname} ) { $files_being_mocked{$dirname}{'has_content'} = 1; } _update_parent_dir_times($newname); return 1; } sub __link ($$) { my ( $oldname, $newname ) = @_; if ( !defined $oldname || !defined $newname ) { carp('Use of uninitialized value in link'); $! = ENOENT; _maybe_throw_autodie( 'link', @_ ); return 0; } my $old_mock = _get_file_object($oldname); my $new_mock = _get_file_object($newname); # Neither path is mocked - passthrough to real link if ( !$old_mock && !$new_mock ) { _real_file_access_hook( 'link', \@_ ); goto \&CORE::link if _goto_is_available(); return CORE::link( $oldname, $newname ); } # Source must exist if ( !$old_mock || !$old_mock->exists ) { $! = ENOENT; _maybe_throw_autodie( 'link', @_ ); return 0; } # Cannot hard-link directories if ( $old_mock->is_dir ) { $! = EPERM; _maybe_throw_autodie( 'link', @_ ); return 0; } # Follow symlinks on the source (link() follows symlinks) my $source_mock = $old_mock; if ( $old_mock->is_link ) { my $target_path = _find_file_or_fh( $oldname, 1 ); # follow_link=1 if ( !defined $target_path || $target_path eq BROKEN_SYMLINK ) { $! = ENOENT; _maybe_throw_autodie( 'link', @_ ); return 0; } if ( $target_path eq CIRCULAR_SYMLINK ) { $! = ELOOP; _throw_autodie( 'link', @_ ) if _caller_has_autodie_for('link'); return 0; } $source_mock = $files_being_mocked{$target_path}; if ( !$source_mock || !$source_mock->exists ) { $! = ENOENT; _maybe_throw_autodie( 'link', @_ ); return 0; } } # Destination must be a pre-declared mock if ( !$new_mock ) { $! = EXDEV; _maybe_throw_autodie( 'link', @_ ); return 0; } # Destination must not already exist if ( $new_mock->exists ) { $! = EEXIST; _maybe_throw_autodie( 'link', @_ ); return 0; } # Copy file attributes from source to destination $new_mock->{'contents'} = $source_mock->{'contents'}; $new_mock->{'has_content'} = 1; $new_mock->{'mode'} = $source_mock->{'mode'}; $new_mock->{'uid'} = $source_mock->{'uid'}; $new_mock->{'gid'} = $source_mock->{'gid'}; $new_mock->{'inode'} = $source_mock->{'inode'}; $new_mock->{'dev'} = $source_mock->{'dev'}; # Update link counts — propagate to ALL same-inode mocks (mirrors unlink behavior) $source_mock->{'nlink'}++; $new_mock->{'nlink'} = $source_mock->{'nlink'}; my $inode = $source_mock->{'inode'}; if ($inode) { for my $path ( keys %files_being_mocked ) { my $m = $files_being_mocked{$path}; next if !$m || $m == $source_mock || $m == $new_mock; next if !$m->exists; if ( defined $m->{'inode'} && $m->{'inode'} == $inode ) { $m->{'nlink'} = $source_mock->{'nlink'}; } } } # Update ctime (inode change) on both my $now = time; $source_mock->{'ctime'} = $now; $new_mock->{'ctime'} = $now; $new_mock->{'atime'} = $source_mock->{'atime'}; $new_mock->{'mtime'} = $source_mock->{'mtime'}; # Mark parent directory as having content and update timestamps ( my $dirname = $new_mock->{'path'} ) =~ s{ / [^/]+ $ }{}xms; if ( $files_being_mocked{$dirname} ) { $files_being_mocked{$dirname}{'has_content'} = 1; } _update_parent_dir_times($newname); return 1; } # $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; _maybe_throw_autodie( 'mkdir', @_ ); return 0; } my $mock = _get_file_object($file); if ( !$mock ) { $mock = _maybe_autovivify( _abs_path_to_file($file) ); } if ( !$mock ) { _real_file_access_hook( 'mkdir', \@_ ); goto \&CORE::mkdir if _goto_is_available(); return CORE::mkdir(@_); } # Permission check: mkdir needs write+execute on parent dir (GH #3) if ( defined $_mock_uid && !_check_parent_perms( $mock->{'path'}, 2 | 1 ) ) { $! = EACCES; _throw_autodie( 'mkdir', @_ ) if _caller_has_autodie_for('mkdir'); return 0; } # File or directory, this exists and should fail if ( $mock->exists ) { $! = EEXIST; _maybe_throw_autodie( 'mkdir', @_ ); return 0; } # If the mock was a symlink or a file, we've just made it a dir. $mock->{'mode'} = ( $perms & ~umask ) | S_IFDIR; $mock->{'nlink'} = 2; # directories have nlink=2 (self + '.') delete $mock->{'readlink'}; # This should now start returning content $mock->{'has_content'} = 1; # POSIX mkdir(2): the new directory's timestamps are set to the current time. my $now = time; $mock->{'atime'} = $now; $mock->{'mtime'} = $now; $mock->{'ctime'} = $now; _update_parent_dir_times($file); 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'); $! = ENOENT; _maybe_throw_autodie( '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; _maybe_throw_autodie( 'rmdir', @_ ); return 0; } if ( $mock->is_link ) { $! = ENOTDIR; _maybe_throw_autodie( 'rmdir', @_ ); return 0; } } if ( !$mock->exists ) { $! = ENOENT; _maybe_throw_autodie( 'rmdir', @_ ); return 0; } # Permission check: rmdir needs write+execute on parent dir (GH #3) if ( defined $_mock_uid && !_check_parent_perms( $mock->{'path'}, 2 | 1 ) ) { $! = EACCES; _throw_autodie( 'rmdir', @_ ) if _caller_has_autodie_for('rmdir'); return 0; } if ( grep { $_->exists } _files_in_dir($file) ) { $! = ENOTEMPTY; _maybe_throw_autodie( 'rmdir', @_ ); return 0; } $mock->{'has_content'} = undef; _update_parent_dir_times($file); return 1; } sub __rename ($$) { my ( $old, $new ) = @_; my $mock_old = _get_file_object($old); my $mock_new = _get_file_object($new); # Try autovivify for paths under mocked directories if ( !$mock_old ) { $mock_old = _maybe_autovivify( _abs_path_to_file($old) ); } if ( !$mock_new ) { $mock_new = _maybe_autovivify( _abs_path_to_file($new) ); } # If neither is mocked, pass through to real FS if ( !$mock_old && !$mock_new ) { _real_file_access_hook( 'rename', \@_ ); goto \&CORE::rename if _goto_is_available(); return CORE::rename( $old, $new ); } # Can't rename between mocked and real filesystem if ( !$mock_old || !$mock_new ) { confess("rename: Cannot rename between mocked and real filesystem"); } # Source must exist if ( !$mock_old->exists ) { $! = ENOENT; _maybe_throw_autodie( 'rename', @_ ); return 0; } # Renaming to self is a no-op (POSIX rename(2)) return 1 if $mock_old == $mock_new; # Can't overwrite a directory with a non-directory if ( $mock_new->exists && $mock_new->is_dir && !$mock_old->is_dir ) { $! = EISDIR; _maybe_throw_autodie( 'rename', @_ ); return 0; } # Can't overwrite a file with a directory if ( $mock_old->is_dir && $mock_new->exists && !$mock_new->is_dir ) { $! = ENOTDIR; _maybe_throw_autodie( 'rename', @_ ); return 0; } # Can't overwrite a non-empty directory (POSIX rename(2)) if ( $mock_old->is_dir && $mock_new->exists && $mock_new->is_dir ) { if ( grep { $_->exists } _files_in_dir( $mock_new->{'path'} ) ) { $! = ENOTEMPTY; _throw_autodie( 'rename', @_ ) if _caller_has_autodie_for('rename'); return 0; } } # Move state from old to new if ( $mock_old->is_link ) { delete $mock_new->{'contents'}; delete $mock_new->{'has_content'}; $mock_new->{'readlink'} = $mock_old->{'readlink'}; $mock_old->{'readlink'} = undef; } elsif ( $mock_old->is_dir ) { delete $mock_new->{'contents'}; delete $mock_new->{'readlink'}; $mock_new->{'has_content'} = $mock_old->{'has_content'}; $mock_old->{'has_content'} = undef; # Transfer autovivify settings from old dir to new dir if ( $mock_old->{'autovivify'} ) { $mock_new->{'autovivify'} = delete $mock_old->{'autovivify'}; delete $_autovivify_dirs{ $mock_old->{'path'} }; $_autovivify_dirs{ $mock_new->{'path'} } = $mock_new; Scalar::Util::weaken( $_autovivify_dirs{ $mock_new->{'path'} } ); } # Transfer ownership of autovivified children if ( $mock_old->{'_autovivified_children'} ) { $mock_new->{'_autovivified_children'} = delete $mock_old->{'_autovivified_children'}; } # Re-key all children from old path prefix to new path prefix # in %files_being_mocked (and %_autovivify_dirs if applicable). # This ensures files under the renamed directory remain accessible. my $old_prefix = $mock_old->{'path'}; my $new_prefix = $mock_new->{'path'}; for my $key ( grep { m{^\Q$old_prefix/\E} } keys %files_being_mocked ) { my $child = $files_being_mocked{$key}; ( my $new_key = $key ) =~ s{^\Q$old_prefix/\E}{$new_prefix/}; delete $files_being_mocked{$key}; $files_being_mocked{$new_key} = $child; $child->{'path'} = $new_key; # Update autovivify tracking for child directories if ( $_autovivify_dirs{$key} ) { $_autovivify_dirs{$new_key} = delete $_autovivify_dirs{$key}; } } } else { delete $mock_new->{'readlink'}; delete $mock_new->{'has_content'}; $mock_new->{'contents'} = $mock_old->{'contents'}; $mock_old->{'contents'} = undef; } # Copy mode, ownership, and inode metadata $mock_new->{'mode'} = $mock_old->{'mode'}; $mock_new->{'uid'} = $mock_old->{'uid'}; $mock_new->{'gid'} = $mock_old->{'gid'}; $mock_new->{'inode'} = $mock_old->{'inode'}; $mock_new->{'nlink'} = $mock_old->{'nlink'}; $mock_new->{'mtime'} = $mock_old->{'mtime'}; $mock_new->{'atime'} = $mock_old->{'atime'}; # rename updates ctime on both source and destination my $now = time; $mock_new->{'ctime'} = $now; $mock_old->{'ctime'} = $now; # Update parent directory timestamps (old dir loses entry, new dir gains entry) _update_parent_dir_times($old); _update_parent_dir_times($new); 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; # Follow symlinks: chown operates on the target, not the symlink itself my %mocked_files = map +( $_ => _get_file_object_follow_link($_) ), @files; my @unmocked_files = grep !$mocked_files{$_}, @files; my @mocked_files = map { ref $_ && ref $_ ne 'A::BROKEN::SYMLINK' && ref $_ ne 'A::CIRCULAR::SYMLINK' ? $_->{'path'} : () } values %mocked_files; # The idea is that if some are mocked and some are not, # it's probably a mistake. Broken/circular symlinks are mocked paths # (handled per-file below), so they don't count as unmocked. if ( @mocked_files && @unmocked_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 ), ); } # Permission check uses the actual target uid/gid (not -1). # Use mock user identity if set, otherwise real process credentials (GH #3) my $eff_uid = defined $_mock_uid ? $_mock_uid : $>; my $eff_gids = defined $_mock_uid ? join( ' ', @_mock_gids ) : $); # -1 means "keep as is" and is handled per-file below. my $target_uid = $uid == -1 ? $eff_uid : $uid; my ($primary_gid) = split /\s/, $eff_gids; my $target_gid = $gid == -1 ? $primary_gid : $gid; my $is_root = $eff_uid == 0 || $eff_gids =~ /( ^ | \s ) 0 ( \s | $)/xms; my $is_in_group = grep /(^ | \s ) \Q$target_gid\E ( \s | $ )/xms, $eff_gids; # Only check permissions once (before the loop), not per-file. # -1 means "keep as is" — no permission needed for unchanged fields. # POSIX: non-root cannot change uid; can only change gid to a group they belong to. if ( !$is_root ) { if ( $uid != -1 && $eff_uid != $target_uid ) { $! = EPERM; _maybe_throw_autodie( 'chown', @_ ); return 0; } if ( $gid != -1 && !$is_in_group ) { $! = EPERM; _maybe_throw_autodie( 'chown', @_ ); return 0; } } 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( $uid, $gid, @files ); } # Handle broken/circular symlink errors if ( ref $mock eq 'A::BROKEN::SYMLINK' ) { $! = ENOENT; next; } if ( ref $mock eq 'A::CIRCULAR::SYMLINK' ) { $! = ELOOP; next; } # Even if you're root, nonexistent file is nonexistent if ( !$mock->exists() ) { $! = ENOENT; next; } # -1 means "keep as is" — preserve the file's current value $mock->{'uid'} = $uid == -1 ? $mock->{'uid'} : $uid; $mock->{'gid'} = $gid == -1 ? $mock->{'gid'} : $gid; $mock->{'ctime'} = time; $num_changed++; } if ( $num_changed < scalar(@files) ) { _maybe_throw_autodie( 'chown', @_ ); } 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; } # Follow symlinks: chmod operates on the target, not the symlink itself my %mocked_files = map +( $_ => _get_file_object_follow_link($_) ), @files; my @unmocked_files = grep !$mocked_files{$_}, @files; my @mocked_files = map { ref $_ && ref $_ ne 'A::BROKEN::SYMLINK' && ref $_ ne 'A::CIRCULAR::SYMLINK' ? $_->{'path'} : () } values %mocked_files; # The idea is that if some are mocked and some are not, # it's probably a mistake. Broken/circular symlinks are mocked paths # (handled per-file below), so they don't count as unmocked. if ( @mocked_files && @unmocked_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( $mode, @files ); } # Handle broken/circular symlink errors if ( ref $mock eq 'A::BROKEN::SYMLINK' ) { $! = ENOENT; next; } if ( ref $mock eq 'A::CIRCULAR::SYMLINK' ) { $! = ELOOP; next; } # chmod is less specific in such errors # chmod $mode, '/foo/' still yields ENOENT if ( !$mock->exists() ) { $! = ENOENT; next; } # Permission check: only owner or root can chmod (GH #3) if ( defined $_mock_uid && $_mock_uid != 0 && $_mock_uid != $mock->{'uid'} ) { $! = EPERM; next; } $mock->{'mode'} = ( $mock->{'mode'} & S_IFMT ) | ( $mode & S_IFPERMS ); $mock->{'ctime'} = time; $num_changed++; } if ( $num_changed < scalar(@files) ) { _maybe_throw_autodie( 'chmod', @_ ); } return $num_changed; } sub __flock (*$) { my ( $fh, $operation ) = @_; my $mock = _get_file_object($fh); if ($mock) { # Mocked files have no real file descriptor, so flock cannot # operate on them. In a test context, the lock always succeeds. return 1; } # Not a mocked file — delegate to the real flock. _real_file_access_hook( 'flock', \@_ ); goto \&CORE::flock if _goto_is_available(); return CORE::flock( $fh, $operation ); } sub __utime (@) { my ( $atime, $mtime, @files ) = @_; # Not an error, report we changed zero files @files or return 0; # Follow symlinks: utime operates on the target, not the symlink itself my %mocked_files = map +( $_ => _get_file_object_follow_link($_) ), @files; my @unmocked_files = grep !$mocked_files{$_}, @files; # If no files are mocked, fall through to the real utime if ( @unmocked_files == @files ) { _real_file_access_hook( 'utime', \@_ ); goto \&CORE::utime if _goto_is_available(); return CORE::utime( $atime, $mtime, @files ); } # Handle unmocked files via CORE::utime before processing mocks my $num_changed = 0; if (@unmocked_files) { $num_changed += CORE::utime( $atime, $mtime, @unmocked_files ); } my $now = time; foreach my $file (@files) { my $mock = $mocked_files{$file} or next; # unmocked — already handled above # Handle broken/circular symlink errors if ( ref $mock eq 'A::BROKEN::SYMLINK' ) { $! = ENOENT; next; } if ( ref $mock eq 'A::CIRCULAR::SYMLINK' ) { $! = ELOOP; next; } # The virtual file may not exist (e.g., file('/path', undef)). if ( !$mock->exists() ) { $! = ENOENT; next; } $mock->{'atime'} = defined $atime ? $atime : $now; $mock->{'mtime'} = defined $mtime ? $mtime : $now; $mock->{'ctime'} = $now; $num_changed++; } if ( $num_changed < scalar(@files) ) { _maybe_throw_autodie( 'utime', @_ ); } return $num_changed; } sub __truncate ($$) { my ( $file_or_fh, $length ) = @_; # Follow symlinks: truncate operates on the target, not the symlink itself my $mock = _get_file_object_follow_link($file_or_fh); if ( !$mock ) { _real_file_access_hook( 'truncate', \@_ ); return CORE::truncate( $file_or_fh, $length ); } # Handle broken/circular symlink errors if ( ref $mock eq 'A::BROKEN::SYMLINK' ) { $! = ENOENT; _maybe_throw_autodie( 'truncate', @_ ); return 0; } if ( ref $mock eq 'A::CIRCULAR::SYMLINK' ) { $! = ELOOP; _maybe_throw_autodie( 'truncate', @_ ); return 0; } if ( $mock->is_dir() ) { $! = EISDIR; _maybe_throw_autodie( 'truncate', @_ ); return 0; } if ( !$mock->exists() ) { $! = ENOENT; _maybe_throw_autodie( 'truncate', @_ ); return 0; } # When called with a filehandle, the handle must be open for writing. # POSIX ftruncate(2): EINVAL if fd is not open for writing. if ( ref $file_or_fh ) { my $tied = tied( *{$file_or_fh} ); if ( $tied && !$tied->{'write'} ) { $! = EINVAL; _maybe_throw_autodie( 'truncate', @_ ); return 0; } } if ( $length < 0 ) { $! = EINVAL; _maybe_throw_autodie( 'truncate', @_ ); return 0; } my $contents = $mock->contents() // ''; my $cur_len = length $contents; if ( $length < $cur_len ) { $contents = substr( $contents, 0, $length ); } elsif ( $length > $cur_len ) { $contents .= "\0" x ( $length - $cur_len ); } $mock->contents($contents); # POSIX truncate(2): marks mtime and ctime for update my $now = time; $mock->{'mtime'} = $now; $mock->{'ctime'} = $now; return 1; } BEGIN { no warnings 'redefine'; *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::symlink = \&__symlink; *CORE::GLOBAL::link = \&__link; *CORE::GLOBAL::mkdir = \&__mkdir; *CORE::GLOBAL::rename = \&__rename; *CORE::GLOBAL::rmdir = \&__rmdir; *CORE::GLOBAL::chown = \&__chown; *CORE::GLOBAL::chmod = \&__chmod; *CORE::GLOBAL::flock = \&__flock; *CORE::GLOBAL::utime = \&__utime; *CORE::GLOBAL::truncate = \&__truncate; # Override Cwd functions to resolve mocked symlinks (GH #139) $_original_cwd_abs_path = \&Cwd::abs_path; { no warnings 'redefine'; *Cwd::abs_path = \&__cwd_abs_path; *Cwd::realpath = \&__cwd_abs_path; *Cwd::fast_abs_path = \&__cwd_abs_path; *Cwd::fast_realpath = \&__cwd_abs_path; } # Override IO::File::open to intercept mocked files. # IO::File uses CORE::open internally which bypasses CORE::GLOBAL::open. $_orig_io_file_open = \&IO::File::open; { no warnings 'redefine'; *IO::File::open = \&_io_file_open_override; } } =head1 CAVEATS 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 HARD LINKS The C override copies file contents and metadata from the source to the destination mock. However, unlike real hard links, writes to one file will B be reflected in the other. The C count is incremented on both files. The destination path must be a pre-declared mock (via C or C). Attempting to C a mocked source to an unmocked destination will fail with C. =head2 FILENO IS UNSUPPORTED Filehandles can provide the file descriptor (in number) using the C keyword but this is purposefully unsupported in L. The reason 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 descriptors 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.039/lib/Test/MockFile/000755 000765 000024 00000000000 15160070576 021044 5ustar00todd.rinaldostaff000000 000000 Test-MockFile-0.039/lib/Test/MockFile/Plugins.pm000644 000765 000024 00000002604 15160070456 023022 0ustar00todd.rinaldostaff000000 000000 package Test::MockFile::Plugins; use strict; use warnings; our $VERSION = '0.039'; 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.039/lib/Test/MockFile/FileHandle.pm000644 000765 000024 00000042040 15160070472 023370 0ustar00todd.rinaldostaff000000 000000 # 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 EINVAL/; use Scalar::Util (); our $VERSION = '0.039'; 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.039 =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, 'append' => $mode =~ m/a/ ? 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. In append mode (C<< >> >> or C<< +>> >>), output is always written at the end of the file contents. In other write modes, output is written at the current tell position, overwriting existing bytes. The tell position advances by the number of bytes written. If the file handle wasn't opened in a write mode, this call will set C<$!> to EBADF and return. =cut # _write_bytes: raw write of $output at the current tell position. # This is the shared engine for both PRINT and WRITE. # Returns the number of bytes written. sub _write_bytes { my ( $self, $output ) = @_; my $data = $self->{'data'} or do { $! = EBADF; return 0; }; my $tell = $self->{'tell'}; my $contents = \$data->{'contents'}; if ( $self->{'append'} ) { # Append mode (>> / +>>): always write at end regardless of tell. $$contents .= $output; $self->{'tell'} = length $$contents; } else { # Overwrite at tell position (>, +<, +>). # Pad with null bytes if tell is past end of current contents. my $content_len = length $$contents; if ( $tell > $content_len ) { $$contents .= "\0" x ( $tell - $content_len ); } substr( $$contents, $tell, length($output), $output ); $self->{'tell'} = $tell + length($output); } return length($output); } 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/cpanel/Test-MockFile/issues/1 CORE::warn("Filehandle ???? opened only for input at ???? line ???, line ???."); $! = EBADF; return; } # Build the output string: join with $, (output field separator) if set. my $output = ''; for my $i ( 0 .. $#list ) { $output .= $list[$i] if defined $list[$i]; $output .= $, if defined $, && $i < $#list; } # Append output record separator ($\) when set explicitly by the caller. # Note: say() does NOT set $\ for tied handles (Perl handles its newline # at the C level after PRINT returns), so this only covers explicit usage. $output .= $\ if defined $\; my $data = $self->{'data'} or do { $! = EBADF; return 0; }; my $bytes = $self->_write_bytes($output); $self->_update_write_times() if $bytes; return 1; } =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. Per L, C does B append C<$\> (the output record separator), unlike C. We therefore write directly via C<_write_bytes> instead of delegating to C. =cut sub PRINTF { my $self = shift; my $format = shift; if ( !$self->{'write'} ) { $! = EBADF; return; } my $data = $self->{'data'} or do { $! = EBADF; return 0; }; my $bytes = $self->_write_bytes( sprintf( $format, @_ ) ); $self->_update_write_times() if $bytes; return 1; } =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 ) = @_; if ( !$self->{'write'} ) { $! = EBADF; return 0; } unless ( $len =~ m/^-?[0-9.]+$/ ) { CORE::warn(qq{Argument "$len" isn't numeric in syswrite at @{[ join ' line ', (caller)[1,2] ]}.\n}); $! = EINVAL; return 0; } $len = int($len); # Perl seems to do this to floats. if ( $len < 0 ) { CORE::warn(qq{Negative length at @{[ join ' line ', (caller)[1,2] ]}.\n}); $! = EINVAL; return 0; } my $strlen = length($buf); $offset //= 0; if ( $offset < 0 ) { $offset = $strlen + $offset; } if ( $offset < 0 || $offset > $strlen ) { CORE::warn(qq{Offset outside string at @{[ join ' line ', (caller)[1,2] ]}.\n}); $! = EINVAL; return 0; } # Write directly — syswrite must NOT inherit $, or $\ from PRINT. # Per perlapi: if len exceeds available data after offset, writes # only what is available (substr handles this naturally). my $bytes = $self->_write_bytes( substr( $buf, $offset, $len ) ); $self->_update_write_times() if $bytes; return $bytes; } =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 $data = $self->{'data'} or return undef; my $contents = $data->{'contents'}; my $len = length($contents); my $tell = $self->{'tell'}; # Slurp mode: $/ = undef — return everything from tell to end if ( !defined $/ ) { return undef if $tell >= $len; $self->{'tell'} = $len; return substr( $contents, $tell ); } # Fixed-record mode: $/ = \N — read exactly N bytes if ( ref $/ ) { my $reclen = ${ $/ } + 0; return undef if $tell >= $len; my $remaining = $len - $tell; my $read_len = $reclen < $remaining ? $reclen : $remaining; $self->{'tell'} = $tell + $read_len; return substr( $contents, $tell, $read_len ); } # Paragraph mode: $/ = '' — read paragraphs separated by blank lines if ( $/ eq '' ) { my $pos = $tell; # Skip leading newlines while ( $pos < $len && substr( $contents, $pos, 1 ) eq "\n" ) { $pos++; } return undef if $pos >= $len; my $start = $pos; my $boundary = index( $contents, "\n\n", $pos ); if ( $boundary == -1 ) { # No more paragraph boundaries — return rest $self->{'tell'} = $len; return substr( $contents, $start ); } # Return text up to boundary + 2 newlines (Perl collapses to exactly 2) my $text = substr( $contents, $start, $boundary - $start ) . "\n\n"; # Advance past all consecutive newlines at the boundary $pos = $boundary; while ( $pos < $len && substr( $contents, $pos, 1 ) eq "\n" ) { $pos++; } $self->{'tell'} = $pos; return $text; } # Normal mode: read until $/ is found return undef if $tell >= $len; my $idx = index( $contents, $/, $tell ); if ( $idx == -1 ) { # Record separator not found — return rest of string $self->{'tell'} = $len; return substr( $contents, $tell ); } my $new_tell = $idx + length($/); $self->{'tell'} = $new_tell; return substr( $contents, $tell, $new_tell - $tell ); } sub READLINE { my ($self) = @_; if ( !$self->{'read'} ) { my $path = $self->{'file'} // 'unknown'; CORE::warn("Filehandle $path opened only for output"); return; } 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); } $self->_update_read_time() if @all; return @all; } my $line = _READLINE_ONE_LINE($self); $self->_update_read_time() if defined $line; return $line; } =head2 GETC 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. Returns undef at EOF. =cut sub GETC { my ($self) = @_; if ( !$self->{'read'} ) { my $path = $self->{'file'} // 'unknown'; CORE::warn("Filehandle $path opened only for output"); return undef; } return undef if $self->EOF; my $data = $self->{'data'} or return undef; my $char = substr( $data->{'contents'}, $self->{'tell'}, 1 ); $self->{'tell'}++; $self->_update_read_time(); return $char; } =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 ( !$self->{'read'} ) { $! = EBADF; return undef; } # Validate $len the same way WRITE does — match real sysread behavior. unless ( $len =~ m/^-?[0-9.]+$/ ) { CORE::warn(qq{Argument "$len" isn't numeric in sysread at @{[ join ' line ', (caller)[1,2] ]}.\n}); $! = EINVAL; return undef; } $len = int($len); if ( $len < 0 ) { CORE::warn(qq{Negative length at @{[ join ' line ', (caller)[1,2] ]}.\n}); $! = EINVAL; return undef; } # 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]; my $data = $self->{'data'} or do { $! = EBADF; return 0; }; my $contents_len = length $data->{'contents'}; my $buf_len = length $_[1]; $offset //= 0; if ( $offset > $buf_len ) { $_[1] .= "\0" x ( $offset - $buf_len ); } my $tell = $self->{'tell'}; # If tell is at or past the end of contents, nothing to read (EOF) return 0 if $tell >= $contents_len; my $read_len = ( $contents_len - $tell < $len ) ? $contents_len - $tell : $len; substr( $_[1], $offset ) = substr( $data->{'contents'}, $tell, $read_len ); $self->{'tell'} += $read_len; $self->_update_read_time() if $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) = @_; # Remove this specific handle from the mock's fhs list. # Each handle has its own tied object, so we match by tied identity. # Try through the weak data ref first, then fall back to the global hash. my $mock = $self->{'data'}; if ( !$mock && $self->{'file'} ) { $mock = $files_being_mocked->{ $self->{'file'} }; } if ( $mock && $mock->{'fhs'} ) { @{ $mock->{'fhs'} } = grep { defined $_ && ( !ref $_ || ( tied( *{$_} ) || 0 ) != $self ) } @{ $mock->{'fhs'} }; } 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) = @_; # During global destruction, our weak ref or even $self may be # partially torn down. Guard before attempting cleanup. return unless $self && $self->{'file'}; 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) = @_; my $data = $self->{'data'} or return 1; if ( !$self->{'read'} ) { my $path = $self->{'file'} // 'unknown'; CORE::warn("Filehandle $path opened only for output"); } return $self->{'tell'} >= length $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. C<$whence> controls the seek origin: =over 4 =item C<0> (SEEK_SET) - seek to C<$pos> from start of file =item C<1> (SEEK_CUR) - seek to C<$pos> relative to current position =item C<2> (SEEK_END) - seek to C<$pos> relative to end of file =back No L exists on this method. =cut sub SEEK { my ( $self, $pos, $whence ) = @_; my $data = $self->{'data'} or do { $! = EBADF; return 0; }; my $file_size = length $data->{'contents'}; my $new_pos; my $SEEK_SET = 0; my $SEEK_CUR = 1; my $SEEK_END = 2; if ( $whence == $SEEK_SET ) { $new_pos = $pos; } elsif ( $whence == $SEEK_CUR ) { $new_pos = $self->{'tell'} + $pos; } elsif ( $whence == $SEEK_END ) { $new_pos = $file_size + $pos; } else { $! = EINVAL; return 0; } if ( $new_pos < 0 ) { return 0; } $self->{'tell'} = $new_pos; return $new_pos == 0 ? '0 but true' : $new_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'}; } # Update mtime and ctime after a successful write operation. sub _update_write_times { my ($self) = @_; my $data = $self->{'data'} or return; my $now = time; $data->{'mtime'} = $now; $data->{'ctime'} = $now; return; } # Update atime after a successful read operation. sub _update_read_time { my ($self) = @_; my $data = $self->{'data'} or return; $data->{'atime'} = time; return; } 1; Test-MockFile-0.039/lib/Test/MockFile/Plugin/000755 000765 000024 00000000000 15160070576 022302 5ustar00todd.rinaldostaff000000 000000 Test-MockFile-0.039/lib/Test/MockFile/Plugin.pm000644 000765 000024 00000002037 15160070457 022640 0ustar00todd.rinaldostaff000000 000000 package 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.039'; 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.039/lib/Test/MockFile/DirHandle.pm000644 000765 000024 00000004526 15160070471 023235 0ustar00todd.rinaldostaff000000 000000 # 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.039'; =head1 NAME Test::MockFile::DirHandle - Provides a class object for L to give out for opendir calls. =head1 VERSION Version 0.039 =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.039/lib/Test/MockFile/Plugin/FileTemp.pm000644 000765 000024 00000005270 15160070460 024341 0ustar00todd.rinaldostaff000000 000000 package 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.039'; 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.039/t/pod.t000644 000765 000024 00000000536 15160070345 017076 0ustar00todd.rinaldostaff000000 000000 #!perl -T use 5.016; 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.039/t/utime.t000644 000765 000024 00000017234 15157362227 017453 0ustar00todd.rinaldostaff000000 000000 #!/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 lives >; use Cwd (); use Errno qw< ENOENT >; # Create real tempfiles before Test::MockFile overrides are installed. # We avoid File::Temp because its DESTROY can trigger overridden chmod # on older Perls, causing spurious warnings. my ( $passthrough_tempfile, $nostrict_tempfile, $mixed_tempfile ); BEGIN { $passthrough_tempfile = "/tmp/tmf_utime_pass_$$.tmp"; $nostrict_tempfile = "/tmp/tmf_utime_nostrict_$$.tmp"; $mixed_tempfile = "/tmp/tmf_utime_mixed_$$.tmp"; CORE::open( my $fh1, '>', $passthrough_tempfile ) or die "Cannot create $passthrough_tempfile: $!"; CORE::close($fh1); CORE::open( my $fh2, '>', $nostrict_tempfile ) or die "Cannot create $nostrict_tempfile: $!"; CORE::close($fh2); CORE::open( my $fh3, '>', $mixed_tempfile ) or die "Cannot create $mixed_tempfile: $!"; CORE::close($fh3); } use Test::MockFile qw< nostrict >; subtest( 'utime on mocked file' => sub { my $file = Test::MockFile->file( '/foo/bar', 'content' ); ok( -f '/foo/bar', 'File exists' ); my $new_atime = 1000000; my $new_mtime = 2000000; is( utime( $new_atime, $new_mtime, '/foo/bar' ), 1, 'utime returns 1 for success' ); my @stat = stat('/foo/bar'); is( $stat[8], $new_atime, 'atime was updated' ); is( $stat[9], $new_mtime, 'mtime was updated' ); } ); subtest( 'utime updates ctime to current time' => sub { my $file = Test::MockFile->file( '/foo/baz', 'content' ); my $before = time; utime( 1000, 2000, '/foo/baz' ); my $after = time; my @stat = stat('/foo/baz'); ok( $stat[10] >= $before && $stat[10] <= $after, 'ctime was updated to current time' ); } ); subtest( 'utime with undef uses current time' => sub { my $file = Test::MockFile->file( '/foo/undef_test', 'content' ); my $before = time; is( utime( undef, undef, '/foo/undef_test' ), 1, 'utime with undef returns 1' ); my $after = time; my @stat = stat('/foo/undef_test'); ok( $stat[8] >= $before && $stat[8] <= $after, 'atime set to current time when undef' ); ok( $stat[9] >= $before && $stat[9] <= $after, 'mtime set to current time when undef' ); } ); subtest( 'utime on multiple mocked files' => sub { my $file1 = Test::MockFile->file( '/multi/a', 'aaa' ); my $file2 = Test::MockFile->file( '/multi/b', 'bbb' ); is( utime( 5000, 6000, '/multi/a', '/multi/b' ), 2, 'utime returns 2 for two files' ); my @stat_a = stat('/multi/a'); my @stat_b = stat('/multi/b'); is( $stat_a[8], 5000, 'file a atime updated' ); is( $stat_a[9], 6000, 'file a mtime updated' ); is( $stat_b[8], 5000, 'file b atime updated' ); is( $stat_b[9], 6000, 'file b mtime updated' ); } ); subtest( 'utime on nonexistent mocked file' => sub { my $file = Test::MockFile->file('/no/exist'); ok( !-f '/no/exist', 'File does not exist' ); $! = 0; is( utime( 1000, 2000, '/no/exist' ), 0, 'utime returns 0 for nonexistent file' ); is( $! + 0, ENOENT, '$! is set to ENOENT' ); } ); subtest( 'utime on mocked directory' => sub { my $dir = Test::MockFile->dir('/mydir'); ok( mkdir('/mydir'), 'Created directory' ); ok( -d '/mydir', 'Directory exists' ); is( utime( 3000, 4000, '/mydir' ), 1, 'utime on directory returns 1' ); my @stat = stat('/mydir'); is( $stat[8], 3000, 'dir atime updated' ); is( $stat[9], 4000, 'dir mtime updated' ); } ); subtest( 'utime with no files returns 0' => sub { is( utime( 1000, 2000 ), 0, 'utime with no files returns 0' ); } ); subtest( 'utime on mix of mocked and unmocked files' => sub { my $mock = Test::MockFile->file( '/mocked/mixed_test', 'data' ); my $new_atime = 7000000; my $new_mtime = 8000000; is( utime( $new_atime, $new_mtime, '/mocked/mixed_test', $mixed_tempfile ), 2, 'utime returns 2 for mixed mocked/unmocked' ); # Verify mocked file was updated my @mock_stat = stat('/mocked/mixed_test'); is( $mock_stat[8], $new_atime, 'mocked file atime updated' ); is( $mock_stat[9], $new_mtime, 'mocked file mtime updated' ); # Verify unmocked file was updated via CORE::utime passthrough my @real_stat = CORE::stat($mixed_tempfile); is( $real_stat[8], $new_atime, 'unmocked file atime updated' ); is( $real_stat[9], $new_mtime, 'unmocked file mtime updated' ); } ); subtest( 'utime on unmocked file passes through' => sub { my $new_atime = 1000000; my $new_mtime = 2000000; is( utime( $new_atime, $new_mtime, $passthrough_tempfile ), 1, 'utime on real file returns 1' ); my @stat = CORE::stat($passthrough_tempfile); is( $stat[8], $new_atime, 'real file atime was updated' ); is( $stat[9], $new_mtime, 'real file mtime was updated' ); CORE::unlink $passthrough_tempfile; } ); subtest( 'utime on unmocked file while mocked files exist' => sub { my $mock = Test::MockFile->file( '/mocked/for_utime', 'data' ); my $new_atime = 3000000; my $new_mtime = 4000000; is( utime( $new_atime, $new_mtime, $nostrict_tempfile ), 1, 'utime on unmocked file returns 1' ); my @stat = CORE::stat($nostrict_tempfile); is( $stat[8], $new_atime, 'unmocked file atime was updated' ); is( $stat[9], $new_mtime, 'unmocked file mtime was updated' ); CORE::unlink $nostrict_tempfile; } ); # Reference test: verify real utime behavior with mixed existing/non-existing files. # This demonstrates what CORE::utime does so our mock can match it. subtest( 'real utime with mixed existing/non-existing files sets ENOENT' => sub { my $nonexistent = "/tmp/tmf_utime_DOES_NOT_EXIST_$$.tmp"; # Sanity: the non-existent file really doesn't exist ok( !-e $nonexistent, 'non-existent file does not exist' ); $! = 0; my $changed = CORE::utime( 1000, 2000, $mixed_tempfile, $nonexistent ); is( $changed, 1, 'CORE::utime returns 1 (only the existing file succeeded)' ); is( $! + 0, ENOENT, 'CORE::utime sets $! to ENOENT for the missing file' ); # The existing file was still updated despite the other file failing my @stat = CORE::stat($mixed_tempfile); is( $stat[8], 1000, 'existing file atime was updated' ); is( $stat[9], 2000, 'existing file mtime was updated' ); CORE::unlink $mixed_tempfile; } ); # Mock test: verify our mock matches real utime behavior for mixed exist/non-exist subtest( 'mocked utime on mix of existing and non-existing mocked files' => sub { my $exists = Test::MockFile->file( '/mixed/exists', 'content' ); my $not_exists = Test::MockFile->file( '/mixed/not_exists' ); # undef = does not exist ok( -f '/mixed/exists', 'existing mock is a file' ); ok( !-f '/mixed/not_exists', 'non-existing mock does not exist' ); $! = 0; my $changed = utime( 5000, 6000, '/mixed/exists', '/mixed/not_exists' ); is( $changed, 1, 'utime returns 1 (only existing file succeeded)' ); is( $! + 0, ENOENT, '$! is ENOENT for the non-existing mocked file' ); # The existing mock was still updated my @stat = stat('/mixed/exists'); is( $stat[8], 5000, 'existing mock atime was updated' ); is( $stat[9], 6000, 'existing mock mtime was updated' ); } ); done_testing(); exit; Test-MockFile-0.039/t/autodie_eisdir.t000644 000765 000024 00000004243 15160070345 021304 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl # Test that open() on a directory with autodie active throws an exception. # Previously, __open set EISDIR but didn't call _throw_autodie_open, # so autodie's exception was silently swallowed. use strict; use warnings; use Test::More; # Skip if autodie is not available BEGIN { eval { require autodie }; if ($@) { plan skip_all => 'autodie not available'; } } use autodie qw(open); use Test::MockFile qw(nostrict); SKIP: { subtest 'autodie dies on open("<") of directory (EISDIR)' => sub { my $dir = Test::MockFile->new_dir("/autodie_eisdir_read_$$"); my $died = !eval { open( my $fh, '<', "/autodie_eisdir_read_$$" ); 1; }; my $err = $@; ok( $died, "autodie dies when opening directory for reading" ); ok( defined $err, "exception is set" ) if $died; }; subtest 'autodie dies on open(">") of directory (EISDIR)' => sub { my $dir = Test::MockFile->new_dir("/autodie_eisdir_write_$$"); my $died = !eval { open( my $fh, '>', "/autodie_eisdir_write_$$" ); 1; }; my $err = $@; ok( $died, "autodie dies when opening directory for writing" ); ok( defined $err, "exception is set" ) if $died; }; subtest 'EISDIR autodie exception is autodie::exception object' => sub { my $dir = Test::MockFile->new_dir("/autodie_eisdir_type_$$"); eval { open( my $fh, '<', "/autodie_eisdir_type_$$" ); }; my $err = $@; # Save before next eval clobbers it if ( eval { require autodie::exception; 1 } ) { isa_ok( $err, 'autodie::exception', 'EISDIR exception is autodie::exception' ); } else { ok( defined $err, "exception is set (autodie::exception not loadable)" ); } }; subtest 'autodie dies on open("+<") of directory (EISDIR)' => sub { my $dir = Test::MockFile->new_dir("/autodie_eisdir_rw_$$"); my $died = !eval { open( my $fh, '+<', "/autodie_eisdir_rw_$$" ); 1; }; ok( $died, "autodie dies on +< open of directory" ); }; } done_testing(); Test-MockFile-0.039/t/read_write_helpers.t000644 000765 000024 00000013420 15157362227 022170 0ustar00todd.rinaldostaff000000 000000 #!/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 >; note "-------------- read() tests --------------"; { my $file = Test::MockFile->file( '/read/basic', "hello world" ); is( $file->read, "hello world", "read returns file contents in scalar context" ); } { my $file = Test::MockFile->file( '/read/lines', "line1\nline2\nline3\n" ); my @lines = $file->read; is( \@lines, [ "line1\n", "line2\n", "line3\n" ], "read returns lines in list context" ); } { my $file = Test::MockFile->file( '/read/no-trailing', "line1\nline2" ); my @lines = $file->read; is( \@lines, [ "line1\n", "line2" ], "read handles missing trailing newline" ); } { my $file = Test::MockFile->file( '/read/empty', "" ); is( $file->read, "", "read on empty file returns empty string" ); my @lines = $file->read; is( \@lines, [], "read on empty file returns empty list" ); } { my $file = Test::MockFile->file('/read/nonexistent'); is( $file->read, undef, "read on non-existent file returns undef in scalar context" ); my @lines = $file->read; is( \@lines, [], "read on non-existent file returns empty list" ); } { my $file = Test::MockFile->file( '/read/single-line', "no newline" ); my @lines = $file->read; is( \@lines, ["no newline"], "read with no newline gives single element list" ); } { my $file = Test::MockFile->file( '/read/custom-sep', "aXXbXXc" ); local $/ = "XX"; my @lines = $file->read; is( \@lines, [ "aXX", "bXX", "c" ], "read respects custom \$/ separator" ); } { my $file = Test::MockFile->file( '/read/slurp', "line1\nline2\n" ); local $/ = undef; my @lines = $file->read; is( \@lines, ["line1\nline2\n"], "read with undef \$/ returns single element in list context" ); } { my $dir = Test::MockFile->dir('/read/dir'); like( dies { $dir->read }, qr/not supported for directories/, "read dies on directory" ); } { my $link = Test::MockFile->symlink( '/somewhere', '/read/link' ); like( dies { $link->read }, qr/not supported for symlinks/, "read dies on symlink" ); } note "-------------- write() tests --------------"; { my $file = Test::MockFile->file( '/write/basic', "" ); my $ret = $file->write("new content"); is( $file->contents, "new content", "write sets file contents" ); is( $ret, object { prop blessed => 'Test::MockFile' }, "write returns the object" ); } { my $file = Test::MockFile->file('/write/create'); ok( !$file->exists, "file does not exist before write" ); $file->write("created"); ok( $file->exists, "write brings non-existent file into existence" ); is( $file->contents, "created", "contents are correct after write-create" ); } { my $file = Test::MockFile->file( '/write/multi', "" ); $file->write( "line1\n", "line2\n", "line3\n" ); is( $file->contents, "line1\nline2\nline3\n", "write concatenates multiple args" ); } { my $file = Test::MockFile->file( '/write/overwrite', "old" ); $file->write("new"); is( $file->contents, "new", "write overwrites existing contents" ); } { my $file = Test::MockFile->file( '/write/empty', "stuff" ); $file->write(""); is( $file->contents, "", "write with empty string empties the file" ); } { my $file = Test::MockFile->file( '/write/time', "before" ); $file->mtime(1000); $file->ctime(1000); my $before = time; $file->write("after"); ok( $file->mtime >= $before, "write updates mtime" ); ok( $file->ctime >= $before, "write updates ctime" ); } { my $dir = Test::MockFile->dir('/write/dir'); like( dies { $dir->write("nope") }, qr/not supported for directories/, "write dies on directory" ); } { my $link = Test::MockFile->symlink( '/somewhere', '/write/link' ); like( dies { $link->write("nope") }, qr/not supported for symlinks/, "write dies on symlink" ); } note "-------------- append() tests --------------"; { my $file = Test::MockFile->file( '/append/basic', "hello" ); my $ret = $file->append(" world"); is( $file->contents, "hello world", "append adds to existing contents" ); is( $ret, object { prop blessed => 'Test::MockFile' }, "append returns the object" ); } { my $file = Test::MockFile->file('/append/create'); ok( !$file->exists, "file does not exist before append" ); $file->append("created"); ok( $file->exists, "append brings non-existent file into existence" ); is( $file->contents, "created", "contents are correct after append-create" ); } { my $file = Test::MockFile->file( '/append/multi', "start" ); $file->append( "\n", "line2", "\n", "line3" ); is( $file->contents, "start\nline2\nline3", "append concatenates multiple args" ); } { my $file = Test::MockFile->file( '/append/time', "before" ); $file->mtime(1000); $file->ctime(1000); my $before = time; $file->append(" after"); ok( $file->mtime >= $before, "append updates mtime" ); ok( $file->ctime >= $before, "append updates ctime" ); } { my $file = Test::MockFile->file( '/append/empty', "stuff" ); $file->append(""); is( $file->contents, "stuff", "appending empty string is a no-op on contents" ); } { my $dir = Test::MockFile->dir('/append/dir'); like( dies { $dir->append("nope") }, qr/not supported for directories/, "append dies on directory" ); } { my $link = Test::MockFile->symlink( '/somewhere', '/append/link' ); like( dies { $link->append("nope") }, qr/not supported for symlinks/, "append dies on symlink" ); } note "-------------- chaining tests --------------"; { my $file = Test::MockFile->file( '/chain/test', "" ); $file->write("hello")->append(" world"); is( $file->contents, "hello world", "write->append chaining works" ); } done_testing(); Test-MockFile-0.039/t/chmod-filetemp.t000644 000765 000024 00000000604 15157362227 021216 0ustar00todd.rinaldostaff000000 000000 #!/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.039/t/autodie_compat_reverse.t000644 000765 000024 00000003355 15157362227 023057 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl # Test autodie compatibility when Test::MockFile is loaded BEFORE autodie. # This tests the CHECK block re-installation mechanism. use strict; use warnings; use Test::More; BEGIN { eval { require autodie }; if ($@) { plan skip_all => 'autodie not available'; } } # Load T::MF first, then autodie. # T::MF's import() installs main::open = goto wrapper. # autodie's import() overwrites main::open = autodie wrapper. # T::MF's CHECK block re-installs main::open = goto wrapper. use Test::MockFile qw(nostrict); use autodie qw(open); subtest 'mocking works when T::MF loaded before autodie' => sub { my $file = "/autodie_rev_read_$$"; my $mock = Test::MockFile->file( $file, "reverse order\n" ); my $ok = eval { open( my $fh, '<', $file ); my $line = <$fh>; is( $line, "reverse order\n", "read from mocked file" ); close($fh); 1; }; ok( $ok, "mocked file open works when T::MF loaded before autodie" ) or diag("Error: $@"); }; subtest 'autodie still dies on failure' => sub { my $file = "/autodie_rev_fail_$$"; my $mock = Test::MockFile->file( $file, undef ); my $died = !eval { open( my $fh, '<', $file ); 1; }; ok( $died, "autodie dies on non-existent mocked file (reverse load order)" ); }; subtest 'write works in reverse load order' => sub { my $file = "/autodie_rev_write_$$"; my $mock = Test::MockFile->file( $file, '' ); my $ok = eval { open( my $fh, '>', $file ); print $fh "reverse write"; close($fh); 1; }; ok( $ok, "write to mocked file works" ) or diag("Error: $@"); is( $mock->contents(), "reverse write", "content is correct" ) if $ok; }; done_testing(); Test-MockFile-0.039/t/handle-corruption.t000644 000765 000024 00000001230 15157362227 021752 0ustar00todd.rinaldostaff000000 000000 #!/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.039/t/seek.t000644 000765 000024 00000020470 15157362227 017253 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Errno qw( EINVAL ); use Fcntl qw( :seek O_RDONLY O_WRONLY O_CREAT O_TRUNC O_RDWR ); use Test::MockFile qw< nostrict >; # File content used across tests: "ABCDEFGHIJ" (10 bytes) my $content = "ABCDEFGHIJ"; { note "--- SEEK_SET (whence=0) ---"; my $mock = Test::MockFile->file( '/fake/seek_set', $content ); sysopen( my $fh, '/fake/seek_set', O_RDONLY ) or die; is( sysseek( $fh, 0, SEEK_SET ), "0 but true", "SEEK_SET to 0 returns '0 but true'" ); is( sysseek( $fh, 5, SEEK_SET ), 5, "SEEK_SET to 5 returns 5" ); my $buf = ""; sysread( $fh, $buf, 3, 0 ); is( $buf, "FGH", "Reading 3 bytes from position 5 gives FGH" ); is( sysseek( $fh, 10, SEEK_SET ), 10, "SEEK_SET to 10 (EOF) returns 10" ); is( sysseek( $fh, 11, SEEK_SET ), 11, "SEEK_SET beyond EOF succeeds (POSIX allows seeking past end)" ); is( sysseek( $fh, -1, SEEK_SET ), 0, "SEEK_SET to negative returns 0 (failure)" ); close $fh; } { note "--- SEEK_CUR (whence=1) ---"; my $mock = Test::MockFile->file( '/fake/seek_cur', $content ); sysopen( my $fh, '/fake/seek_cur', O_RDONLY ) or die; is( sysseek( $fh, 3, SEEK_SET ), 3, "Start at position 3" ); is( sysseek( $fh, 4, SEEK_CUR ), 7, "SEEK_CUR +4 from 3 gives 7" ); my $buf = ""; sysread( $fh, $buf, 2, 0 ); is( $buf, "HI", "Reading from position 7 gives HI" ); # After sysread of 2 bytes, tell is at 9 is( sysseek( $fh, -3, SEEK_CUR ), 6, "SEEK_CUR -3 from 9 gives 6" ); is( sysseek( $fh, 0, SEEK_CUR ), 6, "SEEK_CUR 0 returns current position (6)" ); # Try to seek before start of file is( sysseek( $fh, -100, SEEK_CUR ), 0, "SEEK_CUR before start of file returns 0" ); # Try to seek beyond EOF is( sysseek( $fh, 100, SEEK_CUR ), 106, "SEEK_CUR beyond EOF succeeds (position 6 + 100 = 106)" ); close $fh; } { note "--- SEEK_END (whence=2) ---"; my $mock = Test::MockFile->file( '/fake/seek_end', $content ); sysopen( my $fh, '/fake/seek_end', O_RDONLY ) or die; is( sysseek( $fh, 0, SEEK_END ), 10, "SEEK_END with offset 0 = EOF position (10)" ); is( sysseek( $fh, -3, SEEK_END ), 7, "SEEK_END -3 gives position 7" ); my $buf = ""; sysread( $fh, $buf, 3, 0 ); is( $buf, "HIJ", "Reading 3 bytes from position 7 gives HIJ" ); is( sysseek( $fh, -10, SEEK_END ), "0 but true", "SEEK_END -10 gives position 0 ('0 but true')" ); is( sysseek( $fh, -11, SEEK_END ), 0, "SEEK_END before start returns 0 (failure)" ); is( sysseek( $fh, 1, SEEK_END ), 11, "SEEK_END +1 beyond file succeeds (10 + 1 = 11)" ); close $fh; } { note "--- Invalid whence ---"; my $mock = Test::MockFile->file( '/fake/seek_bad', $content ); sysopen( my $fh, '/fake/seek_bad', O_RDONLY ) or die; # Invalid whence values should return failure and set EINVAL, not die. $! = 0; my $ret = sysseek( $fh, 0, 3 ); ok( !$ret, "whence=3 returns false" ); is( $! + 0, EINVAL, "whence=3 sets \$! to EINVAL" ); $! = 0; $ret = sysseek( $fh, 0, -1 ); ok( !$ret, "whence=-1 returns false" ); is( $! + 0, EINVAL, "whence=-1 sets \$! to EINVAL" ); $! = 0; $ret = sysseek( $fh, 0, 99 ); ok( !$ret, "whence=99 returns false" ); is( $! + 0, EINVAL, "whence=99 sets \$! to EINVAL" ); close $fh; } { note "--- seek() via Perl builtin (not sysseek) ---"; my $mock = Test::MockFile->file( '/fake/seek_builtin', $content ); sysopen( my $fh, '/fake/seek_builtin', O_RDONLY ) or die; ok( seek( $fh, 5, SEEK_SET ), "seek() with SEEK_SET returns true" ); is( sysseek( $fh, 0, SEEK_CUR ), 5, "tell position is 5 after seek()" ); ok( seek( $fh, 2, SEEK_CUR ), "seek() with SEEK_CUR returns true" ); is( sysseek( $fh, 0, SEEK_CUR ), 7, "tell position is 7 after relative seek()" ); ok( seek( $fh, -2, SEEK_END ), "seek() with SEEK_END returns true" ); is( sysseek( $fh, 0, SEEK_CUR ), 8, "tell position is 8 after SEEK_END -2" ); close $fh; } { note "--- Empty file ---"; my $mock = Test::MockFile->file( '/fake/seek_empty', "" ); sysopen( my $fh, '/fake/seek_empty', O_RDONLY ) or die; is( sysseek( $fh, 0, SEEK_SET ), "0 but true", "SEEK_SET 0 on empty file returns '0 but true'" ); is( sysseek( $fh, 0, SEEK_END ), "0 but true", "SEEK_END 0 on empty file returns '0 but true'" ); is( sysseek( $fh, 0, SEEK_CUR ), "0 but true", "SEEK_CUR 0 on empty file returns '0 but true'" ); is( sysseek( $fh, 1, SEEK_SET ), 1, "SEEK_SET 1 on empty file succeeds (past EOF allowed)" ); close $fh; } { note "--- Seek after write ---"; my $mock = Test::MockFile->file('/fake/seek_rw'); sysopen( my $fh, '/fake/seek_rw', O_RDWR | O_CREAT | O_TRUNC ) or die; syswrite( $fh, "Hello World" ); # 11 bytes is( sysseek( $fh, 0, SEEK_SET ), "0 but true", "Seek back to start after write" ); my $buf = ""; sysread( $fh, $buf, 5, 0 ); is( $buf, "Hello", "Read back what was written after seek" ); is( sysseek( $fh, -5, SEEK_END ), 6, "SEEK_END -5 on written data gives position 6" ); $buf = ""; sysread( $fh, $buf, 5, 0 ); is( $buf, "World", "Read 'World' from position 6" ); close $fh; } { note "--- Seek past EOF then read (should get EOF) ---"; my $mock = Test::MockFile->file( '/fake/seek_past_read', $content ); sysopen( my $fh, '/fake/seek_past_read', O_RDONLY ) or die; is( sysseek( $fh, 50, SEEK_SET ), 50, "SEEK_SET to 50 (past 10-byte file) succeeds" ); my $buf = ""; my $nread = sysread( $fh, $buf, 10 ); is( $nread, 0, "sysread after seek past EOF returns 0 bytes" ); is( $buf, "", "buffer is empty after seek-past-EOF read" ); ok( eof($fh), "eof() is true after seek past EOF" ); close $fh; } { note "--- Seek past EOF then seek back and read ---"; my $mock = Test::MockFile->file( '/fake/seek_past_back', $content ); sysopen( my $fh, '/fake/seek_past_back', O_RDONLY ) or die; is( sysseek( $fh, 100, SEEK_SET ), 100, "Seek to position 100 (past EOF)" ); ok( eof($fh), "eof() is true at position 100" ); is( sysseek( $fh, 5, SEEK_SET ), 5, "Seek back to position 5" ); ok( !eof($fh), "eof() is false at position 5" ); my $buf = ""; sysread( $fh, $buf, 5 ); is( $buf, "FGHIJ", "Can read normally after seeking back from past-EOF position" ); ok( eof($fh), "eof() is true after reading to end" ); close $fh; } { note "--- Seek past EOF with SEEK_CUR and SEEK_END ---"; my $mock = Test::MockFile->file( '/fake/seek_past_modes', $content ); sysopen( my $fh, '/fake/seek_past_modes', O_RDONLY ) or die; # SEEK_END past EOF is( sysseek( $fh, 5, SEEK_END ), 15, "SEEK_END +5 = 10 + 5 = 15" ); ok( eof($fh), "eof() is true at position 15" ); # SEEK_CUR from past EOF is( sysseek( $fh, 10, SEEK_CUR ), 25, "SEEK_CUR +10 from 15 = 25" ); ok( eof($fh), "eof() is true at position 25" ); # Can still seek back to valid range is( sysseek( $fh, 0, SEEK_SET ), "0 but true", "Seek back to 0" ); ok( !eof($fh), "eof() is false at position 0" ); close $fh; } { note "--- tell() on regular file handles ---"; my $mock = Test::MockFile->file( '/fake/tell_test', $content ); open( my $fh, '<', '/fake/tell_test' ) or die; is( tell($fh), 0, "tell() returns 0 at start of file" ); my $line = <$fh>; is( tell($fh), 10, "tell() returns 10 after reading all content" ); seek( $fh, 3, SEEK_SET ); is( tell($fh), 3, "tell() returns 3 after seek to position 3" ); seek( $fh, 50, SEEK_SET ); is( tell($fh), 50, "tell() returns 50 after seek past EOF" ); close $fh; } { note "--- EOF warning mentions file path (not STDOUT) ---"; my $mock = Test::MockFile->file( '/fake/eof_warn', $content ); sysopen( my $fh, '/fake/eof_warn', O_WRONLY | O_CREAT ) or die; my @warnings; local $SIG{__WARN__} = sub { push @warnings, $_[0] }; my $is_eof = eof($fh); is( scalar @warnings, 1, "eof() on write-only handle emits one warning" ); like( $warnings[0], qr{/fake/eof_warn}, "warning mentions the file path, not STDOUT" ); unlike( $warnings[0], qr{STDOUT}, "warning does not mention STDOUT" ); close $fh; } is( \%Test::MockFile::files_being_mocked, {}, "No mock files are in cache" ); done_testing(); exit; Test-MockFile-0.039/t/mkdir.t000644 000765 000024 00000012244 15157362227 017432 0ustar00todd.rinaldostaff000000 000000 #!/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.039/t/unlink.t000644 000765 000024 00000006047 15157362227 017630 0ustar00todd.rinaldostaff000000 000000 #!/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' ); }; subtest 'unlink with no args uses $_' => sub { my $mock = Test::MockFile->file( '/unlink_default', "data" ); ok( -e '/unlink_default', 'file exists before unlink' ); local $_ = '/unlink_default'; is( unlink(), 1, 'unlink() with no args uses $_ and returns 1' ); ok( !-e '/unlink_default', 'file no longer exists after unlink()' ); }; done_testing(); sub on_broken_docker { return 0 if $] > 5.019; return 0 unless -f '/.dockerenv'; return 1; } Test-MockFile-0.039/t/truncate.t000644 000765 000024 00000012044 15157362227 020147 0ustar00todd.rinaldostaff000000 000000 use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Fcntl qw( O_RDWR O_CREAT ); use File::Temp (); use Errno qw( ENOENT EISDIR EINVAL ); # Create a real tempfile before loading Test::MockFile my $real_tempfile; BEGIN { $real_tempfile = File::Temp->new( UNLINK => 1 ); print {$real_tempfile} "hello world, this is a test"; $real_tempfile->flush; } use Test::MockFile qw< nostrict >; # GitHub issue #221: truncate() on mocked files should work. subtest 'truncate by path — shorten contents' => sub { my $mock = Test::MockFile->file( '/fake/truncme', 'hello world' ); ok( truncate( '/fake/truncme', 5 ), 'truncate returns true' ); is( $mock->contents(), 'hello', 'contents shortened to 5 bytes' ); }; subtest 'truncate by path — extend with null bytes' => sub { my $mock = Test::MockFile->file( '/fake/extend', 'abc' ); ok( truncate( '/fake/extend', 6 ), 'truncate returns true' ); is( length( $mock->contents() ), 6, 'contents extended to 6 bytes' ); is( $mock->contents(), "abc\0\0\0", 'padded with null bytes' ); }; subtest 'truncate by path — same length is no-op' => sub { my $mock = Test::MockFile->file( '/fake/noop', 'test' ); ok( truncate( '/fake/noop', 4 ), 'truncate returns true' ); is( $mock->contents(), 'test', 'contents unchanged' ); }; subtest 'truncate to zero' => sub { my $mock = Test::MockFile->file( '/fake/zero', 'some data here' ); ok( truncate( '/fake/zero', 0 ), 'truncate to 0 returns true' ); is( $mock->contents(), '', 'contents now empty' ); }; subtest 'truncate via filehandle' => sub { my $mock = Test::MockFile->file( '/fake/fhtrunc', 'abcdefgh' ); open( my $fh, '+<', '/fake/fhtrunc' ) or die "open: $!"; ok( truncate( $fh, 3 ), 'truncate via fh returns true' ); is( $mock->contents(), 'abc', 'contents shortened via fh' ); close $fh; }; subtest 'truncate via sysopen filehandle' => sub { my $mock = Test::MockFile->file( '/fake/systrunc', 'data1234' ); sysopen( my $fh, '/fake/systrunc', O_RDWR ) or die "sysopen: $!"; ok( truncate( $fh, 4 ), 'truncate via sysopen fh returns true' ); is( $mock->contents(), 'data', 'contents shortened via sysopen fh' ); close $fh; }; subtest 'truncate on non-existent mock file fails with ENOENT' => sub { my $mock = Test::MockFile->file( '/fake/noexist' ); ok( !truncate( '/fake/noexist', 0 ), 'truncate returns false' ); is( $! + 0, ENOENT, '$! is ENOENT' ); }; subtest 'truncate on directory fails with EISDIR' => sub { my $mock = Test::MockFile->new_dir('/fake/adir'); ok( !truncate( '/fake/adir', 0 ), 'truncate returns false' ); is( $! + 0, EISDIR, '$! is EISDIR' ); }; subtest 'truncate with negative length fails with EINVAL' => sub { my $mock = Test::MockFile->file( '/fake/neglen', 'data' ); ok( !truncate( '/fake/neglen', -1 ), 'truncate returns false' ); is( $! + 0, EINVAL, '$! is EINVAL' ); }; subtest 'truncate on real file falls through to CORE::truncate' => sub { my $path = $real_tempfile->filename; ok( truncate( $path, 5 ), 'truncate real file returns true' ); open( my $fh, '<', $path ) or die "open: $!"; my $data = do { local $/; <$fh> }; close $fh; is( length($data), 5, 'real file truncated to 5 bytes' ); }; subtest 'truncate on file with undef contents (created by open)' => sub { my $mock = Test::MockFile->file('/fake/newfile'); # File doesn't exist yet — can't truncate ok( !truncate( '/fake/newfile', 0 ), 'truncate returns false for non-existent' ); is( $! + 0, ENOENT, '$! is ENOENT' ); # Create it via open, then truncate open( my $fh, '>', '/fake/newfile' ) or die "open: $!"; print {$fh} "created"; close $fh; ok( truncate( '/fake/newfile', 3 ), 'truncate after open returns true' ); is( $mock->contents(), 'cre', 'contents shortened' ); }; subtest 'truncate via read-only filehandle fails with EINVAL' => sub { my $mock = Test::MockFile->file( '/fake/readonly', 'abcdefgh' ); open( my $fh, '<', '/fake/readonly' ) or die "open: $!"; $! = 0; my $ret = truncate( $fh, 3 ); ok( !$ret, 'truncate on read-only fh returns false' ); is( $! + 0, EINVAL, '$! is EINVAL for read-only fh' ); is( $mock->contents(), 'abcdefgh', 'contents unchanged' ); close $fh; }; subtest 'truncate via write-only filehandle succeeds' => sub { my $mock = Test::MockFile->file( '/fake/writeonly', 'original' ); open( my $fh, '>', '/fake/writeonly' ) or die "open: $!"; # > mode truncates on open, so contents are now empty ok( truncate( $fh, 0 ), 'truncate on write-only fh succeeds' ); is( $mock->contents(), '', 'contents truncated' ); close $fh; }; subtest 'truncate via append filehandle succeeds' => sub { my $mock = Test::MockFile->file( '/fake/appendfh', 'some data' ); open( my $fh, '>>', '/fake/appendfh' ) or die "open: $!"; ok( truncate( $fh, 4 ), 'truncate on append fh succeeds' ); is( $mock->contents(), 'some', 'contents shortened via append fh' ); close $fh; }; done_testing(); Test-MockFile-0.039/t/autodie_compat.t000644 000765 000024 00000010211 15160070345 021300 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl # Test autodie compatibility with Test::MockFile (GH #44) # # The core problem: autodie installs per-package wrappers that call # CORE::open directly, bypassing CORE::GLOBAL::open (where T::MF # installs its overrides). This test verifies that T::MF's per-package # override installation handles this correctly. use strict; use warnings; use Test::More; # Skip if autodie is not available BEGIN { eval { require autodie }; if ($@) { plan skip_all => 'autodie not available'; } } # Load both — autodie first, then Test::MockFile. # autodie installs main::open = autodie wrapper at compile time. # Test::MockFile then overwrites it with our goto wrapper. use autodie qw(open); use Test::MockFile qw(nostrict); subtest 'open mocked file succeeds with autodie active' => sub { my $file = "/autodie_test_read_$$"; my $mock = Test::MockFile->file( $file, "line one\nline two\n" ); # This is the exact scenario from issue #44 — previously this would # fail with "Can't open '/autodie_test_read_...' for reading: 'No # such file or directory'" because autodie bypassed T::MF's override. my $ok = eval { open( my $fh, '<', $file ); my $line = <$fh>; is( $line, "line one\n", "first line from mocked file" ); close($fh); 1; }; ok( $ok, "open on mocked file does not die with autodie" ) or diag("Error: $@"); }; subtest 'write to mocked file succeeds with autodie active' => sub { my $file = "/autodie_test_write_$$"; my $mock = Test::MockFile->file( $file, '' ); my $ok = eval { open( my $fh, '>', $file ); print $fh "written data"; close($fh); 1; }; ok( $ok, "open for writing does not die with autodie" ) or diag("Error: $@"); is( $mock->contents(), "written data", "mocked file has correct contents" ) if $ok; }; subtest 'append to mocked file succeeds with autodie active' => sub { my $file = "/autodie_test_append_$$"; my $mock = Test::MockFile->file( $file, "existing\n" ); my $ok = eval { open( my $fh, '>>', $file ); print $fh "appended\n"; close($fh); 1; }; ok( $ok, "open for append does not die with autodie" ) or diag("Error: $@"); is( $mock->contents(), "existing\nappended\n", "appended content is correct" ) if $ok; }; SKIP: { subtest 'autodie dies on non-existent mocked file' => sub { my $file = "/autodie_test_noexist_$$"; # undef contents = file does not exist my $mock = Test::MockFile->file( $file, undef ); my $died = !eval { open( my $fh, '<', $file ); 1; }; ok( $died, "autodie dies when opening non-existent mocked file" ); ok( defined $@, "exception is set" ) if $died; }; subtest 'autodie exception is autodie::exception when possible' => sub { my $file = "/autodie_test_exception_$$"; my $mock = Test::MockFile->file( $file, undef ); eval { open( my $fh, '<', $file ); }; my $err = $@; # Save before next eval clobbers it if ( eval { require autodie::exception; 1 } ) { isa_ok( $err, 'autodie::exception', 'exception is autodie::exception object' ); } else { ok( defined $err, "exception is set (autodie::exception not loadable)" ); } }; subtest '+< mode on non-existent mocked file dies with autodie' => sub { my $file = "/autodie_test_rw_noexist_$$"; my $mock = Test::MockFile->file( $file, undef ); my $died = !eval { open( my $fh, '+<', $file ); 1; }; ok( $died, "autodie dies on +< open of non-existent mocked file" ); }; } subtest 'mocked file read-write works with autodie' => sub { my $file = "/autodie_test_rw_$$"; my $mock = Test::MockFile->file( $file, "content" ); my $ok = eval { open( my $fh, '+<', $file ); my $data = <$fh>; is( $data, "content", "read from +< opened file" ); close($fh); 1; }; ok( $ok, "read-write open succeeds with autodie" ) or diag("Error: $@"); }; done_testing(); Test-MockFile-0.039/t/opendir.t000644 000765 000024 00000027637 15157362227 020000 0ustar00todd.rinaldostaff000000 000000 #!/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->new_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' ); } # Regression: dir() must use "keys" when grepping %files_being_mocked. # Without "keys", grep iterates over both keys (paths) and values (weakrefs # to blessed hashrefs). The stringified mock objects could accidentally match # the path regex, inflating has_content or causing uninitialized-value warnings # when weakrefs are cleared during global destruction. { my $mock_file = Test::MockFile->file( '/regdir/somefile', 'data' ); my $mock_dir = Test::MockFile->dir('/regdir'); is( $mock_dir->contents(), [qw< . .. somefile >], 'dir() detects mocked child file via keys %files_being_mocked' ); opendir my $dh, '/regdir' or die "opendir /regdir: $!"; is( [ readdir($dh) ], [qw< . .. somefile >], 'readdir returns correct entries for dir with mocked children' ); closedir $dh; } # Regression: readdir in list context at EOF must return empty list, not (undef). # "return undef" in Perl returns (undef) in list context — a one-element list # that is truthy — so while(@e = readdir $dh) would never terminate. { my $ldir = Test::MockFile->dir('/listctx'); my $lfile = Test::MockFile->file( '/listctx/a', 'x' ); opendir my $dh, '/listctx' or die "opendir: $!"; # Consume all entries in scalar context first while ( defined( my $e = readdir($dh) ) ) { } # Now at EOF: list context must return empty list, not (undef) my @eof_entries = readdir($dh); is( \@eof_entries, [], 'readdir in list context at EOF returns empty list, not (undef)' ); # Verify the loop pattern works: while(@entries = readdir $dh) must terminate rewinddir($dh); my @collected; my $iterations = 0; while ( my @batch = readdir($dh) ) { push @collected, @batch; last if ++$iterations > 100; # safety: prevent infinite loop in case of bug } is( [ sort @collected ], [qw< . .. a >], 'while(@e = readdir $dh) collects all entries and terminates' ); ok( $iterations <= 4, 'loop terminated without hitting safety limit' ); closedir($dh); } note "-------------- BAREWORD GUARD REGRESSION --------------"; # Regression: the bareword upgrade guard was checking $_[9] (always undef # for 1-2 arg dir functions) instead of $_[0]. This meant _upgrade_barewords # ran unconditionally, even for reference filehandles. # Also: seekdir must return 1 (like CORE::seekdir), not the seek position. { my $mock_dir = Test::MockFile->dir('/guardtest'); my $mock_file = Test::MockFile->file( '/guardtest/aaa', 'data' ); is( opendir( my $dh, '/guardtest' ), 1, "opendir with ref filehandle works" ); is( scalar readdir($dh), ".", "readdir with ref fh reads ." ); is( scalar readdir($dh), "..", "readdir with ref fh reads .." ); is( telldir($dh), 2, "telldir with ref fh returns correct position" ); is( scalar readdir($dh), "aaa", "readdir with ref fh reads aaa" ); is( rewinddir($dh), 1, "rewinddir with ref fh returns 1" ); is( telldir($dh), 0, "telldir after rewinddir is 0" ); # seekdir's return value is not reliably testable across Perl versions # with CORE::GLOBAL overrides — test the effect instead. seekdir( $dh, 2 ); is( telldir($dh), 2, "telldir is 2 after seekdir(2)" ); is( [ readdir($dh) ], ["aaa"], "readdir after seekdir(2) returns remaining entries" ); is( closedir($dh), 1, "closedir with ref fh returns 1" ); } note "opendir failure returns undef in list context (single-element list)"; { my $mock_dir = Test::MockFile->dir('/list_ctx_dir'); my @ret = opendir( my $dh, '/list_ctx_dir' ); is( scalar @ret, 1, 'opendir failure returns one element in list context' ); ok( !$ret[0], 'opendir failure element is false' ); ok( !defined $ret[0], 'opendir failure element is undef' ); } note "-------------- closedir double-close returns EBADF --------------"; { my $mock = Test::MockFile->new_dir('/dblclose'); opendir my $dh, '/dblclose' or die "opendir: $!"; is( closedir($dh), 1, 'first closedir succeeds' ); my $ret; my $errno; like( warning { $ret = closedir($dh); $errno = $! + 0; }, qr/closedir\(\) attempted on invalid dirhandle/, 'second closedir warns about invalid dirhandle' ); ok( !defined $ret, 'second closedir returns undef' ); is( $errno, EBADF, 'second closedir sets EBADF' ); } note "-------------- seekdir with negative position clamps to 0 --------------"; { my $f1 = Test::MockFile->file( '/seekneg/alpha', '' ); my $f2 = Test::MockFile->file( '/seekneg/beta', '' ); my $mock = Test::MockFile->new_dir('/seekneg'); opendir my $dh, '/seekneg' or die "opendir: $!"; # Consume one entry, then seek to -1 my $first = readdir($dh); is( $first, '.', 'readdir returns first entry before seekdir' ); seekdir( $dh, -1 ); is( telldir($dh), 0, 'seekdir(-1) clamps tell to 0' ); # readdir after seekdir(-1) should return the first entry again my $after = readdir($dh); is( $after, '.', 'readdir after seekdir(-1) returns first entry' ); # List context: seekdir(-99) then readdir returns all entries seekdir( $dh, -99 ); my @all = readdir($dh); is( \@all, [qw/. .. alpha beta/], 'readdir list after seekdir(-99) returns all entries' ); closedir($dh); } note "-------------- readdir on closed mock dirhandle warns --------------"; { my $mock = Test::MockFile->new_dir('/rd_closed'); opendir my $dh, '/rd_closed' or die "opendir: $!"; is( closedir($dh), 1, 'closedir succeeds' ); # Scalar context my $entry; like( warning { $entry = readdir($dh) }, qr/readdir\(\) attempted on invalid dirhandle/, 'readdir on closed mock dh warns' ); ok( !defined $entry, 'readdir on closed mock dh returns undef in scalar context' ); # List context my @entries; like( warning { @entries = readdir($dh) }, qr/readdir\(\) attempted on invalid dirhandle/, 'readdir on closed mock dh warns in list context' ); is( \@entries, [], 'readdir on closed mock dh returns empty list in list context' ); } note "-------------- telldir on closed mock dirhandle warns --------------"; { my $mock = Test::MockFile->new_dir('/td_closed'); opendir my $dh, '/td_closed' or die "opendir: $!"; is( closedir($dh), 1, 'closedir succeeds' ); my $pos; like( warning { $pos = telldir($dh) }, qr/telldir\(\) attempted on invalid dirhandle/, 'telldir on closed mock dh warns' ); ok( !defined $pos, 'telldir on closed mock dh returns undef' ); } note "-------------- seekdir on closed mock dirhandle warns --------------"; { my $mock = Test::MockFile->new_dir('/sd_closed'); opendir my $dh, '/sd_closed' or die "opendir: $!"; is( closedir($dh), 1, 'closedir succeeds' ); like( warning { seekdir( $dh, 0 ) }, qr/seekdir\(\) attempted on invalid dirhandle/, 'seekdir on closed mock dh warns' ); } note "-------------- rewinddir on closed mock dirhandle warns --------------"; { my $mock = Test::MockFile->new_dir('/rw_closed'); opendir my $dh, '/rw_closed' or die "opendir: $!"; is( closedir($dh), 1, 'closedir succeeds' ); like( warning { rewinddir($dh) }, qr/rewinddir\(\) attempted on invalid dirhandle/, 'rewinddir on closed mock dh warns' ); } done_testing(); exit; Test-MockFile-0.039/t/readlink.t000644 000765 000024 00000013457 15157362227 020124 0ustar00todd.rinaldostaff000000 000000 #!/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." ); # readlink(undef) errno varies by OS and version: FreeBSD 14+ returns EINVAL, # FreeBSD 12 and Linux return ENOENT. Accept both. (GH #175) ok( $! == EINVAL || $! == ENOENT, "\$! is EINVAL or ENOENT for a readlink(undef) (got: " . ($! + 0) . ")" ); $! = 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." ); ok( $! == EINVAL || $! == ENOENT, "\$! is EINVAL or ENOENT for a readlink() (got: " . ($! + 0) . ")" ); 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, "abc\n" ); push @mocks, Test::MockFile->new_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." ); ok( $! == EINVAL || $! == ENOENT, "\$! is EINVAL or ENOENT for a readlink(undef) (got: " . ($! + 0) . ")" ); $! = 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." ); ok( $! == EINVAL || $! == ENOENT, "\$! is EINVAL or ENOENT for a readlink() (got: " . ($! + 0) . ")" ); note "--- readlink on non-existent mocks returns ENOENT ---"; { my $ne_file = Test::MockFile->file("$temp_dir_name/ne_file"); $! = 0; is( readlink("$temp_dir_name/ne_file"), undef, "readlink on non-existent file mock is undef" ); is( $! + 0, ENOENT, '$! is ENOENT for readlink on non-existent file mock' ); } { my $ne_dir = Test::MockFile->dir("$temp_dir_name/ne_dir"); $! = 0; is( readlink("$temp_dir_name/ne_dir"), undef, "readlink on non-existent dir mock is undef" ); is( $! + 0, ENOENT, '$! is ENOENT for readlink on non-existent dir mock' ); } note "--- readlink failure returns undef (not empty list) in list context ---"; { my $mock_file = Test::MockFile->file("$temp_dir_name/not_a_link", "data"); # readlink on a regular file — should return (undef) in list context my @ret = readlink("$temp_dir_name/not_a_link"); is( scalar @ret, 1, 'readlink on non-link returns one element in list context' ); ok( !defined $ret[0], 'readlink failure element is undef' ); } { my $mock_file = Test::MockFile->file("$temp_dir_name/nonexist"); # readlink on a non-existent mock — should return (undef) in list context my @ret = readlink("$temp_dir_name/nonexist"); is( scalar @ret, 1, 'readlink on non-existent mock returns one element in list context' ); ok( !defined $ret[0], 'readlink non-existent failure element is undef' ); } done_testing(); Test-MockFile-0.039/t/strict-rules_scalar.t000644 000765 000024 00000002406 15157362227 022310 0ustar00todd.rinaldostaff000000 000000 #!/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.039/t/portability_errno.t000644 000765 000024 00000014353 15157362227 022076 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Errno qw/ELOOP ENOTEMPTY ENOENT EINVAL/; use Fcntl; use Test::MockFile qw< nostrict >; subtest "sysopen O_NOFOLLOW on symlink sets ELOOP" => sub { my $target = Test::MockFile->file( '/tmp/real_file', 'data' ); my $link = Test::MockFile->symlink( '/tmp/real_file', '/tmp/link_to_file' ); # O_NOFOLLOW on a regular file should work $! = 0; ok( sysopen( my $fh, '/tmp/real_file', O_RDONLY | O_NOFOLLOW ), "sysopen O_NOFOLLOW on regular file succeeds" ); close $fh if $fh; # O_NOFOLLOW on a symlink should fail with ELOOP $! = 0; ok( !sysopen( my $fh2, '/tmp/link_to_file', O_RDONLY | O_NOFOLLOW ), "sysopen O_NOFOLLOW on symlink fails" ); is( $! + 0, ELOOP, "\$! is ELOOP (not hardcoded 40)" ) or diag "Got errno: " . ( $! + 0 ) . " ($!)"; }; subtest "rmdir non-empty directory sets ENOTEMPTY" => sub { my $dir = Test::MockFile->dir('/tmp/test_dir'); my $file = Test::MockFile->file( '/tmp/test_dir/child', 'content' ); mkdir('/tmp/test_dir'); $! = 0; ok( !rmdir('/tmp/test_dir'), "rmdir on non-empty directory fails" ); is( $! + 0, ENOTEMPTY, "\$! is ENOTEMPTY (not hardcoded 39)" ) or diag "Got errno: " . ( $! + 0 ) . " ($!)"; }; subtest "syswrite with non-numeric length warns" => sub { my $mock = Test::MockFile->file('/tmp/write_test'); sysopen( my $fh, '/tmp/write_test', O_WRONLY | O_CREAT | O_TRUNC ) or die; my @warnings; local $SIG{__WARN__} = sub { push @warnings, $_[0] }; my $ret = syswrite( $fh, "hello", "abc" ); is( $ret, 0, "syswrite with non-numeric len returns 0" ); is( $! + 0, EINVAL, "\$! is set to EINVAL" ); ok( scalar @warnings >= 1, "got a warning" ); like( $warnings[0], qr/isn't numeric/, "warning mentions non-numeric argument" ) if @warnings; close $fh; }; subtest "syswrite with negative length warns" => sub { my $mock = Test::MockFile->file('/tmp/write_test2'); sysopen( my $fh, '/tmp/write_test2', O_WRONLY | O_CREAT | O_TRUNC ) or die; my @warnings; local $SIG{__WARN__} = sub { push @warnings, $_[0] }; my $ret = syswrite( $fh, "hello", -1 ); is( $ret, 0, "syswrite with negative length returns 0" ); is( $! + 0, EINVAL, "\$! is set to EINVAL" ); ok( scalar @warnings >= 1, "got a warning" ); like( $warnings[0], qr/Negative length/, "warning mentions negative length" ) if @warnings; close $fh; }; subtest "syswrite with offset outside string warns" => sub { my $mock = Test::MockFile->file('/tmp/write_test3'); sysopen( my $fh, '/tmp/write_test3', O_WRONLY | O_CREAT | O_TRUNC ) or die; my @warnings; local $SIG{__WARN__} = sub { push @warnings, $_[0] }; my $ret = syswrite( $fh, "hello", 2, 100 ); is( $ret, 0, "syswrite with offset beyond string returns 0" ); is( $! + 0, EINVAL, "\$! is set to EINVAL" ); ok( scalar @warnings >= 1, "got a warning" ); like( $warnings[0], qr/Offset outside string/, "warning mentions offset" ) if @warnings; close $fh; }; subtest "syswrite with valid negative offset works" => sub { my $mock = Test::MockFile->file('/tmp/write_test4'); sysopen( my $fh, '/tmp/write_test4', O_WRONLY | O_CREAT | O_TRUNC ) or die; # -3 from end of "hello" (len 5) = position 2, write 2 chars = "ll" is( syswrite( $fh, "hello", 2, -3 ), 2, "syswrite with negative offset returns correct byte count" ); is( $mock->contents, "ll", "correct substring written with negative offset" ); close $fh; }; subtest "syswrite with too-negative offset warns" => sub { my $mock = Test::MockFile->file('/tmp/write_test5'); sysopen( my $fh, '/tmp/write_test5', O_WRONLY | O_CREAT | O_TRUNC ) or die; my @warnings; local $SIG{__WARN__} = sub { push @warnings, $_[0] }; my $ret = syswrite( $fh, "hello", 2, -10 ); is( $ret, 0, "syswrite with offset before start of string returns 0" ); is( $! + 0, EINVAL, "\$! is set to EINVAL" ); ok( scalar @warnings >= 1, "got a warning" ); like( $warnings[0], qr/Offset outside string/, "warning mentions offset" ) if @warnings; close $fh; }; subtest "sysread with non-numeric length warns and returns undef" => sub { my $mock = Test::MockFile->file( '/tmp/read_test', 'hello world' ); sysopen( my $fh, '/tmp/read_test', O_RDONLY ) or die; my @warnings; local $SIG{__WARN__} = sub { push @warnings, $_[0] }; my $buf = ''; my $ret = sysread( $fh, $buf, "abc" ); ok( !defined $ret, "sysread with non-numeric len returns undef" ); is( $! + 0, EINVAL, "\$! is set to EINVAL" ); ok( scalar @warnings >= 1, "got a warning" ); like( $warnings[0], qr/isn't numeric/, "warning mentions non-numeric argument" ) if @warnings; is( $buf, '', "buffer is unchanged after failed sysread" ); close $fh; }; subtest "sysread with negative length warns and returns undef" => sub { my $mock = Test::MockFile->file( '/tmp/read_test2', 'hello world' ); sysopen( my $fh, '/tmp/read_test2', O_RDONLY ) or die; my @warnings; local $SIG{__WARN__} = sub { push @warnings, $_[0] }; my $buf = ''; my $ret = sysread( $fh, $buf, -1 ); ok( !defined $ret, "sysread with negative length returns undef" ); is( $! + 0, EINVAL, "\$! is set to EINVAL" ); ok( scalar @warnings >= 1, "got a warning" ); like( $warnings[0], qr/Negative length/, "warning mentions negative length" ) if @warnings; is( $buf, '', "buffer is unchanged after failed sysread" ); close $fh; }; subtest "sysread with undef buffer initializes it" => sub { my $mock = Test::MockFile->file( '/tmp/read_test3', 'ABCDEFGHIJ' ); sysopen( my $fh, '/tmp/read_test3', O_RDONLY ) or die; my $buf; # undef my $ret = sysread( $fh, $buf, 5 ); is( $ret, 5, "sysread with undef buffer returns 5 bytes" ); is( $buf, 'ABCDE', "buffer contains the read data" ); close $fh; }; subtest "sysread with zero length returns 0" => sub { my $mock = Test::MockFile->file( '/tmp/read_test4', 'hello' ); sysopen( my $fh, '/tmp/read_test4', O_RDONLY ) or die; my $buf = ''; my $ret = sysread( $fh, $buf, 0 ); is( $ret, 0, "sysread with len=0 returns 0" ); is( $buf, '', "buffer is empty after zero-length read" ); close $fh; }; done_testing(); Test-MockFile-0.039/t/chown.t000644 000765 000024 00000023674 15160057055 017445 0ustar00todd.rinaldostaff000000 000000 #!/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 (); use Errno qw/ENOENT EPERM/; 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)' ); } ); subtest( 'chown -1 preserves per-file ownership, not process identity' => sub { # Create a file with non-default ownership my $custom_uid = 12345; my $custom_gid = 67890; my $file = Test::MockFile->file( '/chown_test_preserve' => 'data', { uid => $custom_uid, gid => $custom_gid }, ); # Use root mock user so permission checks don't interfere with # the -1 preservation semantics being tested here. Test::MockFile->set_user( 0, 0 ); # chown(-1, -1) should keep the custom values, not replace with $> / $) ok( chown( -1, -1, '/chown_test_preserve' ), 'chown(-1, -1) succeeds' ); my @st = stat('/chown_test_preserve'); is( $st[4], $custom_uid, 'uid preserved (not replaced with process uid)' ); is( $st[5], $custom_gid, 'gid preserved (not replaced with process gid)' ); # chown($new_uid, -1) should change uid but preserve gid ok( chown( 99, -1, '/chown_test_preserve' ), 'chown(99, -1) succeeds' ); @st = stat('/chown_test_preserve'); is( $st[4], 99, 'uid changed to 99' ); is( $st[5], $custom_gid, 'gid still preserved after uid-only change' ); # chown(-1, $new_gid) should preserve uid but change gid ok( chown( -1, 42, '/chown_test_preserve' ), 'chown(-1, 42) succeeds' ); @st = stat('/chown_test_preserve'); is( $st[4], 99, 'uid still preserved after gid-only change' ); is( $st[5], 42, 'gid changed to 42' ); Test::MockFile->clear_user; } ); subtest( 'chown uid-only and gid-only permission checks' => sub { my $file = Test::MockFile->file( '/chown_perm_test' => 'data', { uid => 1000, gid => 1000 }, ); # Non-root user cannot change uid to a different user (uid-only) Test::MockFile->set_user( 1000, 1000 ); $! = 0; is( chown( 2000, -1, '/chown_perm_test' ), 0, 'non-root cannot chown uid-only to different user' ); is( $! + 0, EPERM, 'errno is EPERM for uid-only chown' ); # Non-root user cannot change gid to a group they are not in (gid-only) $! = 0; is( chown( -1, 9999, '/chown_perm_test' ), 0, 'non-root cannot chown gid-only to foreign group' ); is( $! + 0, EPERM, 'errno is EPERM for gid-only chown' ); # Non-root user CAN change gid to a group they belong to Test::MockFile->set_user( 1000, 1000, 2000 ); $! = 0; is( chown( -1, 2000, '/chown_perm_test' ), 1, 'non-root can chown gid to own group' ); is( $! + 0, 0, 'no error for allowed gid change' ); # Non-root user CAN chown uid to self (no-op) $! = 0; is( chown( 1000, -1, '/chown_perm_test' ), 1, 'non-root can chown uid to self' ); is( $! + 0, 0, 'no error for uid self-chown' ); Test::MockFile->clear_user; } ); subtest( 'chown with broken symlink in multi-file list does not confess' => sub { my $link = Test::MockFile->symlink( '/nonexistent_target', '/chown_broken_link' ); my $file = Test::MockFile->file( '/chown_real_file', 'content' ); # chown on a mix of regular file + broken symlink should NOT die. # The broken symlink should silently fail with ENOENT, and the # regular file should succeed. my ( $result, $errno ); ok( lives { $result = chown( $>, int($)), '/chown_broken_link', '/chown_real_file' ); $errno = $! + 0 }, 'chown with broken symlink + regular file does not confess', ); is( $result, 1, 'chown returns 1 (one file changed)' ); is( $errno, ENOENT, 'errno set to ENOENT for the broken symlink' ); } ); subtest( 'chown with only broken symlink' => sub { my $link = Test::MockFile->symlink( '/nowhere', '/chown_only_broken' ); my ( $result, $errno ); ok( lives { $result = chown( $>, int($)), '/chown_only_broken' ); $errno = $! + 0 }, 'chown with only a broken symlink does not confess', ); is( $result, 0, 'chown returns 0 (no files changed)' ); is( $errno, ENOENT, 'errno set to ENOENT' ); } ); done_testing(); exit; Test-MockFile-0.039/t/writeline.t000644 000765 000024 00000004402 15157362227 020323 0ustar00todd.rinaldostaff000000 000000 #!/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 ), 1, "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" ), 1, "Append line" ); my $bytes = printf $fh "%04d", 42; is( $bytes, 1, "printf returns 1 (success)" ); is( $bar->contents, "$oneline but really long\n0042", '$foo->contents reflects an append' ); my $undef_len = print $fh undef; is( $undef_len, 1, "Printing undef returns 1 (success) and is not a warning." ); my $empty_ret = print $fh ""; is( $empty_ret, 1, "Printing empty string returns 1 (success), not 0" ); ok( ( print $fh "" or 1 ), "print empty string is truthy (print or die pattern works)" ); 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.039/t/read_write_perms.t000644 000765 000024 00000005463 15157362227 021664 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Errno qw/EBADF/; use Test::MockFile qw< nostrict >; # READ (sysread) on a write-only handle should fail with EBADF { my $mock = Test::MockFile->file( '/read_ebadf', "hello world" ); ok( open( my $fh, '>', '/read_ebadf' ), 'open write-only succeeds' ); my $buf; $! = 0; my $ret = sysread( $fh, $buf, 10 ); ok( !defined $ret, 'sysread on write-only handle returns undef' ); is( $! + 0, EBADF, 'sysread on write-only handle sets EBADF' ); close $fh; } # READ on a read-only handle should succeed { my $mock = Test::MockFile->file( '/read_ok', "hello world" ); ok( open( my $fh, '<', '/read_ok' ), 'open read-only succeeds' ); my $buf; my $ret = sysread( $fh, $buf, 5 ); is( $ret, 5, 'sysread on read-only handle returns byte count' ); is( $buf, 'hello', 'sysread on read-only handle reads data' ); close $fh; } # READ on a read-write handle should succeed { my $mock = Test::MockFile->file( '/read_rw', "hello world" ); ok( open( my $fh, '+<', '/read_rw' ), 'open read-write succeeds' ); my $buf; my $ret = sysread( $fh, $buf, 5 ); is( $ret, 5, 'sysread on read-write handle returns byte count' ); is( $buf, 'hello', 'sysread on read-write handle reads data' ); close $fh; } # Symlink size should equal length of target path { my $link = Test::MockFile->symlink( '/some/target/path', '/test_link_size' ); my @st = lstat('/test_link_size'); is( $st[7], length('/some/target/path'), 'symlink lstat size = length of target path' ); } # Symlink with short target { my $link = Test::MockFile->symlink( '/x', '/test_link_short' ); my @st = lstat('/test_link_short'); is( $st[7], 2, 'symlink to /x has size 2' ); } # Symlink with long target { my $long_target = '/a/very/long/path/to/some/deeply/nested/directory/file.txt'; my $link = Test::MockFile->symlink( $long_target, '/test_link_long' ); my @st = lstat('/test_link_long'); is( $st[7], length($long_target), 'symlink size matches long target path length' ); } # stat on a symlink follows to the target; lstat returns symlink's own size { my $target = Test::MockFile->file( '/target/file', 'hello world!' ); my $link = Test::MockFile->symlink( '/target/file', '/test_link_dash_s' ); # stat follows the symlink — size should be the target file's content length my @st_stat = stat('/test_link_dash_s'); is( $st_stat[7], 12, 'stat on symlink returns target file size (follows symlink)' ); # lstat size of the symlink itself = length of target path my @st = lstat('/test_link_dash_s'); is( $st[7], length('/target/file'), 'lstat size of symlink = length of target path' ); } done_testing(); exit; Test-MockFile-0.039/t/plugin.t000644 000765 000024 00000006321 15157362227 017621 0ustar00todd.rinaldostaff000000 000000 #!/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.039/t/autodie_filesys.t000644 000765 000024 00000005225 15157362227 021515 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl # Test autodie compatibility for filesystem operations beyond open/sysopen. # # autodie installs per-package wrappers that call CORE::func directly, # bypassing CORE::GLOBAL overrides (where T::MF installs its hooks). # T::MF's _install_package_overrides must cover these functions so # mocks are not silently bypassed under autodie. use strict; use warnings; use Test::More; # Skip if autodie is not available BEGIN { eval { require autodie }; if ($@) { plan skip_all => 'autodie not available'; } } use autodie qw(rename link symlink truncate); use Test::MockFile qw(nostrict); subtest 'rename works on mocked files under autodie' => sub { my $src = Test::MockFile->file( '/ad_rename_src', 'data' ); my $dst = Test::MockFile->file('/ad_rename_dst'); my $ok = eval { rename( '/ad_rename_src', '/ad_rename_dst' ); 1; }; ok( $ok, 'rename does not die with autodie on mocked files' ) or diag("Error: $@"); is( $dst->contents(), 'data', 'destination has source contents after rename' ) if $ok; }; subtest 'link works on mocked files under autodie' => sub { my $src = Test::MockFile->file( '/ad_link_src', 'linked' ); my $dst = Test::MockFile->file('/ad_link_dst'); my $ok = eval { link( '/ad_link_src', '/ad_link_dst' ); 1; }; ok( $ok, 'link does not die with autodie on mocked files' ) or diag("Error: $@"); is( $dst->contents(), 'linked', 'destination has source contents after link' ) if $ok; }; subtest 'symlink works on mocked files under autodie' => sub { my $link = Test::MockFile->file('/ad_sym_link'); my $ok = eval { symlink( '/some/target', '/ad_sym_link' ); 1; }; ok( $ok, 'symlink does not die with autodie on mocked files' ) or diag("Error: $@"); is( readlink('/ad_sym_link'), '/some/target', 'symlink points to correct target' ) if $ok; }; subtest 'truncate works on mocked files under autodie' => sub { my $file = Test::MockFile->file( '/ad_trunc', 'hello world' ); my $ok = eval { truncate( '/ad_trunc', 5 ); 1; }; ok( $ok, 'truncate does not die with autodie on mocked files' ) or diag("Error: $@"); is( $file->contents(), 'hello', 'file truncated to 5 bytes' ) if $ok; }; subtest 'flock succeeds on mocked file handle under autodie' => sub { my $file = Test::MockFile->file( '/ad_flock', 'content' ); my $ok = eval { open( my $fh, '<', '/ad_flock' ); flock( $fh, 1 ); # LOCK_SH close($fh); 1; }; ok( $ok, 'flock does not die with autodie on mocked file handle' ) or diag("Error: $@"); }; done_testing(); Test-MockFile-0.039/t/symlink.t000644 000765 000024 00000005744 15157362227 020021 0ustar00todd.rinaldostaff000000 000000 #!/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 Errno qw( ENOENT EEXIST ); 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', ); } # --- stat/lstat on unlinked symlinks --- { my $target = Test::MockFile->file( '/tmp/stat_target', 'data' ); my $link = Test::MockFile->symlink( '/tmp/stat_target', '/tmp/stat_link' ); # Before unlink: lstat on symlink should succeed my @lstat_before = lstat('/tmp/stat_link'); ok( scalar @lstat_before, 'lstat on live symlink returns stat data' ); # Unlink the symlink ok( unlink('/tmp/stat_link'), 'unlink symlink succeeds' ); # After unlink: lstat should fail with ENOENT my @lstat_after = lstat('/tmp/stat_link'); is( scalar @lstat_after, 0, 'lstat on unlinked symlink returns empty list' ); is( $! + 0, ENOENT, 'lstat on unlinked symlink sets ENOENT' ); # stat should also fail my @stat_after = stat('/tmp/stat_link'); is( scalar @stat_after, 0, 'stat on unlinked symlink returns empty list' ); } # --- symlink() builtin sets creation timestamps --- { note "symlink() sets atime, mtime, ctime on the new symlink"; my $target = Test::MockFile->file( '/mock/ts_target', 'data' ); my $link_mock = Test::MockFile->file('/mock/ts_link'); # Set mock timestamps to a known past value $link_mock->{'atime'} = 1000; $link_mock->{'mtime'} = 1000; $link_mock->{'ctime'} = 1000; my $before = time; symlink( '/mock/ts_target', '/mock/ts_link' ); my @lstat = lstat('/mock/ts_link'); ok( scalar @lstat, 'lstat on new symlink succeeds' ); ok( $lstat[8] >= $before, 'symlink atime set to current time' ); ok( $lstat[9] >= $before, 'symlink mtime set to current time' ); ok( $lstat[10] >= $before, 'symlink ctime set to current time' ); } # --- symlink() on existing target returns EEXIST --- { note "symlink() on existing path returns EEXIST"; my $target = Test::MockFile->file( '/mock/eexist_target', 'data' ); my $existing = Test::MockFile->file( '/mock/eexist_link', 'already here' ); my $result = symlink( '/mock/eexist_target', '/mock/eexist_link' ); is( $result, 0, 'symlink on existing file returns 0' ); is( $! + 0, EEXIST, 'symlink on existing file sets EEXIST' ); } done_testing(); exit 0; Test-MockFile-0.039/t/manifest.t000644 000765 000024 00000000647 15160070345 020125 0ustar00todd.rinaldostaff000000 000000 #!perl -T use 5.016; 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.039/t/path.t000644 000765 000024 00000000726 15157362227 017262 0ustar00todd.rinaldostaff000000 000000 #!/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.039/t/perms.t000644 000765 000024 00000032620 15160070345 017441 0ustar00todd.rinaldostaff000000 000000 use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Errno qw( EACCES EPERM ); use Fcntl qw( O_RDONLY O_WRONLY O_RDWR O_CREAT ); use Test::MockFile qw< nostrict >; # On systems with restrictive umask (e.g., 077), group/other permission bits # are stripped from mock files, causing tests that rely on those bits to fail. my $current_umask = umask; my $restrictive_umask = ( $current_umask & 077 ) != 0; # true if group or other bits are masked # GitHub issue #3: User perms are not checked on file access. # When set_user() is active, mock operations check Unix permission bits. # ========================================================================= # Cleanup helper — always clear mock user after each subtest # ========================================================================= sub with_user (&@) { my ( $code, $uid, @gids ) = @_; Test::MockFile->set_user( $uid, @gids ); my $ok = eval { $code->(); 1 }; my $err = $@; Test::MockFile->clear_user(); die $err unless $ok; } # ========================================================================= # set_user / clear_user basics # ========================================================================= subtest 'set_user and clear_user' => sub { # No mock user by default — open should succeed regardless of mode my $f = Test::MockFile->file( '/perms/basic', 'hello', { mode => 0000, uid => 99, gid => 99 } ); ok( open( my $fh, '<', '/perms/basic' ), 'open succeeds with 0000 mode when no mock user set' ); close $fh if $fh; # With mock user set, 0000 mode should fail for non-root Test::MockFile->set_user( 1000, 1000 ); ok( !open( my $fh2, '<', '/perms/basic' ), 'open fails with 0000 mode when mock user is non-owner' ); is( $! + 0, EACCES, 'errno is EACCES' ); # clear_user disables checks again Test::MockFile->clear_user(); ok( open( my $fh3, '<', '/perms/basic' ), 'open succeeds again after clear_user' ); close $fh3 if $fh3; }; # ========================================================================= # open() permission checks # ========================================================================= subtest 'open read-only with owner read permission' => sub { my $f = Test::MockFile->file( '/perms/owner_r', 'data', { mode => 0400, uid => 1000, gid => 1000 } ); with_user { ok( open( my $fh, '<', '/perms/owner_r' ), 'owner can read 0400 file' ); close $fh if $fh } 1000, 1000; with_user { ok( !open( my $fh, '<', '/perms/owner_r' ), 'other user cannot read 0400 file' ) } 2000, 2000; }; subtest 'open write-only with owner write permission' => sub { my $f = Test::MockFile->file( '/perms/owner_w', 'data', { mode => 0200, uid => 1000, gid => 1000 } ); with_user { ok( open( my $fh, '>', '/perms/owner_w' ), 'owner can write 0200 file' ); close $fh if $fh } 1000, 1000; with_user { ok( !open( my $fh, '>', '/perms/owner_w' ), 'other user cannot write 0200 file' ) } 2000, 2000; }; subtest 'open read-write with owner rw permission' => sub { my $f = Test::MockFile->file( '/perms/owner_rw', 'data', { mode => 0600, uid => 1000, gid => 1000 } ); with_user { ok( open( my $fh, '+<', '/perms/owner_rw' ), 'owner can rw 0600 file' ); close $fh if $fh } 1000, 1000; with_user { ok( !open( my $fh, '+<', '/perms/owner_rw' ), 'other user cannot rw 0600 file' ) } 2000, 2000; }; subtest 'open with group permissions' => sub { skip_all 'umask strips group bits' if $restrictive_umask; my $f = Test::MockFile->file( '/perms/grp', 'data', { mode => 0040, uid => 1000, gid => 500 } ); # User in group 500 can read with_user { ok( open( my $fh, '<', '/perms/grp' ), 'group member can read 0040 file' ); close $fh if $fh } 2000, 500; # User NOT in group 500 cannot read with_user { ok( !open( my $fh, '<', '/perms/grp' ), 'non-group member cannot read 0040 file' ) } 2000, 2000; }; subtest 'open with other permissions' => sub { skip_all 'umask strips other bits' if $restrictive_umask; my $f = Test::MockFile->file( '/perms/other', 'data', { mode => 0004, uid => 1000, gid => 1000 } ); # Random user can read via "other" bits with_user { ok( open( my $fh, '<', '/perms/other' ), 'other user can read 0004 file' ); close $fh if $fh } 9999, 9999; # Owner cannot read (owner bits are 0) with_user { ok( !open( my $fh, '<', '/perms/other' ), 'owner cannot read when owner bits are 0' ) } 1000, 1000; }; # ========================================================================= # root bypass # ========================================================================= subtest 'root can read/write any file' => sub { my $f = Test::MockFile->file( '/perms/root', 'secret', { mode => 0000, uid => 1000, gid => 1000 } ); with_user { ok( open( my $fh, '<', '/perms/root' ), 'root can read 0000 file' ); close $fh if $fh; } 0, 0; with_user { ok( open( my $fh, '>', '/perms/root' ), 'root can write 0000 file' ); close $fh if $fh; } 0, 0; }; # ========================================================================= # sysopen permission checks # ========================================================================= subtest 'sysopen permission checks' => sub { my $f = Test::MockFile->file( '/perms/sys', 'data', { mode => 0400, uid => 1000, gid => 1000 } ); with_user { ok( sysopen( my $fh, '/perms/sys', O_RDONLY ), 'owner can sysopen O_RDONLY on 0400' ); close $fh if $fh; } 1000, 1000; with_user { ok( !sysopen( my $fh, '/perms/sys', O_RDONLY ), 'non-owner cannot sysopen O_RDONLY on 0400' ); is( $! + 0, EACCES, 'sysopen errno is EACCES' ); } 2000, 2000; with_user { ok( !sysopen( my $fh, '/perms/sys', O_WRONLY ), 'owner cannot sysopen O_WRONLY on 0400 (no write bit)' ); is( $! + 0, EACCES, 'sysopen errno is EACCES for write' ); } 1000, 1000; }; # ========================================================================= # opendir permission checks # ========================================================================= subtest 'opendir permission checks' => sub { my $dir = Test::MockFile->new_dir( '/perms/dir', { mode => 0700, uid => 1000, gid => 1000 } ); with_user { ok( opendir( my $dh, '/perms/dir' ), 'owner can opendir 0700 dir' ); closedir $dh if $dh; } 1000, 1000; with_user { ok( !opendir( my $dh, '/perms/dir' ), 'non-owner cannot opendir 0700 dir' ); is( $! + 0, EACCES, 'opendir errno is EACCES' ); } 2000, 2000; }; subtest 'opendir group read permission' => sub { skip_all 'umask strips group bits' if $restrictive_umask; my $dir = Test::MockFile->new_dir( '/perms/grpdir', { mode => 0050, uid => 1000, gid => 500 } ); with_user { ok( opendir( my $dh, '/perms/grpdir' ), 'group member can opendir 0050 dir' ); closedir $dh if $dh; } 2000, 500; with_user { ok( !opendir( my $dh, '/perms/grpdir' ), 'non-group cannot opendir 0050 dir' ); } 2000, 2000; }; # ========================================================================= # unlink permission checks (needs write+exec on parent) # ========================================================================= subtest 'unlink permission checks on parent directory' => sub { my $parent = Test::MockFile->new_dir( '/perms/udir', { mode => 0755, uid => 1000, gid => 1000 } ); my $child = Test::MockFile->file( '/perms/udir/victim', 'gone' ); # Owner of parent can unlink with_user { is( unlink('/perms/udir/victim'), 1, 'parent owner can unlink child' ); } 1000, 1000; # Re-create the file for next test $child = Test::MockFile->file( '/perms/udir/victim2', 'gone2' ); # Non-owner, non-group with only read+exec on parent (0755 → other=rx) # Other has r(4)+x(1) = 5, needs w(2)+x(1) = 3 — missing write with_user { is( unlink('/perms/udir/victim2'), 0, 'non-owner cannot unlink in 0755 dir (no write)' ); is( $! + 0, EACCES, 'unlink errno is EACCES' ); } 9999, 9999; }; # ========================================================================= # mkdir permission checks (needs write+exec on parent) # ========================================================================= subtest 'mkdir permission checks on parent directory' => sub { my $parent = Test::MockFile->new_dir( '/perms/mdir', { mode => 0755, uid => 1000, gid => 1000 } ); my $target = Test::MockFile->dir('/perms/mdir/newdir'); with_user { ok( mkdir('/perms/mdir/newdir'), 'parent owner can mkdir' ); } 1000, 1000; # Clean up and re-mock for next test my $parent2 = Test::MockFile->new_dir( '/perms/mdir2', { mode => 0555, uid => 1000, gid => 1000 } ); my $target2 = Test::MockFile->dir('/perms/mdir2/newdir2'); with_user { ok( !mkdir('/perms/mdir2/newdir2'), 'cannot mkdir in 0555 dir (no write)' ); is( $! + 0, EACCES, 'mkdir errno is EACCES' ); } 1000, 1000; }; # ========================================================================= # rmdir permission checks (needs write+exec on parent) # ========================================================================= subtest 'rmdir permission checks on parent directory' => sub { my $parent = Test::MockFile->new_dir( '/perms/rdir', { mode => 0755, uid => 1000, gid => 1000 } ); my $target = Test::MockFile->new_dir('/perms/rdir/empty'); with_user { ok( rmdir('/perms/rdir/empty'), 'parent owner can rmdir empty dir' ); } 1000, 1000; my $parent2 = Test::MockFile->new_dir( '/perms/rdir2', { mode => 0555, uid => 1000, gid => 1000 } ); my $target2 = Test::MockFile->new_dir('/perms/rdir2/empty2'); with_user { ok( !rmdir('/perms/rdir2/empty2'), 'cannot rmdir in 0555 dir (no write)' ); is( $! + 0, EACCES, 'rmdir errno is EACCES' ); } 1000, 1000; }; # ========================================================================= # chmod permission checks (only owner or root) # ========================================================================= subtest 'chmod permission checks' => sub { my $f = Test::MockFile->file( '/perms/chm', 'data', { mode => 0644, uid => 1000, gid => 1000 } ); with_user { is( chmod( 0600, '/perms/chm' ), 1, 'owner can chmod' ); } 1000, 1000; with_user { is( chmod( 0777, '/perms/chm' ), 0, 'non-owner cannot chmod' ); is( $! + 0, EPERM, 'chmod errno is EPERM' ); } 2000, 2000; with_user { is( chmod( 0777, '/perms/chm' ), 1, 'root can chmod any file' ); } 0, 0; }; # ========================================================================= # chown with mock user # ========================================================================= subtest 'chown uses mock user identity' => sub { my $f = Test::MockFile->file( '/perms/cho', 'data', { mode => 0644, uid => 1000, gid => 1000 } ); # Non-root mock user cannot chown to a different user with_user { is( chown( 2000, 2000, '/perms/cho' ), 0, 'non-root mock user cannot chown to different user' ); is( $! + 0, EPERM, 'chown errno is EPERM' ); } 1000, 1000; # Root mock user can chown with_user { is( chown( 2000, 2000, '/perms/cho' ), 1, 'root mock user can chown' ); } 0, 0; }; # ========================================================================= # Non-existent file bypasses permission checks (ENOENT takes priority) # ========================================================================= subtest 'non-existent file returns ENOENT not EACCES' => sub { my $f = Test::MockFile->file('/perms/noexist'); with_user { ok( !open( my $fh, '<', '/perms/noexist' ), 'cannot open non-existent file' ); # ENOENT should come before permission check } 1000, 1000; }; # ========================================================================= # Multiple group membership # ========================================================================= subtest 'user with multiple groups' => sub { skip_all 'umask strips group bits' if $restrictive_umask; my $f = Test::MockFile->file( '/perms/multigrp', 'data', { mode => 0040, uid => 1000, gid => 500 } ); # User in secondary group 500 with_user { ok( open( my $fh, '<', '/perms/multigrp' ), 'user in secondary group can read' ); close $fh if $fh; } 2000, 100, 500, 600; # User NOT in group 500 with_user { ok( !open( my $fh, '<', '/perms/multigrp' ), 'user not in any matching group cannot read' ); } 2000, 100, 200, 300; }; # ========================================================================= # open with write-creating modes checks parent perms # ========================================================================= subtest 'open > on new file checks parent directory perms' => sub { my $parent = Test::MockFile->new_dir( '/perms/wdir', { mode => 0555, uid => 1000, gid => 1000 } ); my $child = Test::MockFile->file('/perms/wdir/newfile'); with_user { ok( !open( my $fh, '>', '/perms/wdir/newfile' ), 'cannot create file in read-only parent dir' ); is( $! + 0, EACCES, 'errno is EACCES' ); } 1000, 1000; my $parent2 = Test::MockFile->new_dir( '/perms/wdir2', { mode => 0755, uid => 1000, gid => 1000 } ); my $child2 = Test::MockFile->file('/perms/wdir2/newfile2'); with_user { ok( open( my $fh, '>', '/perms/wdir2/newfile2' ), 'can create file in writable parent dir' ); close $fh if $fh; } 1000, 1000; }; done_testing(); Test-MockFile-0.039/t/dir_interface.t000644 000765 000024 00000014767 15157362227 021136 0ustar00todd.rinaldostaff000000 000000 #!/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 >] ); } ); subtest( 'Scenario 5: Non-existent dir placeholders excluded from contents' => sub { my $dirname = $get_dirname->(); my $dir = Test::MockFile->new_dir($dirname); # Create a real file and a non-existent dir placeholder as children my $file = Test::MockFile->file( "$dirname/real_file", 'content' ); my $nonexist_dir = Test::MockFile->dir("$dirname/phantom_dir"); # The non-existent dir placeholder should NOT appear in contents is( $dir->contents(), [qw< . .. real_file >], "Non-existent dir placeholder excluded from contents()", ); test_content_with_keywords( $dirname, [qw< . .. real_file >] ); # Once the dir placeholder becomes real, it should appear my $real_subdir = Test::MockFile->new_dir("$dirname/real_subdir"); is( $dir->contents(), [qw< . .. real_file real_subdir >], "Existing subdirectory included in contents()", ); } ); subtest( 'Scenario 6: Non-existent file mock before dir() does not make dir exist' => sub { my $dirname = $get_dirname->(); # Create a non-existent file mock BEFORE the dir mock my $file = Test::MockFile->file("$dirname/phantom"); # The dir should not appear to exist — the child is just a placeholder my $dir = Test::MockFile->dir($dirname); ok( !-d $dirname, "dir does not exist when only child is a non-existent file mock" ); # mkdir still works to bring it into existence ok( mkdir($dirname), "mkdir succeeds on the placeholder dir" ); ok( -d $dirname, "dir exists after mkdir" ); } ); subtest( 'Scenario 7: Existing file before dir() makes dir exist (regression)' => sub { my $dirname = $get_dirname->(); # Create an existing file mock BEFORE the dir mock my $file = Test::MockFile->file( "$dirname/real", 'content' ); # dir() should detect the existing child and set has_content my $dir = Test::MockFile->dir($dirname); ok( -d $dirname, "dir exists when child file has content" ); is( $dir->contents(), [qw< . .. real >], "Correct contents with existing child file", ); } ); done_testing(); Test-MockFile-0.039/t/chmod.t000644 000765 000024 00000023316 15157362227 017420 0ustar00todd.rinaldostaff000000 000000 #!/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 Errno qw/ENOENT/; 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' ); } ); subtest( 'File creation with non-default mode applies umask correctly' => sub { # With umask 0022, creating a file with mode 0644 should stay 0644 # (bits already clear). With the old XOR bug, 0644 ^ 0022 = 0666. my $file = Test::MockFile->file( '/umask_test/file', 'data', { mode => 0644 } ); my $expected = sprintf '%04o', 0644 & ~umask; is( sprintf( '%04o', ( stat '/umask_test/file' )[2] & 07777 ), $expected, "File with explicit mode 0644 gets $expected after umask", ); } ); subtest( 'chmod method ignores umask' => sub { my $file = Test::MockFile->file( '/chmod_umask/file', 'content' ); # Real chmod(2) ignores umask — setting 0755 should give exactly 0755 $file->chmod(0755); is( sprintf( '%04o', ( stat '/chmod_umask/file' )[2] & 07777 ), '0755', 'chmod(0755) gives exactly 0755 (umask not applied)', ); $file->chmod(0644); is( sprintf( '%04o', ( stat '/chmod_umask/file' )[2] & 07777 ), '0644', 'chmod(0644) gives exactly 0644 (umask not applied)', ); } ); subtest( 'mkdir with non-default mode applies umask correctly' => sub { # mkdir(path, 0700) with umask 0022 should give 0700 (bits already clear) # With the old XOR bug, 0700 ^ 0022 = 0722 my $dir = Test::MockFile->dir('/umask_mkdir'); my $expected = sprintf '%04o', 0700 & ~umask; ok( mkdir( '/umask_mkdir', 0700 ), 'mkdir with mode 0700' ); is( sprintf( '%04o', ( stat '/umask_mkdir' )[2] & 07777 ), $expected, "mkdir(0700) gives $expected after umask", ); } ); subtest( 'chmod masks mode to S_IFPERMS (high bits do not corrupt file type)' => sub { my $file = Test::MockFile->file( '/chmod_mask/file', 'data' ); my $dir = Test::MockFile->dir('/chmod_mask'); # Passing file type bits (e.g. S_IFREG=0100000) should not corrupt # the stored mode. CORE::chmod silently ignores bits above 07777. chmod 0100755, '/chmod_mask/file'; my $got_perms = ( stat '/chmod_mask/file' )[2] & 07777; is( sprintf( '%04o', $got_perms ), '0755', 'chmod with S_IFREG bits gives 0755, not corrupted mode', ); ok( -f '/chmod_mask/file', 'File type preserved after chmod with high bits' ); # Same test for directory chmod 0100700, '/chmod_mask'; my $dir_perms = ( stat '/chmod_mask' )[2] & 07777; is( sprintf( '%04o', $dir_perms ), '0700', 'chmod on dir with high bits gives 0700', ); ok( -d '/chmod_mask', 'Directory type preserved after chmod with high bits' ); } ); subtest( 'chmod with broken symlink in multi-file list does not confess' => sub { my $link = Test::MockFile->symlink( '/nonexistent_target', '/chmod_broken_link' ); my $file = Test::MockFile->file( '/chmod_real_file', 'content' ); # chmod on a mix of regular file + broken symlink should NOT die. # The broken symlink should silently fail with ENOENT, and the # regular file should succeed. my ( $result, $errno ); ok( lives { $result = chmod( 0755, '/chmod_broken_link', '/chmod_real_file' ); $errno = $! + 0 }, 'chmod with broken symlink + regular file does not confess', ); is( $result, 1, 'chmod returns 1 (one file changed)' ); is( $errno, ENOENT, 'errno set to ENOENT for the broken symlink' ); } ); subtest( 'chmod with only broken symlink' => sub { my $link = Test::MockFile->symlink( '/nowhere', '/chmod_only_broken' ); my ( $result, $errno ); ok( lives { $result = chmod( 0755, '/chmod_only_broken' ); $errno = $! + 0 }, 'chmod with only a broken symlink does not confess', ); is( $result, 0, 'chmod returns 0 (no files changed)' ); is( $errno, ENOENT, 'errno set to ENOENT' ); } ); done_testing(); exit; Test-MockFile-0.039/t/enoent_on_nonexistent.t000644 000765 000024 00000011422 15157362227 022743 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl -w # Regression test for Overload::FileCheck GH#13 # When a file is mocked as non-existent (undef contents), # -e should set $! to ENOENT, not EBADF. use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Errno qw/ENOENT EBADF ELOOP/; use Test::MockFile; subtest '-e on non-existent mock sets ENOENT' => sub { my $path = '/some/nonexistent/path'; my $mock = Test::MockFile->file( $path, undef ); $! = 0; my $exists = -e $path; ok( !$exists, '-e returns false for file mocked with undef contents' ); is( $! + 0, ENOENT, '$! is ENOENT (not EBADF) after -e on non-existent mock' ); }; subtest '-e on non-existent mock (no content arg)' => sub { my $path = '/another/missing/file'; my $mock = Test::MockFile->file($path); $! = 0; my $exists = -e $path; ok( !$exists, '-e returns false for file mocked without content' ); is( $! + 0, ENOENT, '$! is ENOENT after -e on file mocked without content' ); }; subtest '-f on non-existent mock sets ENOENT' => sub { my $path = '/mock/not/a/file'; my $mock = Test::MockFile->file( $path, undef ); $! = 0; my $is_file = -f $path; ok( !$is_file, '-f returns false for file mocked with undef contents' ); is( $! + 0, ENOENT, '$! is ENOENT after -f on non-existent mock' ); }; subtest '-d on non-existent mock sets ENOENT' => sub { my $path = '/mock/not/a/dir'; my $mock = Test::MockFile->dir($path); $! = 0; my $is_dir = -d $path; ok( !$is_dir, '-d returns false for non-existent dir mock' ); is( $! + 0, ENOENT, '$! is ENOENT after -d on non-existent dir mock' ); }; subtest 'stat on non-existent mock fails cleanly' => sub { my $path = '/mock/no/stat'; my $mock = Test::MockFile->file( $path, undef ); $! = 0; my @st = stat($path); is( scalar @st, 0, 'stat returns empty list for non-existent mock' ); # errno after stat() on non-existent mock depends on Overload::FileCheck's XS # cleanup behavior. The _check() Perl code sets ENOENT correctly, but the XS # FREETMPS/LEAVE in _overload_ft_stat() may clobber errno before returning. # File checks (-e, -f, etc.) are unaffected because _check_from_stat checks # array length rather than errno. See cpanel/Overload-FileCheck for the fix. todo 'Overload::FileCheck XS clobbers errno on stat failure path' => sub { is( $! + 0, ENOENT, '$! is ENOENT after stat on non-existent mock' ); }; }; subtest 'lstat on non-existent mock fails cleanly' => sub { my $path = '/mock/no/lstat'; my $mock = Test::MockFile->file( $path, undef ); $! = 0; my @st = lstat($path); is( scalar @st, 0, 'lstat returns empty list for non-existent mock' ); todo 'Overload::FileCheck XS clobbers errno on stat failure path' => sub { is( $! + 0, ENOENT, '$! is ENOENT after lstat on non-existent mock' ); }; }; subtest '-e succeeds for existing mock' => sub { my $path = '/mock/exists'; my $mock = Test::MockFile->file( $path, 'content' ); $! = 0; my $exists = -e $path; ok( $exists, '-e returns true for file mocked with content' ); is( $! + 0, 0, '$! is not set after successful -e' ); }; subtest '-e on broken symlink sets ENOENT (not ELOOP)' => sub { # Symlink to a target with no mock = broken symlink my $link = Test::MockFile->symlink( '/nonexistent_target', '/broken_stat_link' ); $! = 0; my $exists = -e '/broken_stat_link'; ok( !$exists, '-e returns false for broken symlink' ); is( $! + 0, ENOENT, '$! is ENOENT (not ELOOP) for broken symlink' ); }; subtest 'stat on broken symlink sets ENOENT' => sub { my $link = Test::MockFile->symlink( '/no_such_target', '/broken_stat_link2' ); $! = 0; my @st = stat('/broken_stat_link2'); is( scalar @st, 0, 'stat returns empty list for broken symlink' ); todo 'Overload::FileCheck XS clobbers errno on stat failure path' => sub { is( $! + 0, ENOENT, '$! is ENOENT after stat on broken symlink' ); }; }; subtest '-e on circular symlink sets ELOOP' => sub { # Two symlinks pointing at each other = circular my $a = Test::MockFile->symlink( '/circ_b', '/circ_a' ); my $b = Test::MockFile->symlink( '/circ_a', '/circ_b' ); $! = 0; my $exists = -e '/circ_a'; ok( !$exists, '-e returns false for circular symlink' ); is( $! + 0, ELOOP, '$! is ELOOP for circular symlink' ); }; subtest 'lstat on broken symlink succeeds (reports the link itself)' => sub { my $link = Test::MockFile->symlink( '/nowhere', '/broken_lstat_link' ); $! = 0; my @st = lstat('/broken_lstat_link'); ok( scalar @st > 0, 'lstat returns stats for broken symlink (the link itself)' ); is( $! + 0, 0, '$! is not set after successful lstat on broken symlink' ); }; done_testing(); Test-MockFile-0.039/t/readline.t000644 000765 000024 00000014263 15157362227 020112 0ustar00todd.rinaldostaff000000 000000 #!/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; { my $fhs = $Test::MockFile::files_being_mocked{$filename}->{'fhs'}; my @defined_fhs = $fhs ? grep { defined $_ } @{$fhs} : (); ok( !@defined_fhs, "file handle clears from files_being_mocked hash on close" ) or diag( "fhs has " . scalar(@defined_fhs) . " defined entries after close" ); } 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." ); } note "-------------- readline on write-only handle --------------"; { my $baz = Test::MockFile->file( '/readline_writeonly', "secret data\n" ); open( my $wfh, '>', '/readline_writeonly' ) or die "open: $!"; # Scalar context { my $warn_msg; local $SIG{__WARN__} = sub { $warn_msg = shift }; my $line = readline($wfh); ok( !defined $line, 'readline on write-only handle returns undef' ); like( $warn_msg, qr{opened only for output}, 'readline on write-only handle warns' ); } # List context { my $warn_msg; local $SIG{__WARN__} = sub { $warn_msg = shift }; my @lines = <$wfh>; is( scalar @lines, 0, 'readline in list context on write-only handle returns empty list' ); like( $warn_msg, qr{opened only for output}, 'readline list context on write-only handle warns' ); } close $wfh; } note "-------------- getc on write-only handle --------------"; { my $baz = Test::MockFile->file( '/getc_writeonly', "XY" ); open( my $wfh, '>', '/getc_writeonly' ) or die "open: $!"; my $warn_msg; local $SIG{__WARN__} = sub { $warn_msg = shift }; my $ch = getc($wfh); ok( !defined $ch, 'getc on write-only handle returns undef' ); like( $warn_msg, qr{opened only for output}, 'getc on write-only handle warns' ); close $wfh; } done_testing(); exit; Test-MockFile-0.039/t/globbing.t000644 000765 000024 00000004260 15157362227 020106 0ustar00todd.rinaldostaff000000 000000 use 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.039/t/file_passthrough.t000644 000765 000024 00000013422 15157362227 021671 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; # Create temp dir BEFORE loading Test::MockFile to avoid # File::Temp's internal stat/chmod hitting our overrides. my $dir; BEGIN { $dir = "/tmp/tmf_passthrough_$$"; CORE::mkdir( $dir, 0700 ) or die "Cannot create $dir: $!"; } # Strict mode is the default — file_passthrough must work with it. use Test::MockFile; subtest( 'file_passthrough returns a mock object' => sub { my $file = "$dir/basic.txt"; my $mock = Test::MockFile->file_passthrough($file); isa_ok( $mock, ['Test::MockFile'], 'returns a Test::MockFile object' ); } ); subtest( 'file_passthrough delegates to real filesystem' => sub { my $file = "$dir/delegate.txt"; my $mock = Test::MockFile->file_passthrough($file); # File doesn't exist yet on real FS ok( !-e $file, 'file does not exist yet on real FS' ); # Create the real file via Perl open (goes through CORE::GLOBAL::open override) ok( open( my $fh, '>', $file ), 'can open file for writing via override' ); print {$fh} "hello world\n"; close $fh; # Perl-level checks should see the real file ok( -e $file, '-e sees the real file' ); ok( -f $file, '-f sees the real file' ); ok( !-d $file, '-d correctly returns false' ); my $size = -s $file; is( $size, 12, '-s returns correct size' ); # Can read back via Perl open ok( open( my $fh2, '<', $file ), 'can open file for reading via override' ); my $content = <$fh2>; close $fh2; is( $content, "hello world\n", 'content matches what was written' ); # stat works my @stat = stat($file); ok( scalar @stat, 'stat returns data' ); is( $stat[7], 12, 'stat size is correct' ); # unlink works ok( unlink($file), 'can unlink via override' ); ok( !-e $file, 'file is gone after unlink' ); } ); subtest( 'file_passthrough coexists with regular mocks' => sub { my $mocked_file = "$dir/regular.txt"; my $pass_file = "$dir/pass.txt"; my $regular_mock = Test::MockFile->file( $mocked_file, "mocked content" ); my $pass_mock = Test::MockFile->file_passthrough($pass_file); # Regular mock works as expected ok( -f $mocked_file, 'regular mock file exists in mock world' ); ok( open( my $fh, '<', $mocked_file ), 'can open regular mock' ); my $content = <$fh>; close $fh; is( $content, "mocked content", 'regular mock has mocked content' ); # Passthrough falls through to real FS ok( !-e $pass_file, 'passthrough file does not exist on disk yet' ); # Create real file for passthrough ok( open( my $fh2, '>', $pass_file ), 'can write to passthrough path' ); print {$fh2} "real content\n"; close $fh2; ok( -f $pass_file, 'passthrough file now exists on disk' ); } ); subtest( 'file_passthrough strict rule cleanup on scope exit' => sub { my $file = "$dir/scoped.txt"; { my $mock = Test::MockFile->file_passthrough($file); # Should be able to access the file without strict mode dying ok( !-e $file, 'file does not exist (no strict violation)' ); # Create it ok( open( my $fh, '>', $file ), 'can create file in passthrough scope' ); print {$fh} "temporary\n"; close $fh; ok( -f $file, 'file exists while passthrough is alive' ); # Clean up the real file before mock goes out of scope CORE::unlink($file); } # After scope exit, accessing the unmocked file in strict mode should die like( dies { -e $file }, qr/unmocked file/, 'strict mode violation after passthrough goes out of scope', ); } ); subtest( 'file_passthrough with glob pattern matches multiple files' => sub { my $base = "$dir/mydb.sqlite"; # Register all SQLite auxiliary files with a single glob my $mock = Test::MockFile->file_passthrough("$dir/mydb.sqlite*"); # Create real files via CORE:: (simulating what XS code like DBD::SQLite does) CORE::open( my $fh1, '>', $base ) or die "Cannot create $base: $!"; print {$fh1} "db\n"; CORE::close($fh1); CORE::open( my $fh2, '>', "$base-wal" ) or die "Cannot create $base-wal: $!"; print {$fh2} "wal\n"; CORE::close($fh2); CORE::open( my $fh3, '>', "$base-shm" ) or die "Cannot create $base-shm: $!"; print {$fh3} "shm\n"; CORE::close($fh3); # Perl-level checks should all pass through to real FS without strict violation ok( -f $base, 'main db file visible via -f' ); ok( -f "$base-wal", 'wal file visible via -f' ); ok( -f "$base-shm", 'shm file visible via -f' ); my @st = stat($base); ok( scalar @st, 'stat works on main db file' ); CORE::unlink $base, "$base-wal", "$base-shm"; } ); subtest( 'file_passthrough rejects undefined path' => sub { like( dies { Test::MockFile->file_passthrough(undef) }, qr/No file provided/, 'dies with undef path', ); like( dies { Test::MockFile->file_passthrough('') }, qr/No file provided/, 'dies with empty path', ); } ); done_testing(); # Cleanup — use CORE:: to bypass Test::MockFile strict mode END { if ( defined $dir ) { CORE::unlink "$dir/$_" for qw(basic.txt delegate.txt regular.txt pass.txt scoped.txt mydb.sqlite mydb.sqlite-wal mydb.sqlite-shm); CORE::rmdir $dir; } } Test-MockFile-0.039/t/strict-rules.t000644 000765 000024 00000006451 15157362227 020767 0ustar00todd.rinaldostaff000000 000000 #!/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.039/t/chmod-chown-passthrough.t000644 000765 000024 00000006300 15157362227 023073 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; # Create temp files BEFORE loading Test::MockFile to avoid # File::Temp's internal stat/chmod hitting our overrides on older Perls. my $dir; my $euid; my $egid; BEGIN { $euid = $>; $egid = int $); $dir = "/tmp/tmf_passthrough_$$"; CORE::mkdir($dir, 0700) or die "Cannot create $dir: $!"; } use Test::MockFile qw< nostrict >; # These tests exercise the passthrough path in __chmod and __chown # where all files are unmocked and must be forwarded to CORE::chmod/chown # with the correct arguments (mode for chmod, uid+gid for chown). subtest( 'chmod passthrough to real filesystem' => sub { my $file = "$dir/chmod_test"; CORE::open( my $fh, '>', $file ) or die "Cannot create $file: $!"; print {$fh} "test content\n"; close $fh; # Set to 0644 first via the override (passthrough since not mocked) my $result = chmod 0644, $file; is( $result, 1, 'chmod returned 1 (one file changed)' ); my $perms = ( CORE::stat($file) )[2] & 07777; is( sprintf( '%04o', $perms ), '0644', 'chmod passthrough correctly applied mode 0644', ); # Change to 0600 $result = chmod 0600, $file; is( $result, 1, 'chmod returned 1 for mode change to 0600' ); $perms = ( CORE::stat($file) )[2] & 07777; is( sprintf( '%04o', $perms ), '0600', 'chmod passthrough correctly applied mode 0600', ); # Multiple files my $file2 = "$dir/chmod_test2"; CORE::open( my $fh2, '>', $file2 ) or die "Cannot create $file2: $!"; print {$fh2} "test2\n"; close $fh2; $result = chmod 0755, $file, $file2; is( $result, 2, 'chmod returned 2 (two files changed)' ); for my $f ( $file, $file2 ) { $perms = ( CORE::stat($f) )[2] & 07777; is( sprintf( '%04o', $perms ), '0755', "chmod passthrough correctly applied mode 0755 to $f", ); } } ); subtest( 'chown passthrough to real filesystem' => sub { my $file = "$dir/chown_test"; CORE::open( my $fh, '>', $file ) or die "Cannot create $file: $!"; print {$fh} "test content\n"; close $fh; # chown -1, -1 means "keep as is" - should always succeed my $result = chown -1, -1, $file; is( $result, 1, 'chown -1, -1 passthrough returned 1' ); my ( $uid, $gid ) = ( CORE::stat($file) )[ 4, 5 ]; is( $uid, $euid, 'File UID unchanged after chown -1, -1' ); # chown to current user/group - should always succeed $result = chown $euid, $egid, $file; is( $result, 1, 'chown to current user/group passthrough returned 1' ); ( $uid, $gid ) = ( CORE::stat($file) )[ 4, 5 ]; is( $uid, $euid, 'File UID correct after chown' ); is( $gid, $egid, 'File GID correct after chown' ); } ); done_testing(); # Cleanup END { if ( defined $dir && -d $dir ) { CORE::unlink glob("$dir/*"); CORE::rmdir $dir; } } Test-MockFile-0.039/t/fileno.t000644 000765 000024 00000001021 15157362227 017567 0ustar00todd.rinaldostaff000000 000000 #!/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.039/t/open_strict.t000644 000765 000024 00000001037 15157362227 020653 0ustar00todd.rinaldostaff000000 000000 #!/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.039/t/readline_modes.t000644 000765 000024 00000022760 15157362227 021302 0ustar00todd.rinaldostaff000000 000000 #!/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 $filename = '/tmp/readline_modes_test'; # ============================================================ # Slurp mode: $/ = undef # ============================================================ note "-------------- SLURP MODE (\$/ = undef) --------------"; { note "Slurp from beginning of file"; my $mock = Test::MockFile->file( $filename, "line1\nline2\nline3\n" ); open( my $fh, '<', $filename ) or die "open: $!"; my $content = do { local $/; <$fh> }; is( $content, "line1\nline2\nline3\n", "Slurp from tell=0 returns entire contents" ); is( eof($fh), 1, "EOF after slurp" ); close $fh; } { note "Slurp from non-zero tell position"; my $mock = Test::MockFile->file( $filename, "ABCDEFGHIJ" ); open( my $fh, '<', $filename ) or die "open: $!"; read( $fh, my $buf, 4 ); # Read "ABCD", tell is now 4 is( $buf, "ABCD", "Read first 4 bytes" ); my $rest = do { local $/; <$fh> }; is( $rest, "EFGHIJ", "Slurp from tell=4 returns remainder" ); is( eof($fh), 1, "EOF after partial slurp" ); close $fh; } { note "Slurp empty file"; my $mock = Test::MockFile->file( $filename, "" ); open( my $fh, '<', $filename ) or die "open: $!"; my $content = do { local $/; <$fh> }; is( $content, undef, "Slurp on empty file returns undef" ); close $fh; } { note "Slurp in list context"; my $mock = Test::MockFile->file( $filename, "all\nin\none\n" ); open( my $fh, '<', $filename ) or die "open: $!"; my @lines = do { local $/; <$fh> }; is( \@lines, ["all\nin\none\n"], "Slurp in list context returns single element" ); close $fh; } # ============================================================ # Fixed-record mode: $/ = \N # ============================================================ note "-------------- FIXED-RECORD MODE (\$/ = \\N) --------------"; { note "Read in 5-byte records"; my $mock = Test::MockFile->file( $filename, "ABCDEFGHIJKLM" ); open( my $fh, '<', $filename ) or die "open: $!"; local $/ = \5; my $r1 = <$fh>; my $r2 = <$fh>; my $r3 = <$fh>; # Only 3 bytes left my $r4 = <$fh>; # EOF is( $r1, "ABCDE", "First 5-byte record" ); is( $r2, "FGHIJ", "Second 5-byte record" ); is( $r3, "KLM", "Third record (partial, 3 bytes left)" ); is( $r4, undef, "Fourth read returns undef (EOF)" ); close $fh; } { note "Fixed-record in list context"; my $mock = Test::MockFile->file( $filename, "ABCDEFGH" ); open( my $fh, '<', $filename ) or die "open: $!"; local $/ = \3; my @records = <$fh>; is( \@records, [ "ABC", "DEF", "GH" ], "List context returns all fixed-size records" ); close $fh; } { note "Fixed-record with 1-byte records"; my $mock = Test::MockFile->file( $filename, "XYZ" ); open( my $fh, '<', $filename ) or die "open: $!"; local $/ = \1; my @chars = <$fh>; is( \@chars, [ "X", "Y", "Z" ], "1-byte records return individual characters" ); close $fh; } { note "Fixed-record larger than file"; my $mock = Test::MockFile->file( $filename, "small" ); open( my $fh, '<', $filename ) or die "open: $!"; local $/ = \100; my $r1 = <$fh>; my $r2 = <$fh>; is( $r1, "small", "Record larger than file returns all contents" ); is( $r2, undef, "Second read returns undef" ); close $fh; } # ============================================================ # Paragraph mode: $/ = '' # ============================================================ note "-------------- PARAGRAPH MODE (\$/ = '') --------------"; { note "Two paragraphs separated by blank line"; my $mock = Test::MockFile->file( $filename, "para1 line1\npara1 line2\n\npara2 line1\n" ); open( my $fh, '<', $filename ) or die "open: $!"; local $/ = ''; my $p1 = <$fh>; my $p2 = <$fh>; my $p3 = <$fh>; is( $p1, "para1 line1\npara1 line2\n\n", "First paragraph with collapsed \\n\\n" ); is( $p2, "para2 line1\n", "Second paragraph (last, no trailing blank)" ); is( $p3, undef, "Third read returns undef (EOF)" ); close $fh; } { note "Multiple blank lines between paragraphs (collapsed)"; my $mock = Test::MockFile->file( $filename, "first\n\n\n\nsecond\n" ); open( my $fh, '<', $filename ) or die "open: $!"; local $/ = ''; my $p1 = <$fh>; my $p2 = <$fh>; is( $p1, "first\n\n", "First paragraph with collapsed separator" ); is( $p2, "second\n", "Second paragraph after multiple blank lines" ); close $fh; } { note "Leading blank lines are skipped"; my $mock = Test::MockFile->file( $filename, "\n\n\nhello\n\nworld\n" ); open( my $fh, '<', $filename ) or die "open: $!"; local $/ = ''; my $p1 = <$fh>; my $p2 = <$fh>; my $p3 = <$fh>; is( $p1, "hello\n\n", "First paragraph (leading blanks skipped)" ); is( $p2, "world\n", "Second paragraph" ); is( $p3, undef, "EOF" ); close $fh; } { note "Single paragraph, no blank lines"; my $mock = Test::MockFile->file( $filename, "just one\nparagraph\n" ); open( my $fh, '<', $filename ) or die "open: $!"; local $/ = ''; my $p1 = <$fh>; my $p2 = <$fh>; is( $p1, "just one\nparagraph\n", "Single paragraph returned whole" ); is( $p2, undef, "EOF" ); close $fh; } { note "Paragraph mode in list context"; my $mock = Test::MockFile->file( $filename, "p1\n\np2\n\np3\n" ); open( my $fh, '<', $filename ) or die "open: $!"; local $/ = ''; my @paras = <$fh>; is( \@paras, [ "p1\n\n", "p2\n\n", "p3\n" ], "List context returns all paragraphs" ); close $fh; } { note "File is only blank lines"; my $mock = Test::MockFile->file( $filename, "\n\n\n" ); open( my $fh, '<', $filename ) or die "open: $!"; local $/ = ''; my $p1 = <$fh>; is( $p1, undef, "File with only newlines returns undef in paragraph mode" ); close $fh; } { note "Paragraph without trailing newline"; my $mock = Test::MockFile->file( $filename, "abc\n\ndef" ); open( my $fh, '<', $filename ) or die "open: $!"; local $/ = ''; my $p1 = <$fh>; my $p2 = <$fh>; is( $p1, "abc\n\n", "First paragraph ends with collapsed \\n\\n" ); is( $p2, "def", "Last paragraph without trailing newline" ); close $fh; } # ============================================================ # Custom multi-character record separator # ============================================================ note "-------------- CUSTOM SEPARATOR (\$/ = multi-char) --------------"; { note "Multi-character record separator"; my $mock = Test::MockFile->file( $filename, "part1::part2::part3" ); open( my $fh, '<', $filename ) or die "open: $!"; local $/ = '::'; my $r1 = <$fh>; my $r2 = <$fh>; my $r3 = <$fh>; my $r4 = <$fh>; is( $r1, "part1::", "First record with :: separator" ); is( $r2, "part2::", "Second record" ); is( $r3, "part3", "Third record (no trailing separator)" ); is( $r4, undef, "EOF" ); close $fh; } { note "Custom single-char separator (not newline)"; my $mock = Test::MockFile->file( $filename, "a,b,c,d" ); open( my $fh, '<', $filename ) or die "open: $!"; local $/ = ','; my @parts = <$fh>; is( \@parts, [ "a,", "b,", "c,", "d" ], "Comma-separated reading" ); close $fh; } # ============================================================ # GETC # ============================================================ note "-------------- GETC --------------"; { note "getc reads one character at a time"; my $mock = Test::MockFile->file( $filename, "Hello" ); open( my $fh, '<', $filename ) or die "open: $!"; is( getc($fh), 'H', "getc 1st char" ); is( getc($fh), 'e', "getc 2nd char" ); is( getc($fh), 'l', "getc 3rd char" ); is( getc($fh), 'l', "getc 4th char" ); is( getc($fh), 'o', "getc 5th char" ); is( getc($fh), undef, "getc at EOF returns undef" ); close $fh; } { note "getc after partial read"; my $mock = Test::MockFile->file( $filename, "ABCDEF" ); open( my $fh, '<', $filename ) or die "open: $!"; read( $fh, my $buf, 3 ); is( $buf, "ABC", "Read first 3 bytes" ); is( getc($fh), 'D', "getc after read returns next char" ); is( getc($fh), 'E', "getc continues" ); close $fh; } { note "getc on empty file"; my $mock = Test::MockFile->file( $filename, "" ); open( my $fh, '<', $filename ) or die "open: $!"; is( getc($fh), undef, "getc on empty file returns undef" ); close $fh; } # ============================================================ # Edge cases: interaction between seek and readline modes # ============================================================ note "-------------- SEEK + READLINE INTERACTIONS --------------"; { note "Seek then slurp"; my $mock = Test::MockFile->file( $filename, "0123456789" ); open( my $fh, '<', $filename ) or die "open: $!"; seek( $fh, 5, 0 ); my $rest = do { local $/; <$fh> }; is( $rest, "56789", "Slurp after seek(5) returns remainder" ); close $fh; } { note "Seek then fixed-record"; my $mock = Test::MockFile->file( $filename, "ABCDEFGHIJ" ); open( my $fh, '<', $filename ) or die "open: $!"; seek( $fh, 3, 0 ); local $/ = \4; my $r1 = <$fh>; my $r2 = <$fh>; is( $r1, "DEFG", "Fixed record after seek" ); is( $r2, "HIJ", "Partial record at end" ); close $fh; } done_testing(); exit; Test-MockFile-0.039/t/multi_handle.t000644 000765 000024 00000006562 15157362227 020777 0ustar00todd.rinaldostaff000000 000000 #!/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 >; note "-------------- Two read handles to the same file (#27) --------------"; { my $mock = Test::MockFile->file( '/fake/multi', "line1\nline2\nline3\n" ); ok( open( my $fh1, '<', '/fake/multi' ), "open first read handle" ); ok( open( my $fh2, '<', '/fake/multi' ), "open second read handle" ); is( <$fh1>, "line1\n", "fh1 reads line 1" ); is( <$fh1>, "line2\n", "fh1 reads line 2" ); # fh2 should start at position 0, independent of fh1 is( <$fh2>, "line1\n", "fh2 reads line 1 independently" ); is( <$fh1>, "line3\n", "fh1 reads line 3" ); is( <$fh2>, "line2\n", "fh2 reads line 2 independently" ); close $fh1; # fh2 should still work after fh1 is closed is( <$fh2>, "line3\n", "fh2 reads line 3 after fh1 is closed" ); ok( eof($fh2), "fh2 is at EOF" ); close $fh2; } note "-------------- Read + write handles to the same file (#27) --------------"; { my $mock = Test::MockFile->file( '/fake/rw', "original\n" ); ok( open( my $fhr, '<', '/fake/rw' ), "open read handle" ); ok( open( my $fhw, '>>', '/fake/rw' ), "open append handle" ); is( <$fhr>, "original\n", "read handle sees original content" ); print {$fhw} "appended\n"; # Read handle should now see the appended content (shared contents) is( <$fhr>, "appended\n", "read handle sees appended content" ); close $fhw; close $fhr; is( $mock->contents(), "original\nappended\n", "file contents after both handles closed" ); } note "-------------- fhs tracking cleanup (#27) --------------"; { my $mock = Test::MockFile->file( '/fake/track', "data\n" ); my $path = '/fake/track'; # Before any open, fhs should be empty or nonexistent ok( !$Test::MockFile::files_being_mocked{$path}->{'fhs'} || !grep { defined $_ } @{ $Test::MockFile::files_being_mocked{$path}->{'fhs'} }, "no open handles before open" ); open( my $fh1, '<', $path ) or die $!; my $fhs = $Test::MockFile::files_being_mocked{$path}->{'fhs'}; is( scalar( grep { defined $_ } @{$fhs} ), 1, "one handle tracked after first open" ); open( my $fh2, '<', $path ) or die $!; $fhs = $Test::MockFile::files_being_mocked{$path}->{'fhs'}; is( scalar( grep { defined $_ } @{$fhs} ), 2, "two handles tracked after second open" ); close $fh1; $fhs = $Test::MockFile::files_being_mocked{$path}->{'fhs'}; is( scalar( grep { defined $_ } @{$fhs} ), 1, "one handle tracked after closing first" ); close $fh2; $fhs = $Test::MockFile::files_being_mocked{$path}->{'fhs'}; is( scalar( grep { defined $_ } @{$fhs} ), 0, "zero handles tracked after closing both" ); } note "-------------- Sysopen multiple handles (#27) --------------"; { use Fcntl; my $mock = Test::MockFile->file( '/fake/sysopen', "sysdata\n" ); ok( sysopen( my $fh1, '/fake/sysopen', O_RDONLY ), "sysopen first handle" ); ok( sysopen( my $fh2, '/fake/sysopen', O_RDONLY ), "sysopen second handle" ); my $buf1; my $buf2; sysread( $fh1, $buf1, 4 ); sysread( $fh2, $buf2, 4 ); is( $buf1, "sysd", "sysread from first handle" ); is( $buf2, "sysd", "sysread from second handle (independent position)" ); close $fh1; close $fh2; } done_testing(); Test-MockFile-0.039/t/cwd_abs_path.t000644 000765 000024 00000016502 15157362227 020743 0ustar00todd.rinaldostaff000000 000000 #!/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 >; # Load Cwd AFTER Test::MockFile so imported functions get our override use Cwd (); use Cwd qw( abs_path realpath ); # ========================================================================== # Basic: mocked symlink resolved by Cwd::abs_path (GH #139) # ========================================================================== { my $mock_link = Test::MockFile->symlink( '/different', '/dest' ); is( readlink('/dest'), '/different', 'readlink returns mocked target' ); is( Cwd::abs_path('/dest'), '/different', 'Cwd::abs_path resolves mocked symlink' ); is( Cwd::realpath('/dest'), '/different', 'Cwd::realpath resolves mocked symlink' ); is( Cwd::fast_abs_path('/dest'), '/different', 'Cwd::fast_abs_path resolves mocked symlink' ); } # ========================================================================== # Non-mocked paths delegate to original Cwd::abs_path # ========================================================================== { my $cwd = Cwd::getcwd(); is( Cwd::abs_path('.'), $cwd, 'abs_path(.) returns cwd when nothing is mocked' ); } # ========================================================================== # Chained symlinks: a -> b -> c # ========================================================================== { my $mock_c = Test::MockFile->file( '/chain_target', 'content' ); my $mock_b = Test::MockFile->symlink( '/chain_target', '/chain_mid' ); my $mock_a = Test::MockFile->symlink( '/chain_mid', '/chain_start' ); is( Cwd::abs_path('/chain_start'), '/chain_target', 'abs_path follows chained symlinks' ); } # ========================================================================== # Intermediate symlink in path: /link/subdir/file where /link -> /real # ========================================================================== { my $mock_dir = Test::MockFile->dir('/real'); my $mock_link = Test::MockFile->symlink( '/real', '/link' ); my $mock_file = Test::MockFile->file( '/real/subdir/file.txt', 'data' ); is( Cwd::abs_path('/link/subdir/file.txt'), '/real/subdir/file.txt', 'abs_path resolves intermediate symlink in path' ); } # ========================================================================== # Relative symlink target # ========================================================================== { my $mock_target = Test::MockFile->file( '/parent/actual', 'hello' ); my $mock_link = Test::MockFile->symlink( 'actual', '/parent/link' ); is( Cwd::abs_path('/parent/link'), '/parent/actual', 'abs_path resolves relative symlink target' ); } # ========================================================================== # Path with .. component # ========================================================================== { my $mock_file = Test::MockFile->file( '/a/file.txt', 'data' ); is( Cwd::abs_path('/a/b/../file.txt'), '/a/file.txt', 'abs_path resolves .. in path with mocked file' ); } # ========================================================================== # Circular symlinks return undef and set ELOOP # ========================================================================== { my $mock_a = Test::MockFile->symlink( '/circ_b', '/circ_a' ); my $mock_b = Test::MockFile->symlink( '/circ_a', '/circ_b' ); local $!; my $result = Cwd::abs_path('/circ_a'); my $err = $! + 0; is( $result, undef, 'abs_path returns undef for circular symlinks' ); use Errno qw/ELOOP/; is( $err, ELOOP, '$! is ELOOP for circular symlinks' ); } # ========================================================================== # Mocked regular file (not symlink) is resolved correctly # ========================================================================== { my $mock_file = Test::MockFile->file( '/simple/path', 'content' ); is( Cwd::abs_path('/simple/path'), '/simple/path', 'abs_path returns path for mocked regular file' ); } # ========================================================================== # abs_path with no argument uses current directory # ========================================================================== { my $cwd = Cwd::getcwd(); is( Cwd::abs_path(), $cwd, 'abs_path() with no args returns cwd' ); } # ========================================================================== # Symlink to absolute path with deeper nesting # ========================================================================== { my $mock_link = Test::MockFile->symlink( '/target/deep/path', '/shortcut' ); my $mock_file = Test::MockFile->file( '/target/deep/path/file', 'data' ); is( Cwd::abs_path('/shortcut/file'), '/target/deep/path/file', 'abs_path follows symlink into deeper target path' ); } # ========================================================================== # Imported abs_path() also works (not just Cwd::abs_path) # ========================================================================== { my $mock_link = Test::MockFile->symlink( '/imported_target', '/imported_test' ); is( abs_path('/imported_test'), '/imported_target', 'imported abs_path() resolves mocked symlink' ); is( realpath('/imported_test'), '/imported_target', 'imported realpath() resolves mocked symlink' ); } # ========================================================================== # Symlink target overrides real filesystem (exact scenario from GH #139) # ========================================================================== { # Even if /dest is a real symlink on disk pointing to /src, # when mocked, Cwd::abs_path should see the mocked target. my $mock = Test::MockFile->symlink( '/different', '/mock139_dest' ); is( readlink('/mock139_dest'), '/different', 'GH #139: readlink sees mocked target' ); is( Cwd::abs_path('/mock139_dest'), '/different', 'GH #139: Cwd::abs_path sees mocked target' ); } # ========================================================================== # Relative symlink with .. in target # ========================================================================== { my $mock_target = Test::MockFile->file( '/base/real_file', 'data' ); my $mock_link = Test::MockFile->symlink( '../base/real_file', '/other/link' ); is( Cwd::abs_path('/other/link'), '/base/real_file', 'abs_path resolves relative symlink with .. in target' ); } # ========================================================================== # Mock goes out of scope — abs_path should fall through to original # ========================================================================== { { my $mock_link = Test::MockFile->symlink( '/mocked_target', '/scoped_link' ); is( Cwd::abs_path('/scoped_link'), '/mocked_target', 'abs_path works while mock is in scope' ); } # After mock goes out of scope, /scoped_link is no longer mocked. # abs_path should delegate to the original (which may return undef # for a non-existent path, depending on the system). my $result = Cwd::abs_path('/scoped_link'); # The path likely doesn't exist on the real filesystem ok( !defined $result || $result ne '/mocked_target', 'abs_path does not return mocked target after mock goes out of scope' ); } done_testing(); exit 0; Test-MockFile-0.039/t/autodie_all_functions.t000644 000765 000024 00000024220 15160070345 022662 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl # Test autodie exception throwing for all CORE override functions. # Covers issue #264: autodie exceptions were only thrown for open/sysopen, # leaving 12 other functions silently returning false under autodie. use strict; use warnings; use Test::More; # Skip if autodie is not available BEGIN { eval { require autodie }; if ($@) { plan skip_all => 'autodie not available'; } } use autodie qw(opendir closedir unlink readlink mkdir rmdir rename link symlink truncate chmod chown utime); use Test::MockFile qw(nostrict); SKIP: { # Helper to verify autodie exception my $check_autodie = sub { my ($err, $func_name, $test_label) = @_; ok( defined $err, "$test_label: exception thrown" ); if ( eval { require autodie::exception; 1 } ) { isa_ok( $err, 'autodie::exception', "$test_label: is autodie::exception" ); like( $err->function, qr/\Q$func_name\E/, "$test_label: function is $func_name" ); } }; # ---- opendir ---- subtest 'opendir dies on non-existent mocked dir' => sub { my $dir = Test::MockFile->dir("/ad_opendir_noexist_$$"); my $died = !eval { opendir( my $dh, "/ad_opendir_noexist_$$" ); 1; }; my $err = $@; ok( $died, "opendir dies on non-existent dir" ); $check_autodie->( $err, 'opendir', 'opendir ENOENT' ); }; subtest 'opendir dies on ENOTDIR' => sub { my $file = Test::MockFile->file( "/ad_opendir_notdir_$$", "content" ); my $died = !eval { opendir( my $dh, "/ad_opendir_notdir_$$" ); 1; }; my $err = $@; ok( $died, "opendir dies on regular file (ENOTDIR)" ); $check_autodie->( $err, 'opendir', 'opendir ENOTDIR' ); }; # ---- closedir ---- subtest 'closedir dies on double-close' => sub { my $dir = Test::MockFile->new_dir("/ad_closedir_$$"); opendir( my $dh, "/ad_closedir_$$" ); closedir($dh); # Second close should die my $died = !eval { no warnings 'io'; # suppress closedir warning closedir($dh); 1; }; my $err = $@; ok( $died, "closedir dies on already-closed handle" ); $check_autodie->( $err, 'closedir', 'closedir EBADF' ); }; # ---- unlink ---- subtest 'unlink dies on non-existent mocked file' => sub { my $file = Test::MockFile->file("/ad_unlink_noexist_$$"); my $died = !eval { unlink("/ad_unlink_noexist_$$"); 1; }; my $err = $@; ok( $died, "unlink dies on non-existent mocked file" ); $check_autodie->( $err, 'unlink', 'unlink ENOENT' ); }; # ---- readlink ---- subtest 'readlink dies on non-existent mocked path' => sub { my $file = Test::MockFile->file("/ad_readlink_noexist_$$"); my $died = !eval { readlink("/ad_readlink_noexist_$$"); 1; }; my $err = $@; ok( $died, "readlink dies on non-existent mock" ); $check_autodie->( $err, 'readlink', 'readlink ENOENT' ); }; subtest 'readlink dies on regular file (EINVAL)' => sub { my $file = Test::MockFile->file( "/ad_readlink_file_$$", "data" ); my $died = !eval { readlink("/ad_readlink_file_$$"); 1; }; my $err = $@; ok( $died, "readlink dies on non-symlink" ); $check_autodie->( $err, 'readlink', 'readlink EINVAL' ); }; # ---- symlink ---- subtest 'symlink dies when target exists (EEXIST)' => sub { my $link = Test::MockFile->file( "/ad_symlink_exists_$$", "data" ); my $died = !eval { symlink( '/some/target', "/ad_symlink_exists_$$" ); 1; }; my $err = $@; ok( $died, "symlink dies when link already exists" ); $check_autodie->( $err, 'symlink', 'symlink EEXIST' ); }; # ---- link ---- subtest 'link dies when source does not exist (ENOENT)' => sub { my $src = Test::MockFile->file("/ad_link_nosrc_$$"); my $dst = Test::MockFile->file("/ad_link_nodst_$$"); my $died = !eval { link( "/ad_link_nosrc_$$", "/ad_link_nodst_$$" ); 1; }; my $err = $@; ok( $died, "link dies when source doesn't exist" ); $check_autodie->( $err, 'link', 'link ENOENT' ); }; subtest 'link dies when destination exists (EEXIST)' => sub { my $src = Test::MockFile->file( "/ad_link_src_$$", "data" ); my $dst = Test::MockFile->file( "/ad_link_dstx_$$", "exists" ); my $died = !eval { link( "/ad_link_src_$$", "/ad_link_dstx_$$" ); 1; }; my $err = $@; ok( $died, "link dies when dest already exists" ); $check_autodie->( $err, 'link', 'link EEXIST' ); }; # ---- mkdir ---- subtest 'mkdir dies when dir already exists (EEXIST)' => sub { my $dir = Test::MockFile->new_dir("/ad_mkdir_exists_$$"); my $died = !eval { mkdir("/ad_mkdir_exists_$$"); 1; }; my $err = $@; ok( $died, "mkdir dies on existing dir" ); $check_autodie->( $err, 'mkdir', 'mkdir EEXIST' ); }; # ---- rmdir ---- subtest 'rmdir dies on non-existent dir (ENOENT)' => sub { my $dir = Test::MockFile->dir("/ad_rmdir_noexist_$$"); my $died = !eval { rmdir("/ad_rmdir_noexist_$$"); 1; }; my $err = $@; ok( $died, "rmdir dies on non-existent dir" ); $check_autodie->( $err, 'rmdir', 'rmdir ENOENT' ); }; subtest 'rmdir dies on regular file (ENOTDIR)' => sub { my $file = Test::MockFile->file( "/ad_rmdir_file_$$", "data" ); my $died = !eval { rmdir("/ad_rmdir_file_$$"); 1; }; my $err = $@; ok( $died, "rmdir dies on file (ENOTDIR)" ); $check_autodie->( $err, 'rmdir', 'rmdir ENOTDIR' ); }; # ---- rename ---- subtest 'rename dies when source does not exist (ENOENT)' => sub { my $src = Test::MockFile->file("/ad_rename_nosrc_$$"); my $dst = Test::MockFile->file("/ad_rename_dst_$$"); my $died = !eval { rename( "/ad_rename_nosrc_$$", "/ad_rename_dst_$$" ); 1; }; my $err = $@; ok( $died, "rename dies when source doesn't exist" ); $check_autodie->( $err, 'rename', 'rename ENOENT' ); }; # ---- truncate ---- subtest 'truncate dies on non-existent file (ENOENT)' => sub { my $file = Test::MockFile->file("/ad_trunc_noexist_$$"); my $died = !eval { truncate( "/ad_trunc_noexist_$$", 0 ); 1; }; my $err = $@; ok( $died, "truncate dies on non-existent file" ); $check_autodie->( $err, 'truncate', 'truncate ENOENT' ); }; subtest 'truncate dies on directory (EISDIR)' => sub { my $dir = Test::MockFile->new_dir("/ad_trunc_dir_$$"); my $died = !eval { truncate( "/ad_trunc_dir_$$", 0 ); 1; }; my $err = $@; ok( $died, "truncate dies on directory" ); $check_autodie->( $err, 'truncate', 'truncate EISDIR' ); }; # ---- chmod ---- subtest 'chmod dies on non-existent file' => sub { my $file = Test::MockFile->file("/ad_chmod_noexist_$$"); my $died = !eval { chmod( 0644, "/ad_chmod_noexist_$$" ); 1; }; my $err = $@; ok( $died, "chmod dies on non-existent mocked file" ); $check_autodie->( $err, 'chmod', 'chmod ENOENT' ); }; # ---- chown ---- subtest 'chown dies on non-existent file' => sub { my $file = Test::MockFile->file("/ad_chown_noexist_$$"); my $died = !eval { chown( $>, (split /\s/, $))[0], "/ad_chown_noexist_$$" ); 1; }; my $err = $@; ok( $died, "chown dies on non-existent mocked file" ); $check_autodie->( $err, 'chown', 'chown ENOENT' ); }; # ---- utime ---- subtest 'utime dies on non-existent file' => sub { my $file = Test::MockFile->file("/ad_utime_noexist_$$"); my $died = !eval { utime( time, time, "/ad_utime_noexist_$$" ); 1; }; my $err = $@; ok( $died, "utime dies on non-existent mocked file" ); $check_autodie->( $err, 'utime', 'utime ENOENT' ); }; # ---- Success paths still work ---- subtest 'successful operations do not throw under autodie' => sub { my $dir = Test::MockFile->new_dir("/ad_success_dir_$$"); my $file = Test::MockFile->file( "/ad_success_file_$$", "content" ); my $link_target = Test::MockFile->file("/ad_success_link_$$"); my $hard_dest = Test::MockFile->file("/ad_success_hard_$$"); my $rename_dst = Test::MockFile->file("/ad_success_rdst_$$"); my $mkdir_tgt = Test::MockFile->dir("/ad_success_mkdir_$$"); my $rmdir_tgt = Test::MockFile->new_dir("/ad_success_rmdir_$$"); my $ok = eval { # opendir + closedir opendir( my $dh, "/ad_success_dir_$$" ); closedir($dh); # symlink symlink( '/target', "/ad_success_link_$$" ); # readlink my $target = readlink("/ad_success_link_$$"); # link link( "/ad_success_file_$$", "/ad_success_hard_$$" ); # truncate truncate( "/ad_success_file_$$", 3 ); # rename rename( "/ad_success_file_$$", "/ad_success_rdst_$$" ); # mkdir mkdir("/ad_success_mkdir_$$"); # rmdir rmdir("/ad_success_rmdir_$$"); # chmod chmod( 0755, "/ad_success_rdst_$$" ); # chown chown( $>, (split /\s/, $))[0], "/ad_success_rdst_$$" ); # utime utime( time, time, "/ad_success_rdst_$$" ); # unlink unlink("/ad_success_rdst_$$"); 1; }; ok( $ok, "all successful operations work under autodie" ) or diag("Error: $@"); }; } done_testing(); Test-MockFile-0.039/t/sysopen_strict.t000644 000765 000024 00000001461 15157362227 021413 0ustar00todd.rinaldostaff000000 000000 #!/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.039/t/touch.t000644 000765 000024 00000005337 15157362227 017453 0ustar00todd.rinaldostaff000000 000000 #!/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.039/t/file_access_hooks.t000644 000765 000024 00000006074 15157362227 021773 0ustar00todd.rinaldostaff000000 000000 #!/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.039/t/open_broken_symlink_create.t000644 000765 000024 00000016636 15157362227 023727 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl -w # Tests for: # 1. open() through a broken symlink with write-capable modes should create # the target file (matching real filesystem behavior) # 2. sysopen() through a broken symlink with O_CREAT should create the target # 3. autodie throws on EISDIR in open() use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Fcntl; use Errno qw/EISDIR ENOENT ELOOP/; use Test::MockFile qw< nostrict >; # ======================================================= # open() through a broken symlink with write mode creates the target # ======================================================= note "--- open('>') through broken symlink creates target file ---"; { my $dir = Test::MockFile->new_dir('/bsym'); my $symlink = Test::MockFile->symlink( '/bsym/target', '/bsym/link' ); ok( -l '/bsym/link', "Symlink exists" ); ok( !-e '/bsym/target', "Target does not exist yet" ); # Write mode through broken symlink should create the target ok( open( my $fh, '>', '/bsym/link' ), "open('>') through broken symlink succeeds" ) or diag "Error: $!"; print $fh "created via symlink"; close $fh; ok( -f '/bsym/target', "Target file now exists" ); # Read back through the symlink to verify ok( open( $fh, '<', '/bsym/link' ), "Re-open for reading through symlink" ); my $content = do { local $/; <$fh> }; close $fh; is( $content, "created via symlink", "Content written through broken symlink" ); } note "--- open('>>') through broken symlink creates target file ---"; { my $dir = Test::MockFile->new_dir('/bsym2'); my $symlink = Test::MockFile->symlink( '/bsym2/target', '/bsym2/link' ); ok( !-e '/bsym2/target', "Target does not exist" ); ok( open( my $fh, '>>', '/bsym2/link' ), "open('>>') through broken symlink succeeds" ) or diag "Error: $!"; print $fh "appended"; close $fh; ok( -f '/bsym2/target', "Target file created by append" ); } note "--- open('+>') through broken symlink creates target file ---"; { my $dir = Test::MockFile->new_dir('/bsym3'); my $symlink = Test::MockFile->symlink( '/bsym3/target', '/bsym3/link' ); ok( !-e '/bsym3/target', "Target does not exist" ); ok( open( my $fh, '+>', '/bsym3/link' ), "open('+>') through broken symlink succeeds" ) or diag "Error: $!"; print $fh "rw created"; close $fh; ok( -f '/bsym3/target', "Target file created by +>" ); } note "--- open('+>>') through broken symlink creates target file ---"; { my $dir = Test::MockFile->new_dir('/bsym4'); my $symlink = Test::MockFile->symlink( '/bsym4/target', '/bsym4/link' ); ok( !-e '/bsym4/target', "Target does not exist" ); ok( open( my $fh, '+>>', '/bsym4/link' ), "open('+>>') through broken symlink succeeds" ) or diag "Error: $!"; print $fh "rw appended"; close $fh; ok( -f '/bsym4/target', "Target file created by +>>" ); } # ======================================================= # open('<') through a broken symlink still returns ENOENT # ======================================================= note "--- open('<') through broken symlink returns ENOENT ---"; { my $dir = Test::MockFile->new_dir('/bsym5'); my $symlink = Test::MockFile->symlink( '/bsym5/target', '/bsym5/link' ); ok( !open( my $fh, '<', '/bsym5/link' ), "open('<') through broken symlink fails" ); is( $! + 0, ENOENT, "errno is ENOENT for read-only open through broken symlink" ); } note "--- open('+<') through broken symlink returns ENOENT ---"; { my $dir = Test::MockFile->new_dir('/bsym6'); my $symlink = Test::MockFile->symlink( '/bsym6/target', '/bsym6/link' ); ok( !open( my $fh, '+<', '/bsym6/link' ), "open('+<') through broken symlink fails" ); is( $! + 0, ENOENT, "errno is ENOENT for +< open through broken symlink" ); } # ======================================================= # sysopen() through a broken symlink with O_CREAT creates the target # ======================================================= note "--- sysopen(O_CREAT) through broken symlink creates target file ---"; { my $dir = Test::MockFile->new_dir('/bsym7'); my $symlink = Test::MockFile->symlink( '/bsym7/target', '/bsym7/link' ); ok( !-e '/bsym7/target', "Target does not exist" ); ok( sysopen( my $fh, '/bsym7/link', O_WRONLY | O_CREAT, 0644 ), "sysopen(O_WRONLY|O_CREAT) through broken symlink succeeds" ) or diag "Error: $!"; syswrite( $fh, "sysopen created" ); close $fh; ok( -f '/bsym7/target', "Target file created by sysopen O_CREAT" ); # Read back to verify ok( open( $fh, '<', '/bsym7/link' ), "Read back through symlink" ); my $content = do { local $/; <$fh> }; close $fh; is( $content, "sysopen created", "Content matches what was written" ); } note "--- sysopen(O_RDWR|O_CREAT) through broken symlink creates target ---"; { my $dir = Test::MockFile->new_dir('/bsym8'); my $symlink = Test::MockFile->symlink( '/bsym8/target', '/bsym8/link' ); ok( sysopen( my $fh, '/bsym8/link', O_RDWR | O_CREAT, 0644 ), "sysopen(O_RDWR|O_CREAT) through broken symlink succeeds" ) or diag "Error: $!"; close $fh; ok( -f '/bsym8/target', "Target file created by sysopen O_RDWR|O_CREAT" ); } # ======================================================= # sysopen() without O_CREAT through broken symlink still fails # ======================================================= note "--- sysopen without O_CREAT through broken symlink returns ENOENT ---"; { my $dir = Test::MockFile->new_dir('/bsym9'); my $symlink = Test::MockFile->symlink( '/bsym9/target', '/bsym9/link' ); ok( !sysopen( my $fh, '/bsym9/link', O_RDONLY ), "sysopen(O_RDONLY) through broken symlink fails" ); is( $! + 0, ENOENT, "errno is ENOENT for O_RDONLY through broken symlink" ); ok( !sysopen( $fh, '/bsym9/link', O_WRONLY ), "sysopen(O_WRONLY) without O_CREAT fails" ); is( $! + 0, ENOENT, "errno is ENOENT for O_WRONLY without O_CREAT" ); } # ======================================================= # Symlink chain (multiple levels) — create through double symlink # ======================================================= note "--- open through chained broken symlink creates target ---"; { my $dir = Test::MockFile->new_dir('/chain'); my $link1 = Test::MockFile->symlink( '/chain/link2', '/chain/link1' ); my $link2 = Test::MockFile->symlink( '/chain/target', '/chain/link2' ); ok( -l '/chain/link1', "First symlink exists" ); ok( -l '/chain/link2', "Second symlink exists" ); ok( !-e '/chain/target', "Target does not exist" ); ok( open( my $fh, '>', '/chain/link1' ), "open('>') through double symlink succeeds" ) or diag "Error: $!"; print $fh "chain created"; close $fh; ok( -f '/chain/target', "Target file created through symlink chain" ); } # ======================================================= # Circular symlink still returns ELOOP (not affected by write mode) # ======================================================= note "--- open('>') through circular symlink still returns ELOOP ---"; { my $link_a = Test::MockFile->symlink( '/circ/b', '/circ/a' ); my $link_b = Test::MockFile->symlink( '/circ/a', '/circ/b' ); ok( !open( my $fh, '>', '/circ/a' ), "open('>') through circular symlink fails" ); is( $! + 0, ELOOP, "errno is ELOOP for circular symlink even with write mode" ); } done_testing(); Test-MockFile-0.039/t/open-noclose.t000644 000765 000024 00000002353 15157362227 020725 0ustar00todd.rinaldostaff000000 000000 #!/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.039/t/open.t000644 000765 000024 00000013035 15157362227 017264 0ustar00todd.rinaldostaff000000 000000 #!/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' ); } ); note "-------------- BROKEN SYMLINK OPEN --------------"; { # Symlink to a path with no mock = broken symlink (target doesn't exist) my $link = Test::MockFile->symlink( '/nonexistent_target', '/broken_link' ); # Opening a broken symlink should fail with ENOENT, not confess $! = 0; my $ret = open( my $fh, '<', '/broken_link' ); ok( !$ret, 'open on broken symlink returns false' ); is( $! + 0, ENOENT, 'open on broken symlink sets $! to ENOENT' ); } done_testing(); exit; Test-MockFile-0.039/t/plugin-filetemp.t000644 000765 000024 00000002623 15157362227 021425 0ustar00todd.rinaldostaff000000 000000 #!/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.039/t/mock_stat.t000644 000765 000024 00000020111 15157362227 020300 0ustar00todd.rinaldostaff000000 000000 #!/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 ENOENT/; 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' ], # Component-based resolution: /. in middle of path (GH #108) [ '/there/./xyz' => '/there/xyz' ], [ '/./foo' => '/foo' ], [ '/a/./b/./c' => '/a/b/c' ], # Component-based resolution: /.. at various positions [ '/there/..' => '/' ], [ '/..' => '/' ], [ '/../foo' => '/foo' ], [ '/there/sub/../file' => '/there/file' ], [ '/a/b/c/../../d' => '/a/d' ], # Root path preservation [ '/' => '/' ], # Multiple slashes [ '/foo//bar' => '/foo/bar' ], [ '///foo///bar///' => '/foo/bar' ], ); 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 match qr/^[1-9][0-9]*$/; # inode: unique positive integer item 0100644; item 1; # nlink: 1 for regular files 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 0; }; is( Test::MockFile::_mock_stat( 'lstat', '/foo/bar' ), $basic_stat_return, "/foo/bar mock stat" ); is( Test::MockFile::_mock_stat( 'stat', '/aaa' ), 0, "/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' ), 0, "/foo/baz mock stat when missing." ); is( $! + 0, ENOENT, "Throws an ENOENT error for missing file" ); my $symlink_lstat_return = array { item 0; item match qr/^[1-9][0-9]*$/; # inode: unique positive integer item 0127777; item 1; # nlink: 1 for symlinks item match qr/^[0-9]+$/; item match qr/^[0-9\s]+$/; item 0; item 11; # length('/not/a/file') - symlink size = length of target path 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' ), 0, "stat on /broken_link returns 0 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' ); } note "path canonicalization — stat resolves . and .. components (GH #108)"; { my $dir = Test::MockFile->dir('/there'); my $file = Test::MockFile->file( '/there/xyz', "content" ); mkdir '/there'; # /there/. should resolve to /there ok( -d '/there/.', '-d "/there/." resolves to mocked /there' ); # /there/./xyz should resolve to /there/xyz ok( -e '/there/./xyz', '-e "/there/./xyz" resolves to mocked /there/xyz' ); ok( -f '/there/./xyz', '-f "/there/./xyz" resolves to mocked /there/xyz' ); # stat on paths with . component my @st = stat('/there/./xyz'); ok( scalar @st, 'stat("/there/./xyz") returns stat data' ); } { my $parent = Test::MockFile->dir('/up'); my $child = Test::MockFile->dir('/up/down'); mkdir '/up'; mkdir '/up/down'; # /up/down/.. should resolve to /up ok( -d '/up/down/..', '-d "/up/down/.." resolves to mocked /up' ); } note "directory stat size returns blksize, not stringified arrayref length"; { my $dir = Test::MockFile->new_dir('/stat_dir_size'); my $child = Test::MockFile->file( '/stat_dir_size/a', 'data' ); my @st = stat('/stat_dir_size'); is( $st[7], 4096, 'directory stat size is blksize (4096), not stringified ref length' ); my $s = -s '/stat_dir_size'; is( $s, 4096, '-s on directory returns blksize' ); } done_testing(); exit; Test-MockFile-0.039/t/rmdir.t000644 000765 000024 00000012553 15157362227 017444 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Errno qw/ENOENT ENOTEMPTY 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 $_; $! = 0; like( warning { $returns = rmdir(undef) }, qr/^Use of uninitialized value in rmdir at.+\n$/, "MOCK rmdir when undef is passed as the directory." ); is( $returns, 0, " - returns 0" ); is( $! + 0, ENOENT, ' - $! is ENOENT (matches CORE::rmdir behavior)' ); }; 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, ENOTEMPTY, '$! is ENOTEMPTY' ); } ); subtest( 'rmdir succeeds when only non-existent mocks exist in directory' => sub { my $dir = Test::MockFile->new_dir('/mydir'); my $file = Test::MockFile->file('/mydir/ghost'); # non-existent placeholder (undef contents) ok( -d '/mydir', 'Directory exists' ); ok( !-e '/mydir/ghost', 'Ghost file does not exist' ); $! = 0; is( rmdir('/mydir'), 1, 'rmdir succeeds on dir with only non-existent child mocks' ); is( $! + 0, 0, '$! is not set' ) or diag "$!"; ok( !-d '/mydir', 'Directory no longer exists after rmdir' ); } ); subtest( 'rmdir fails when at least one existing file is in directory' => sub { my $dir = Test::MockFile->new_dir('/mixdir'); my $ghost = Test::MockFile->file('/mixdir/ghost'); # non-existent my $real = Test::MockFile->file( '/mixdir/real', 'content' ); # exists ok( -d '/mixdir', 'Directory exists' ); ok( !-e '/mixdir/ghost', 'Ghost file does not exist' ); ok( -e '/mixdir/real', 'Real file exists' ); $! = 0; ok( !rmdir('/mixdir'), 'rmdir fails when existing file is present' ); ok( $! + 0, '$! is set' ); ok( -d '/mixdir', 'Directory still exists' ); } ); 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.039/t/filehandle_weakref.t000644 000765 000024 00000011442 15157362227 022122 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Errno qw/EBADF/; use Test::MockFile qw< nostrict >; note "-------------- FILEHANDLE AFTER MOCK DESTRUCTION --------------"; note "When a mock goes out of scope, the weakened data ref in the tied"; note "filehandle becomes undef. Operations must not crash."; # Helper: open a mock file handle, destroy the mock, return the fh. sub _open_then_destroy_mock { my ($path, $content, $mode) = @_; $mode //= '<'; my $mock = Test::MockFile->file($path, $content); open(my $fh, $mode, $path) or die "open failed: $!"; # Destroy the mock — weakened ref in tied handle becomes undef. undef $mock; return $fh; } subtest 'readline after mock destruction returns undef' => sub { my $fh = _open_then_destroy_mock('/fake/readline', "hello\nworld\n"); my $line; my $ok = lives { $line = <$fh> }; ok($ok, "readline does not crash after mock destruction"); is($line, undef, "readline returns undef"); close $fh; }; subtest 'getc after mock destruction returns undef' => sub { my $fh = _open_then_destroy_mock('/fake/getc', "abc"); my $ch; my $ok = lives { $ch = getc($fh) }; ok($ok, "getc does not crash after mock destruction"); is($ch, undef, "getc returns undef"); close $fh; }; subtest 'sysread after mock destruction returns 0' => sub { my $fh = _open_then_destroy_mock('/fake/sysread', "data"); my ($buf, $ret, $errno) = (''); my $ok = lives { $ret = sysread($fh, $buf, 10); $errno = $! + 0; }; ok($ok, "sysread does not crash after mock destruction"); is($ret, 0, "sysread returns 0 bytes"); is($errno, EBADF, "errno is EBADF after sysread on destroyed mock"); close $fh; }; subtest 'print after mock destruction returns false' => sub { my $fh = _open_then_destroy_mock('/fake/print', '', '>'); my ($ret, $errno); my $ok = lives { $ret = print {$fh} "hello"; $errno = $! + 0; }; ok($ok, "print does not crash after mock destruction"); ok(!$ret, "print returns false when mock is destroyed"); is($errno, EBADF, "errno is EBADF after print on destroyed mock"); close $fh; }; subtest 'printf after mock destruction returns false' => sub { my $fh = _open_then_destroy_mock('/fake/printf', '', '>'); my ($ret, $errno); my $ok = lives { $ret = printf {$fh} "%s", "hello"; $errno = $! + 0; }; ok($ok, "printf does not crash after mock destruction"); ok(!$ret, "printf returns false when mock is destroyed"); is($errno, EBADF, "errno is EBADF after printf on destroyed mock"); close $fh; }; subtest 'syswrite after mock destruction returns 0' => sub { my $fh = _open_then_destroy_mock('/fake/syswrite', '', '>'); my ($ret, $errno); my $ok = lives { $ret = syswrite($fh, "hello", 5); $errno = $! + 0; }; ok($ok, "syswrite does not crash after mock destruction"); is($ret, 0, "syswrite returns 0 bytes"); is($errno, EBADF, "errno is EBADF after syswrite on destroyed mock"); close $fh; }; subtest 'eof after mock destruction returns true' => sub { my $fh = _open_then_destroy_mock('/fake/eof', "content"); my $ret; my $ok = lives { $ret = eof($fh) }; ok($ok, "eof does not crash after mock destruction"); ok($ret, "eof returns true (handle is dead)"); close $fh; }; subtest 'seek after mock destruction fails gracefully' => sub { my $fh = _open_then_destroy_mock('/fake/seek', "content"); my ($ret, $errno); my $ok = lives { $ret = seek($fh, 0, 0); $errno = $! + 0; }; ok($ok, "seek does not crash after mock destruction"); is($ret, 0, "seek returns 0 (failure)"); is($errno, EBADF, "errno is EBADF after seek on destroyed mock"); close $fh; }; subtest 'tell after mock destruction still works' => sub { my $fh = _open_then_destroy_mock('/fake/tell', "content"); my $ret; my $ok = lives { $ret = tell($fh) }; ok($ok, "tell does not crash after mock destruction"); is($ret, 0, "tell returns the last known position"); close $fh; }; subtest 'readline list context after mock destruction returns empty' => sub { my $fh = _open_then_destroy_mock('/fake/readline_list', "a\nb\n"); my @lines; my $ok = lives { @lines = <$fh> }; ok($ok, "readline (list) does not crash after mock destruction"); is(scalar @lines, 0, "readline (list) returns empty list"); close $fh; }; subtest 'close after mock destruction succeeds' => sub { my $fh = _open_then_destroy_mock('/fake/close', "content"); my $ret; my $ok = lives { $ret = close($fh) }; ok($ok, "close does not crash after mock destruction"); ok($ret, "close returns true"); }; done_testing(); Test-MockFile-0.039/t/autovivify.t000644 000765 000024 00000014151 15157362227 020530 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Errno qw/ENOENT/; use Test::MockFile qw< nostrict >; note "-------------- autovivify: basic file creation via open --------------"; { my $dir = Test::MockFile->new_dir( '/av', { 'autovivify' => 1 } ); # File doesn't exist yet ok( !-e '/av/file.txt', 'auto-vivified file does not exist before open' ); # Create and write via open ok( open( my $fh, '>', '/av/file.txt' ), 'open for write under autovivify dir' ); print $fh 'hello world'; close $fh; ok( -e '/av/file.txt', 'file exists after write' ); ok( -f '/av/file.txt', 'file is a regular file' ); # Read it back ok( open( my $rfh, '<', '/av/file.txt' ), 'open for read' ); my $content = do { local $/; <$rfh> }; close $rfh; is( $content, 'hello world', 'content matches what was written' ); } note "-------------- autovivify: temp file then rename pattern --------------"; { my $dir = Test::MockFile->new_dir( '/tmpdir', { 'autovivify' => 1 } ); # Write to temp file ok( open( my $fh, '>', '/tmpdir/.tmp.data' ), 'open temp file for write' ); print $fh 'final content'; close $fh; # Rename into place ok( rename( '/tmpdir/.tmp.data', '/tmpdir/data.txt' ), 'rename temp file into place' ); # Verify final file ok( -e '/tmpdir/data.txt', 'renamed file exists' ); ok( !-e '/tmpdir/.tmp.data', 'temp file no longer exists' ); ok( open( my $rfh, '<', '/tmpdir/data.txt' ), 'can read renamed file' ); my $content = do { local $/; <$rfh> }; close $rfh; is( $content, 'final content', 'renamed file has correct content' ); } note "-------------- autovivify: stat on non-existent file --------------"; { my $dir = Test::MockFile->new_dir( '/avstat', { 'autovivify' => 1 } ); ok( !-e '/avstat/nofile', 'non-existent file under autovivify dir returns false for -e' ); ok( !-f '/avstat/nofile', 'non-existent file returns false for -f' ); ok( !-d '/avstat/nofile', 'non-existent file returns false for -d' ); } note "-------------- autovivify: mkdir subdirectory --------------"; { my $dir = Test::MockFile->new_dir( '/avmk', { 'autovivify' => 1 } ); ok( mkdir('/avmk/sub'), 'mkdir under autovivify dir works' ); ok( -d '/avmk/sub', 'subdirectory exists after mkdir' ); ok( opendir( my $dh, '/avmk' ), 'can opendir the autovivify dir' ); my @entries = readdir($dh); closedir $dh; ok( grep( { $_ eq 'sub' } @entries ), 'subdirectory appears in readdir' ); } note "-------------- autovivify: unlink auto-vivified file --------------"; { my $dir = Test::MockFile->new_dir( '/avul', { 'autovivify' => 1 } ); ok( open( my $fh, '>', '/avul/temp' ), 'create file' ); print $fh 'data'; close $fh; ok( -e '/avul/temp', 'file exists' ); ok( unlink('/avul/temp'), 'unlink succeeds' ); ok( !-e '/avul/temp', 'file is gone after unlink' ); } note "-------------- autovivify: sysopen with O_CREAT --------------"; { use Fcntl qw/O_WRONLY O_CREAT/; my $dir = Test::MockFile->new_dir( '/avsys', { 'autovivify' => 1 } ); ok( sysopen( my $fh, '/avsys/sysfile', O_WRONLY | O_CREAT ), 'sysopen with O_CREAT under autovivify' ); syswrite $fh, 'sysdata'; close $fh; ok( -e '/avsys/sysfile', 'sysopen-created file exists' ); } note "-------------- autovivify: cleanup on scope exit --------------"; { { my $dir = Test::MockFile->new_dir( '/avscope', { 'autovivify' => 1 } ); ok( open( my $fh, '>', '/avscope/tmp' ), 'create file in scoped dir' ); print $fh 'data'; close $fh; ok( -e '/avscope/tmp', 'file exists in scope' ); } # After scope exit, the autovivify dir and its children should be gone # Accessing /avscope/tmp should fall through to real FS (nostrict mode) ok( !-e '/avscope/tmp', 'auto-vivified file cleaned up on scope exit' ); } note "-------------- autovivify: readdir shows created files --------------"; { my $dir = Test::MockFile->new_dir( '/avrd', { 'autovivify' => 1 } ); ok( open( my $fh1, '>', '/avrd/alpha' ), 'create alpha' ); close $fh1; ok( open( my $fh2, '>', '/avrd/beta' ), 'create beta' ); close $fh2; ok( opendir( my $dh, '/avrd' ), 'opendir on autovivify dir' ); my @entries = sort readdir($dh); closedir $dh; is( \@entries, [qw/. .. alpha beta/], 'readdir shows auto-vivified files' ); } note "-------------- autovivify: glob works --------------"; { my $dir = Test::MockFile->new_dir( '/avgl', { 'autovivify' => 1 } ); ok( open( my $fh1, '>', '/avgl/foo.txt' ), 'create foo.txt' ); close $fh1; ok( open( my $fh2, '>', '/avgl/bar.txt' ), 'create bar.txt' ); close $fh2; my @files = sort glob('/avgl/*.txt'); is( \@files, [qw(/avgl/bar.txt /avgl/foo.txt)], 'glob finds auto-vivified files' ); } note "-------------- autovivify: works with dir() + mkdir pattern --------------"; { my $dir = Test::MockFile->dir( '/avdir', { 'autovivify' => 1 } ); # dir() creates non-existent placeholder ok( !-d '/avdir', 'dir with autovivify does not exist yet' ); # mkdir materializes it ok( mkdir('/avdir'), 'mkdir materializes autovivify dir' ); ok( -d '/avdir', 'dir exists after mkdir' ); # Now auto-vivification works ok( open( my $fh, '>', '/avdir/newfile' ), 'open file under materialized dir' ); print $fh 'works'; close $fh; ok( -e '/avdir/newfile', 'file exists' ); } note "-------------- autovivify: file permissions respect umask correctly --------------"; { # With umask 0077, perms should be 0666 & ~0077 = 0600 # Bug: XOR (^) gives 0666 ^ 0077 = 0611 (wrong — adds execute bits) my $old_umask = umask(0077); my $dir = Test::MockFile->new_dir( '/avperms', { 'autovivify' => 1 } ); ok( open( my $fh, '>', '/avperms/secret' ), 'create file with umask 0077' ); print $fh 'data'; close $fh; my $mode = ( stat('/avperms/secret') )[2] & 07777; is( sprintf( '%04o', $mode ), '0600', 'autovivified file perms are 0600 with umask 0077 (not 0611)' ); umask($old_umask); } done_testing(); Test-MockFile-0.039/t/stat-x.t000644 000765 000024 00000003437 15157362227 017550 0ustar00todd.rinaldostaff000000 000000 #!/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.039/t/creation_timestamps.t000644 000765 000024 00000017632 15157362227 022404 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Fcntl qw/O_WRONLY O_CREAT O_APPEND O_RDWR/; use Test::MockFile qw< nostrict >; # POSIX specifies that creating a new file/directory sets atime, mtime, # and ctime to the current time. These tests verify that the mock # timestamps reflect the operation time, not the mock construction time. # Helper: set a mock's timestamps to a known past value so we can detect # whether they were updated by the operation under test. sub _set_timestamps_to_past { my ($mock) = @_; my $past = time - 100; $mock->{'atime'} = $past; $mock->{'mtime'} = $past; $mock->{'ctime'} = $past; return $past; } # ============================================================ # open() with > mode creating a new file # ============================================================ subtest 'open > creates file: timestamps reset to now' => sub { my $mock = Test::MockFile->file('/tmp/test_create_gt'); my $past = _set_timestamps_to_past($mock); my $before = time; ok( open( my $fh, '>', '/tmp/test_create_gt' ), 'open > succeeds' ) or diag "open: $!"; close $fh; my @stat = stat('/tmp/test_create_gt'); cmp_ok( $stat[8], '>=', $before, 'atime >= operation time' ); cmp_ok( $stat[9], '>=', $before, 'mtime >= operation time' ); cmp_ok( $stat[10], '>=', $before, 'ctime >= operation time' ); cmp_ok( $stat[8], '>', $past, 'atime updated from past value' ); }; # ============================================================ # open() with >> mode creating a new file # ============================================================ subtest 'open >> creates file: timestamps reset to now' => sub { my $mock = Test::MockFile->file('/tmp/test_create_append'); my $past = _set_timestamps_to_past($mock); my $before = time; ok( open( my $fh, '>>', '/tmp/test_create_append' ), 'open >> succeeds' ) or diag "open: $!"; close $fh; my @stat = stat('/tmp/test_create_append'); cmp_ok( $stat[8], '>=', $before, 'atime >= operation time' ); cmp_ok( $stat[9], '>=', $before, 'mtime >= operation time' ); cmp_ok( $stat[10], '>=', $before, 'ctime >= operation time' ); cmp_ok( $stat[8], '>', $past, 'atime updated from past value' ); }; # ============================================================ # open() with +> mode creating a new file # ============================================================ subtest 'open +> creates file: timestamps reset to now' => sub { my $mock = Test::MockFile->file('/tmp/test_create_rw_trunc'); my $past = _set_timestamps_to_past($mock); my $before = time; ok( open( my $fh, '+>', '/tmp/test_create_rw_trunc' ), 'open +> succeeds' ) or diag "open: $!"; close $fh; my @stat = stat('/tmp/test_create_rw_trunc'); cmp_ok( $stat[8], '>=', $before, 'atime >= operation time' ); cmp_ok( $stat[9], '>=', $before, 'mtime >= operation time' ); cmp_ok( $stat[10], '>=', $before, 'ctime >= operation time' ); cmp_ok( $stat[8], '>', $past, 'atime updated from past value' ); }; # ============================================================ # open() with +>> mode creating a new file # ============================================================ subtest 'open +>> creates file: timestamps reset to now' => sub { my $mock = Test::MockFile->file('/tmp/test_create_rw_append'); my $past = _set_timestamps_to_past($mock); my $before = time; ok( open( my $fh, '+>>', '/tmp/test_create_rw_append' ), 'open +>> succeeds' ) or diag "open: $!"; close $fh; my @stat = stat('/tmp/test_create_rw_append'); cmp_ok( $stat[8], '>=', $before, 'atime >= operation time' ); cmp_ok( $stat[9], '>=', $before, 'mtime >= operation time' ); cmp_ok( $stat[10], '>=', $before, 'ctime >= operation time' ); cmp_ok( $stat[8], '>', $past, 'atime updated from past value' ); }; # ============================================================ # open() with > truncating an existing file # Truncation should update mtime/ctime but NOT atime. # ============================================================ subtest 'open > truncating existing file: mtime/ctime updated, atime unchanged' => sub { my $mock = Test::MockFile->file( '/tmp/test_trunc', 'hello' ); my $past = _set_timestamps_to_past($mock); my $before = time; ok( open( my $fh, '>', '/tmp/test_trunc' ), 'open > succeeds on existing file' ) or diag "open: $!"; close $fh; my @stat = stat('/tmp/test_trunc'); is( $stat[8], $past, 'atime unchanged on truncation' ); cmp_ok( $stat[9], '>=', $before, 'mtime updated on truncation' ); cmp_ok( $stat[10], '>=', $before, 'ctime updated on truncation' ); }; # ============================================================ # sysopen() with O_CREAT creating a new file # ============================================================ subtest 'sysopen O_CREAT creates file: timestamps reset to now' => sub { my $mock = Test::MockFile->file('/tmp/test_sysopen_create'); my $past = _set_timestamps_to_past($mock); my $before = time; ok( sysopen( my $fh, '/tmp/test_sysopen_create', O_WRONLY | O_CREAT ), 'sysopen O_CREAT succeeds' ) or diag "sysopen: $!"; close $fh; my @stat = stat('/tmp/test_sysopen_create'); cmp_ok( $stat[8], '>=', $before, 'atime >= operation time' ); cmp_ok( $stat[9], '>=', $before, 'mtime >= operation time' ); cmp_ok( $stat[10], '>=', $before, 'ctime >= operation time' ); cmp_ok( $stat[8], '>', $past, 'atime updated from past value' ); }; # ============================================================ # sysopen() with O_CREAT|O_APPEND creating a new file # ============================================================ subtest 'sysopen O_CREAT|O_APPEND creates file: timestamps reset to now' => sub { my $mock = Test::MockFile->file('/tmp/test_sysopen_creat_append'); my $past = _set_timestamps_to_past($mock); my $before = time; ok( sysopen( my $fh, '/tmp/test_sysopen_creat_append', O_WRONLY | O_CREAT | O_APPEND ), 'sysopen O_CREAT|O_APPEND succeeds' ) or diag "sysopen: $!"; close $fh; my @stat = stat('/tmp/test_sysopen_creat_append'); cmp_ok( $stat[8], '>=', $before, 'atime >= operation time' ); cmp_ok( $stat[9], '>=', $before, 'mtime >= operation time' ); cmp_ok( $stat[10], '>=', $before, 'ctime >= operation time' ); cmp_ok( $stat[8], '>', $past, 'atime updated from past value' ); }; # ============================================================ # mkdir() creating a new directory # ============================================================ subtest 'mkdir creates directory: timestamps reset to now' => sub { my $mock = Test::MockFile->dir('/tmp/test_mkdir_ts'); my $past = _set_timestamps_to_past($mock); my $before = time; ok( mkdir('/tmp/test_mkdir_ts'), 'mkdir succeeds' ) or diag "mkdir: $!"; my @stat = stat('/tmp/test_mkdir_ts'); cmp_ok( $stat[8], '>=', $before, 'atime >= operation time' ); cmp_ok( $stat[9], '>=', $before, 'mtime >= operation time' ); cmp_ok( $stat[10], '>=', $before, 'ctime >= operation time' ); cmp_ok( $stat[8], '>', $past, 'atime updated from past value' ); }; # ============================================================ # mkdir() with custom permissions: timestamps still reset # ============================================================ subtest 'mkdir with perms creates directory: timestamps reset to now' => sub { my $mock = Test::MockFile->dir('/tmp/test_mkdir_perms_ts'); my $past = _set_timestamps_to_past($mock); my $before = time; ok( mkdir( '/tmp/test_mkdir_perms_ts', 0755 ), 'mkdir with perms succeeds' ) or diag "mkdir: $!"; my @stat = stat('/tmp/test_mkdir_perms_ts'); cmp_ok( $stat[8], '>=', $before, 'atime >= operation time' ); cmp_ok( $stat[9], '>=', $before, 'mtime >= operation time' ); cmp_ok( $stat[10], '>=', $before, 'ctime >= operation time' ); }; done_testing(); Test-MockFile-0.039/t/io_file_compat.t000644 000765 000024 00000016071 15157362227 021277 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use Test::More; use Errno qw/ENOENT EISDIR/; use Test::MockFile qw< nostrict >; # IO::File is loaded by Test::MockFile itself, so it's available. # The key issue: IO::File::open() uses CORE::open which bypasses CORE::GLOBAL::open. note "-------------- IO::File->new with mocked file --------------"; { my $mock = Test::MockFile->file( '/fake/iofile_test', "hello world\n" ); my $fh = IO::File->new( '/fake/iofile_test', 'r' ); ok( defined $fh, "IO::File->new opens a mocked file" ); if ($fh) { my $line = <$fh>; is( $line, "hello world\n", " ... reads correct content" ); is( <$fh>, undef, " ... EOF" ); $fh->close; } } note "-------------- IO::File->new read mode (default) --------------"; { my $mock = Test::MockFile->file( '/fake/iofile_default', "line1\nline2\n" ); my $fh = IO::File->new('/fake/iofile_default'); ok( defined $fh, "IO::File->new with bare filename opens mocked file" ); if ($fh) { my @lines = <$fh>; is_deeply( \@lines, [ "line1\n", "line2\n" ], " ... reads all lines" ); $fh->close; } } note "-------------- IO::File->new with explicit read mode '<' --------------"; { my $mock = Test::MockFile->file( '/fake/iofile_read', "content here\n" ); my $fh = IO::File->new( '/fake/iofile_read', '<' ); ok( defined $fh, "IO::File->new with '<' mode opens mocked file" ); if ($fh) { my $line = <$fh>; is( $line, "content here\n", " ... reads correct content" ); $fh->close; } } note "-------------- IO::File->new with write mode 'w' --------------"; { my $mock = Test::MockFile->file( '/fake/iofile_write', '' ); my $fh = IO::File->new( '/fake/iofile_write', 'w' ); ok( defined $fh, "IO::File->new with 'w' mode opens mocked file" ); if ($fh) { print $fh "written via IO::File\n"; $fh->close; } is( $mock->contents(), "written via IO::File\n", " ... content was written to mock" ); } note "-------------- IO::File->new with append mode 'a' --------------"; { my $mock = Test::MockFile->file( '/fake/iofile_append', "existing\n" ); my $fh = IO::File->new( '/fake/iofile_append', 'a' ); ok( defined $fh, "IO::File->new with 'a' mode opens mocked file" ); if ($fh) { print $fh "appended\n"; $fh->close; } is( $mock->contents(), "existing\nappended\n", " ... content was appended" ); } note "-------------- IO::File->new with read-write mode 'r+' --------------"; { my $mock = Test::MockFile->file( '/fake/iofile_rw', "original\n" ); my $fh = IO::File->new( '/fake/iofile_rw', 'r+' ); ok( defined $fh, "IO::File->new with 'r+' mode opens mocked file" ); if ($fh) { my $line = <$fh>; is( $line, "original\n", " ... reads existing content" ); $fh->close; } } note "-------------- IO::File->new on non-existent mock --------------"; { my $mock = Test::MockFile->file('/fake/iofile_noexist'); my $fh = IO::File->new( '/fake/iofile_noexist', 'r' ); ok( !defined $fh, "IO::File->new returns undef for non-existent mock" ); } note "-------------- IO::File->new with numeric sysopen mode --------------"; { use Fcntl qw/O_RDONLY O_WRONLY O_CREAT O_TRUNC/; my $mock = Test::MockFile->file( '/fake/iofile_sysopen', "sysopen data\n" ); my $fh = IO::File->new( '/fake/iofile_sysopen', O_RDONLY ); ok( defined $fh, "IO::File->new with O_RDONLY opens mocked file" ); if ($fh) { my $line = <$fh>; is( $line, "sysopen data\n", " ... reads correct content via sysopen" ); $fh->close; } } note "-------------- IO::File->open method on existing object --------------"; { my $mock = Test::MockFile->file( '/fake/iofile_method', "method test\n" ); my $fh = IO::File->new; ok( defined $fh, "IO::File->new creates empty handle" ); my $result = $fh->open( '/fake/iofile_method', 'r' ); ok( $result, " ... open method succeeds on mocked file" ); if ($result) { my $line = <$fh>; is( $line, "method test\n", " ... reads correct content" ); $fh->close; } } note "-------------- IO::File with 2-arg embedded mode --------------"; { my $mock = Test::MockFile->file( '/fake/iofile_2arg', '' ); my $fh = IO::File->new('>/fake/iofile_2arg'); ok( defined $fh, "IO::File->new with '>/path' opens mocked file for write" ); if ($fh) { print $fh "two-arg write\n"; $fh->close; } is( $mock->contents(), "two-arg write\n", " ... content was written" ); } note "-------------- IO::File with write+truncate via sysopen mode --------------"; { my $mock = Test::MockFile->file( '/fake/iofile_trunc', "old data" ); my $fh = IO::File->new( '/fake/iofile_trunc', O_WRONLY | O_TRUNC ); ok( defined $fh, "IO::File->new with O_WRONLY|O_TRUNC opens mocked file" ); if ($fh) { print $fh "new"; $fh->close; } is( $mock->contents(), "new", " ... old content was truncated" ); } note "-------------- IO::File getline method on mocked file --------------"; { my $mock = Test::MockFile->file( '/fake/iofile_getline', "first\nsecond\nthird\n" ); my $fh = IO::File->new( '/fake/iofile_getline', 'r' ); ok( defined $fh, "IO::File->new opens for getline test" ); if ($fh) { is( $fh->getline, "first\n", " ... getline returns first line" ); is( $fh->getline, "second\n", " ... getline returns second line" ); is( $fh->getline, "third\n", " ... getline returns third line" ); is( $fh->getline, undef, " ... getline returns undef at EOF" ); $fh->close; } } note "-------------- IO::File->new on directory mock returns EISDIR --------------"; { my $dir = Test::MockFile->dir('/fake/iofile_dir'); mkdir '/fake/iofile_dir'; $! = 0; my $fh = IO::File->new( '/fake/iofile_dir', 'r' ); ok( !defined $fh, "IO::File->new on a directory returns undef" ); is( $! + 0, EISDIR, " ... errno is EISDIR" ); } note "-------------- IO::File->new on directory mock via sysopen returns EISDIR --------------"; { use Fcntl qw/O_RDONLY/; my $dir = Test::MockFile->dir('/fake/iofile_dir_sys'); mkdir '/fake/iofile_dir_sys'; $! = 0; my $fh = IO::File->new( '/fake/iofile_dir_sys', O_RDONLY ); ok( !defined $fh, "IO::File->new with O_RDONLY on a directory returns undef" ); is( $! + 0, EISDIR, " ... errno is EISDIR" ); } note "-------------- IO::File append mode preserves append semantics after seek --------------"; { my $mock = Test::MockFile->file( '/fake/iofile_append_seek', "AAA" ); my $fh = IO::File->new( '/fake/iofile_append_seek', 'a' ); ok( defined $fh, "IO::File->new with 'a' mode opens mocked file" ); if ($fh) { # Write something in append mode print $fh "BBB"; is( $mock->contents(), "AAABBB", " ... first append works" ); # Seek to beginning and write again — should still append seek $fh, 0, 0; print $fh "CCC"; is( $mock->contents(), "AAABBBCCC", " ... append after seek still appends" ); $fh->close; } } done_testing(); Test-MockFile-0.039/t/flock.t000644 000765 000024 00000006007 15160070345 017411 0ustar00todd.rinaldostaff000000 000000 use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Fcntl qw( :flock O_RDWR O_CREAT ); use File::Temp (); # Create a real tempfile before loading Test::MockFile my $real_tempfile; BEGIN { $real_tempfile = File::Temp->new( UNLINK => 1 ); } use Test::MockFile qw< nostrict >; # GitHub issue #112: flock on mocked files should work. subtest 'flock LOCK_EX on mocked file succeeds' => sub { my $mock = Test::MockFile->file( '/fake/lockfile', 'data' ); open( my $fh, '>', '/fake/lockfile' ) or die "open: $!"; ok( flock( $fh, LOCK_EX ), 'LOCK_EX succeeds on mocked file' ); close $fh; }; subtest 'flock LOCK_SH on mocked file succeeds' => sub { my $mock = Test::MockFile->file( '/fake/shared', 'data' ); open( my $fh, '<', '/fake/shared' ) or die "open: $!"; ok( flock( $fh, LOCK_SH ), 'LOCK_SH succeeds on mocked file' ); close $fh; }; subtest 'flock LOCK_UN on mocked file succeeds' => sub { my $mock = Test::MockFile->file( '/fake/unlock', 'data' ); open( my $fh, '>', '/fake/unlock' ) or die "open: $!"; ok( flock( $fh, LOCK_EX ), 'LOCK_EX succeeds' ); ok( flock( $fh, LOCK_UN ), 'LOCK_UN succeeds' ); close $fh; }; subtest 'flock LOCK_EX|LOCK_NB on mocked file succeeds' => sub { my $mock = Test::MockFile->file( '/fake/nonblock', 'data' ); open( my $fh, '>', '/fake/nonblock' ) or die "open: $!"; ok( flock( $fh, LOCK_EX | LOCK_NB ), 'LOCK_EX|LOCK_NB succeeds' ); close $fh; }; subtest 'flock with sysopen on mocked file succeeds' => sub { my $mock = Test::MockFile->file( '/fake/syslock', 'data' ); sysopen( my $fh, '/fake/syslock', O_RDWR | O_CREAT ) or die "sysopen: $!"; ok( flock( $fh, LOCK_EX | LOCK_NB ), 'LOCK_EX|LOCK_NB via sysopen' ); ok( flock( $fh, LOCK_UN ), 'LOCK_UN via sysopen' ); close $fh; }; subtest 'flock on real file falls through to CORE::flock' => sub { # Some CPAN smoker environments have TMPDIR on a filesystem that does # not support flock (e.g. NFS on FreeBSD). Detect this before loading # Test::MockFile's overrides into the picture. my $path = $real_tempfile->filename; # Probe with a handle opened *before* Test::MockFile was loaded so # we're hitting CORE::flock directly via the File::Temp handle. if ( !CORE::flock( $real_tempfile, LOCK_EX | LOCK_NB ) ) { skip_all("flock not supported on this filesystem ($path): $!"); } CORE::flock( $real_tempfile, LOCK_UN ); open( my $fh, '>', $path ) or die "Cannot open $path: $!"; ok( flock( $fh, LOCK_EX | LOCK_NB ), 'LOCK_EX|LOCK_NB on real file succeeds' ); ok( flock( $fh, LOCK_UN ), 'LOCK_UN on real file succeeds' ); close $fh; }; subtest 'reproducer from issue #112' => sub { my $f = '/tmp/myfile'; my $mocked = Test::MockFile->file( $f => 'content' ); open( my $fh, '>', $f ) or die; ok( flock( $fh, LOCK_EX | LOCK_NB ), 'flock succeeds (issue #112 reproducer)' ); close $fh; }; done_testing(); Test-MockFile-0.039/t/blocks.t000644 000765 000024 00000005110 15157362227 017573 0ustar00todd.rinaldostaff000000 000000 #!/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 >; # Assures testers don't mess up with our hard coded perms expectations. umask 022; note "blocks() calculation"; { note "empty file has 0 blocks"; my $mock = Test::MockFile->file('/tmp/empty'); is $mock->blocks, 0, "non-existent file: blocks is 0"; my $mock2 = Test::MockFile->file( '/tmp/empty_content', '' ); is $mock2->blocks, 0, "empty string content: blocks is 0"; } { note "small file has 1 block"; my $mock = Test::MockFile->file( '/tmp/small', 'x' ); is $mock->blocks, 1, "1-byte file: 1 block"; my $mock2 = Test::MockFile->file( '/tmp/small2', 'x' x 100 ); is $mock2->blocks, 1, "100-byte file: 1 block"; } { note "file exactly at blksize boundary"; my $mock = Test::MockFile->file( '/tmp/exact', 'x' x 4096 ); is $mock->blocks, 1, "4096-byte file with 4096 blksize: exactly 1 block"; } { note "file one byte over blksize boundary"; my $mock = Test::MockFile->file( '/tmp/over', 'x' x 4097 ); is $mock->blocks, 2, "4097-byte file: 2 blocks"; } { note "file at exactly 2x blksize"; my $mock = Test::MockFile->file( '/tmp/double', 'x' x 8192 ); is $mock->blocks, 2, "8192-byte file with 4096 blksize: exactly 2 blocks"; } { note "custom blksize"; my $mock = Test::MockFile->file( '/tmp/custom_blk', 'x' x 1024, { blksize => 512 } ); is $mock->blocks, 2, "1024-byte file with 512 blksize: 2 blocks"; my $mock2 = Test::MockFile->file( '/tmp/custom_blk2', 'x' x 513, { blksize => 512 } ); is $mock2->blocks, 2, "513-byte file with 512 blksize: 2 blocks (ceiling)"; my $mock3 = Test::MockFile->file( '/tmp/custom_blk3', 'x' x 512, { blksize => 512 } ); is $mock3->blocks, 1, "512-byte file with 512 blksize: exactly 1 block"; } { note "blocks from stat()"; my $mock = Test::MockFile->file( '/tmp/stat_blocks', 'hello' ); my @stat = stat('/tmp/stat_blocks'); is $stat[12], 1, "stat[12] (blocks) is 1 for a 5-byte file"; my $mock_empty = Test::MockFile->file( '/tmp/stat_empty', '' ); my @stat_e = stat('/tmp/stat_empty'); is $stat_e[12], 0, "stat[12] (blocks) is 0 for an empty file"; } { note "directory blocks"; my $mock = Test::MockFile->new_dir('/tmp/test_dir_blocks'); # Directories have contents = undef, size depends on is_dir path # Just verify it doesn't die my @stat = stat('/tmp/test_dir_blocks'); ok defined $stat[12], "stat[12] defined for directory"; } done_testing(); exit; Test-MockFile-0.039/t/glob_real_files.t000644 000765 000024 00000003404 15157362227 021432 0ustar00todd.rinaldostaff000000 000000 use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use File::Temp; use Test::MockFile qw< nostrict >; # Issue #158: glob should return real files when nothing is mocked # for the given pattern. my $dir = File::Temp->newdir(); # Create real files on disk my $log_file = "$dir/file.log"; open( my $fh, '>', $log_file ) or die "Cannot create $log_file: $!"; print {$fh} "test"; close $fh; my $txt_file = "$dir/file.txt"; open( $fh, '>', $txt_file ) or die "Cannot create $txt_file: $!"; print {$fh} "test"; close $fh; # Test 1: glob should find real files when nothing is mocked my @logs = glob("$dir/*.log"); is \@logs, [$log_file], 'glob finds real .log file on disk'; # Test 2: glob with multiple results my @all = sort glob("$dir/*"); is \@all, [ sort( $log_file, $txt_file ) ], 'glob finds all real files on disk'; # Test 3: glob returns empty for non-matching pattern my @none = glob("$dir/*.xyz"); is \@none, [], 'glob returns empty for non-matching pattern'; # Test 4: diamond operator (angle bracket) glob should also work my @diamond = <$dir/*.log>; is \@diamond, [$log_file], 'angle bracket glob finds real .log file on disk'; # Test 5: mocked files should still work alongside real files, results sorted my $mock = Test::MockFile->file("$dir/mock.log", "mocked"); my @mixed = glob("$dir/*.log"); is \@mixed, [ sort( $log_file, "$dir/mock.log" ) ], 'glob returns both real and mocked files in sorted order'; # Test 6: mocked file that shadows a real file (no duplicates) my $shadow = Test::MockFile->file($log_file, "shadow"); my @shadowed = glob("$dir/*.log"); is \@shadowed, [ sort( $log_file, "$dir/mock.log" ) ], 'glob returns mocked files that shadow real files without duplicates'; done_testing(); Test-MockFile-0.039/t/file_from_disk.t000644 000765 000024 00000002100 15157362227 021266 0ustar00todd.rinaldostaff000000 000000 #!/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.039/t/warnstrict.t000644 000765 000024 00000004410 15157362227 020520 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test::MockFile qw< warnstrict >; subtest( 'is_strict_mode returns true in warnstrict mode' => sub { ok( Test::MockFile::is_strict_mode(), 'is_strict_mode() is true' ); } ); subtest( 'is_warn_mode returns true in warnstrict mode' => sub { ok( Test::MockFile::is_warn_mode(), 'is_warn_mode() is true' ); } ); subtest( 'accessing unmocked file warns instead of dying' => sub { my @w; local $SIG{__WARN__} = sub { push @w, $_[0] }; my $exists = -e '/some/unmocked/file/warnstrict_test'; is( scalar @w, 1, 'got one warning' ); like( $w[0], qr/\Qstat\E.*unmocked.*strict mode/, 'got warning about unmocked file access', ); } ); subtest( 'accessing mocked file does not warn' => sub { my $file = Test::MockFile->file( '/warnstrict/mocked', 'content' ); my @w; local $SIG{__WARN__} = sub { push @w, $_[0] }; my $exists = -e '/warnstrict/mocked'; is( \@w, [], 'no warnings for mocked file access' ); } ); subtest( 'open on unmocked file warns instead of dying' => sub { my @w; local $SIG{__WARN__} = sub { push @w, $_[0] }; open my $fh, '<', '/warnstrict/unmocked/open_test'; is( scalar @w, 1, 'got one warning' ); like( $w[0], qr/\Qopen\E.*unmocked.*strict mode/, 'got warning about unmocked open', ); } ); subtest( 'open on mocked file works normally' => sub { my $file = Test::MockFile->file( '/warnstrict/open_mocked', 'hello' ); my @w; my $ok; local $SIG{__WARN__} = sub { push @w, $_[0] }; $ok = open my $fh, '<', '/warnstrict/open_mocked'; is( \@w, [], 'no warnings for mocked file open' ); ok( $ok, 'open succeeded' ); } ); subtest( 'multiple unmocked accesses all produce warnings' => sub { my @w; local $SIG{__WARN__} = sub { push @w, $_[0] }; -e '/warnstrict/multi/a'; -e '/warnstrict/multi/b'; -e '/warnstrict/multi/c'; is( scalar @w, 3, 'got 3 warnings for 3 unmocked accesses' ); } ); done_testing(); exit; Test-MockFile-0.039/t/sysreadwrite_edge_cases.t000644 000765 000024 00000025036 15157362227 023216 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Fcntl qw( O_RDONLY O_WRONLY O_CREAT O_TRUNC O_RDWR O_APPEND ); use Errno qw( EBADF EINVAL ); use Test::MockFile qw< nostrict >; # ============================================================ # syswrite edge cases # ============================================================ { note "--- syswrite zero-length write returns 0 and writes nothing ---"; my $mock = Test::MockFile->file( '/fake/sw_zero', "original" ); sysopen( my $fh, '/fake/sw_zero', O_WRONLY ) or die; my $ret = syswrite( $fh, "abc", 0 ); is( $ret, 0, "syswrite with len=0 returns 0" ); close $fh; is( $mock->contents, "original", "file contents unchanged after zero-length write" ); } { note "--- syswrite zero-length write on empty file ---"; my $mock = Test::MockFile->file('/fake/sw_zero_empty'); sysopen( my $fh, '/fake/sw_zero_empty', O_WRONLY | O_CREAT | O_TRUNC ) or die; my $ret = syswrite( $fh, "data", 0 ); is( $ret, 0, "syswrite len=0 on empty file returns 0" ); is( tell($fh), 0, "tell unchanged after zero-length write" ); close $fh; is( $mock->contents, '', "file still empty after zero-length write" ); } { note "--- syswrite with O_APPEND always appends regardless of seek ---"; my $mock = Test::MockFile->file( '/fake/sw_append', "AAAA" ); sysopen( my $fh, '/fake/sw_append', O_WRONLY | O_APPEND ) or die; # Seek to beginning — in append mode, writes should still go to end sysseek( $fh, 0, 0 ); syswrite( $fh, "BB", 2 ); close $fh; is( $mock->contents, "AAAABB", "syswrite with O_APPEND appends even after seek to 0" ); } { note "--- syswrite with O_APPEND via open >> ---"; my $mock = Test::MockFile->file( '/fake/sw_append2', "start" ); open( my $fh, '>>', '/fake/sw_append2' ) or die; syswrite( $fh, "END", 3 ); close $fh; is( $mock->contents, "startEND", "syswrite via open >> appends to file" ); } { note "--- seek past EOF then syswrite creates null-byte gap ---"; my $mock = Test::MockFile->file('/fake/sw_gap'); sysopen( my $fh, '/fake/sw_gap', O_RDWR | O_CREAT | O_TRUNC ) or die; syswrite( $fh, "AB", 2 ); sysseek( $fh, 10, 0 ); # Seek past current end syswrite( $fh, "XY", 2 ); close $fh; my $expected = "AB" . ( "\0" x 8 ) . "XY"; is( $mock->contents, $expected, "syswrite after seek past EOF fills gap with null bytes" ); is( length( $mock->contents ), 12, "file is 12 bytes (2 + 8 null + 2)" ); } { note "--- seek past EOF then syswrite on file with existing content ---"; my $mock = Test::MockFile->file( '/fake/sw_gap2', "Hello" ); sysopen( my $fh, '/fake/sw_gap2', O_RDWR ) or die; sysseek( $fh, 8, 0 ); # Seek past 5-byte content syswrite( $fh, "!", 1 ); close $fh; my $expected = "Hello" . ( "\0" x 3 ) . "!"; is( $mock->contents, $expected, "syswrite past existing content fills gap with nulls" ); is( length( $mock->contents ), 9, "file is 9 bytes (5 + 3 null + 1)" ); } { note "--- syswrite with float len is truncated to int ---"; my $mock = Test::MockFile->file('/fake/sw_float'); sysopen( my $fh, '/fake/sw_float', O_WRONLY | O_CREAT | O_TRUNC ) or die; my $ret = syswrite( $fh, "ABCDE", 2.9 ); is( $ret, 2, "syswrite with float len 2.9 writes 2 bytes (truncated)" ); close $fh; is( $mock->contents, "AB", "only 2 bytes written with float len 2.9" ); } { note "--- syswrite with non-numeric len warns and returns 0 ---"; my $mock = Test::MockFile->file('/fake/sw_nonnumeric'); sysopen( my $fh, '/fake/sw_nonnumeric', O_WRONLY | O_CREAT | O_TRUNC ) or die; my @warns; local $SIG{__WARN__} = sub { push @warns, $_[0] }; $! = 0; my $ret = syswrite( $fh, "data", "abc" ); is( $ret, 0, "syswrite with non-numeric len returns 0" ); is( $! + 0, EINVAL, "errno is EINVAL for non-numeric len" ); ok( @warns >= 1, "warning emitted for non-numeric len" ); like( $warns[0], qr/isn't numeric/, "warning mentions non-numeric argument" ); close $fh; is( $mock->contents, '', "no data written with non-numeric len" ); } { note "--- syswrite with negative len warns and returns 0 ---"; my $mock = Test::MockFile->file('/fake/sw_neglen'); sysopen( my $fh, '/fake/sw_neglen', O_WRONLY | O_CREAT | O_TRUNC ) or die; my @warns; local $SIG{__WARN__} = sub { push @warns, $_[0] }; $! = 0; my $ret = syswrite( $fh, "data", -5 ); is( $ret, 0, "syswrite with negative len returns 0" ); is( $! + 0, EINVAL, "errno is EINVAL for negative len" ); ok( @warns >= 1, "warning emitted for negative len" ); like( $warns[0], qr/Negative length/, "warning mentions negative length" ); close $fh; is( $mock->contents, '', "no data written with negative len" ); } { note "--- syswrite offset 0 on empty buffer writes nothing ---"; my $mock = Test::MockFile->file('/fake/sw_empty_buf'); sysopen( my $fh, '/fake/sw_empty_buf', O_WRONLY | O_CREAT | O_TRUNC ) or die; my $ret = syswrite( $fh, "", 0 ); is( $ret, 0, "syswrite with empty buffer and len=0 returns 0" ); is( tell($fh), 0, "tell unchanged" ); close $fh; is( $mock->contents, '', "file still empty" ); } # ============================================================ # sysread edge cases # ============================================================ { note "--- sysread with non-numeric len warns and returns undef ---"; my $mock = Test::MockFile->file( '/fake/sr_nonnumeric', "test data" ); sysopen( my $fh, '/fake/sr_nonnumeric', O_RDONLY ) or die; my @warns; local $SIG{__WARN__} = sub { push @warns, $_[0] }; my $buf = ""; $! = 0; my $ret = sysread( $fh, $buf, "abc" ); ok( !defined $ret, "sysread with non-numeric len returns undef" ); is( $! + 0, EINVAL, "errno is EINVAL for non-numeric len" ); ok( @warns >= 1, "warning emitted for non-numeric len" ); like( $warns[0], qr/isn't numeric/, "warning mentions non-numeric argument" ); close $fh; } { note "--- sysread with negative len warns and returns undef ---"; my $mock = Test::MockFile->file( '/fake/sr_neglen', "test data" ); sysopen( my $fh, '/fake/sr_neglen', O_RDONLY ) or die; my @warns; local $SIG{__WARN__} = sub { push @warns, $_[0] }; my $buf = ""; $! = 0; my $ret = sysread( $fh, $buf, -3 ); ok( !defined $ret, "sysread with negative len returns undef" ); is( $! + 0, EINVAL, "errno is EINVAL for negative len" ); ok( @warns >= 1, "warning emitted for negative len" ); like( $warns[0], qr/Negative length/, "warning mentions negative length" ); close $fh; } { note "--- sysread with float len truncates to int ---"; my $mock = Test::MockFile->file( '/fake/sr_float', "ABCDEFGH" ); sysopen( my $fh, '/fake/sr_float', O_RDONLY ) or die; my $buf = ""; my $ret = sysread( $fh, $buf, 3.7 ); is( $ret, 3, "sysread with float len 3.7 reads 3 bytes" ); is( $buf, "ABC", "correct 3 bytes read with float len" ); close $fh; } { note "--- sysread zero-length returns 0 and does not modify buffer ---"; my $mock = Test::MockFile->file( '/fake/sr_zero', "content" ); sysopen( my $fh, '/fake/sr_zero', O_RDONLY ) or die; my $buf = "existing"; my $ret = sysread( $fh, $buf, 0 ); is( $ret, 0, "sysread with len=0 returns 0" ); # Per real Perl: sysread with len=0 truncates buffer at offset # With offset defaulting to 0, buffer becomes "" is( $buf, "", "buffer truncated to empty by zero-length read at offset 0" ); is( tell($fh), 0, "tell unchanged after zero-length read" ); close $fh; } { note "--- sysread with undef buffer initializes it to empty string ---"; my $mock = Test::MockFile->file( '/fake/sr_undef_buf', "Hello" ); sysopen( my $fh, '/fake/sr_undef_buf', O_RDONLY ) or die; my $buf; # undef my $ret = sysread( $fh, $buf, 3 ); is( $ret, 3, "sysread with undef buffer reads 3 bytes" ); is( $buf, "Hel", "buffer correctly filled from undef" ); close $fh; } { note "--- sysread with undef buffer and offset pads with null bytes ---"; my $mock = Test::MockFile->file( '/fake/sr_undef_offset', "Hello" ); sysopen( my $fh, '/fake/sr_undef_offset', O_RDONLY ) or die; my $buf; # undef my $ret = sysread( $fh, $buf, 2, 3 ); is( $ret, 2, "sysread with undef buffer and offset reads 2 bytes" ); is( $buf, "\0\0\0He", "buffer is null-padded then data at offset" ); close $fh; } { note "--- sysread on write-only handle returns undef with EBADF ---"; my $mock = Test::MockFile->file('/fake/sr_ebadf'); sysopen( my $fh, '/fake/sr_ebadf', O_WRONLY | O_CREAT | O_TRUNC ) or die; my $buf = ""; $! = 0; my $ret = sysread( $fh, $buf, 5 ); ok( !defined $ret, "sysread on write-only handle returns undef" ); is( $! + 0, EBADF, "errno is EBADF for sysread on write-only handle" ); close $fh; } { note "--- sysread at EOF returns 0 ---"; my $mock = Test::MockFile->file( '/fake/sr_eof', "AB" ); sysopen( my $fh, '/fake/sr_eof', O_RDONLY ) or die; my $buf = ""; sysread( $fh, $buf, 2 ); # Read all content is( $buf, "AB", "first read gets all content" ); my $ret = sysread( $fh, $buf, 5 ); is( $ret, 0, "sysread at EOF returns 0" ); close $fh; } { note "--- syswrite then sysread in O_RDWR mode ---"; my $mock = Test::MockFile->file('/fake/sw_then_sr'); sysopen( my $fh, '/fake/sw_then_sr', O_RDWR | O_CREAT | O_TRUNC ) or die; syswrite( $fh, "Hello World", 11 ); is( tell($fh), 11, "tell is 11 after syswrite" ); sysseek( $fh, 0, 0 ); my $buf = ""; my $ret = sysread( $fh, $buf, 5 ); is( $ret, 5, "sysread returns 5" ); is( $buf, "Hello", "read back what was written" ); # Continue reading from current position $ret = sysread( $fh, $buf, 6 ); is( $ret, 6, "sysread returns 6" ); is( $buf, " World", "second read continues from tell position" ); close $fh; } { note "--- syswrite multiple times accumulates content ---"; my $mock = Test::MockFile->file('/fake/sw_multi'); sysopen( my $fh, '/fake/sw_multi', O_WRONLY | O_CREAT | O_TRUNC ) or die; syswrite( $fh, "A", 1 ); syswrite( $fh, "BC", 2 ); syswrite( $fh, "DEF", 3 ); close $fh; is( $mock->contents, "ABCDEF", "multiple syswrite calls accumulate correctly" ); is( length( $mock->contents ), 6, "total length is 6" ); } is( \%Test::MockFile::files_being_mocked, {}, "No mock files are in cache" ); done_testing(); exit; Test-MockFile-0.039/t/00-load.t000644 000765 000024 00000000665 15160070345 017453 0ustar00todd.rinaldostaff000000 000000 #!perl -T use 5.016; 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.039/t/print_separators.t000644 000765 000024 00000003646 15157362227 021731 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Test::MockFile qw; note "--- output field separator (\$,) ---"; { my $mock = Test::MockFile->file("/fake/ofs_test"); open( my $fh, '>', "/fake/ofs_test" ) or die; { local $, = ","; print $fh "a", "b", "c"; } close $fh; is( $mock->contents, "a,b,c", 'print with $, = "," joins args with comma' ); } { my $mock = Test::MockFile->file("/fake/ofs_tab"); open( my $fh, '>', "/fake/ofs_tab" ) or die; { local $, = "\t"; print $fh "col1", "col2", "col3"; } close $fh; is( $mock->contents, "col1\tcol2\tcol3", 'print with $, = "\t" joins args with tab' ); } { my $mock = Test::MockFile->file("/fake/ofs_none"); open( my $fh, '>', "/fake/ofs_none" ) or die; # $, is undef by default print $fh "a", "b", "c"; close $fh; is( $mock->contents, "abc", 'print without $, concatenates directly' ); } { my $mock = Test::MockFile->file("/fake/ofs_single"); open( my $fh, '>', "/fake/ofs_single" ) or die; { local $, = ","; print $fh "only"; } close $fh; is( $mock->contents, "only", 'print with $, and single arg has no separator' ); } { my $mock = Test::MockFile->file("/fake/ofs_multichar"); open( my $fh, '>', "/fake/ofs_multichar" ) or die; { local $, = " | "; print $fh "x", "y"; } close $fh; is( $mock->contents, "x | y", 'print with multi-char $, works' ); } note "--- verify printf is unaffected by \$, ---"; { my $mock = Test::MockFile->file("/fake/printf_ofs"); open( my $fh, '>', "/fake/printf_ofs" ) or die; { local $, = ","; printf $fh "%s=%d", "answer", 42; } close $fh; is( $mock->contents, "answer=42", 'printf ignores $, (format handles args)' ); } done_testing(); Test-MockFile-0.039/t/trace.t000644 000765 000024 00000010340 15157362227 017415 0ustar00todd.rinaldostaff000000 000000 #!/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 "--- :trace import tag ---"; $test_code = <<'EOS'; use Test::MockFile qw< :trace >; is $Test::MockFile::STRICT_MODE_STATUS, Test::MockFile::STRICT_MODE_ENABLED, 'strict mode still enabled with :trace'; ok Test::MockFile::is_strict_mode(), "is_strict_mode is true"; # Trace should log the access before strict mode dies my $err; eval { -e '/no/such/trace/file'; 1 } or $err = $@; like $err, qr/strict mode/, "strict mode still dies on unmocked access"; EOS tmf_test_code( name => q[use Test::MockFile qw< :trace > enables trace with strict], exit => 0, test_code => $test_code, test => sub { my ($out) = @_; like $out->{output}, qr/\[trace\]\s+stat\b.*\/no\/such\/trace\/file/, "trace output includes stat access"; }, debug => 0, ); note "--- :trace with :nostrict ---"; $test_code = <<'EOS'; use Test::MockFile qw< :trace :nostrict >; is $Test::MockFile::STRICT_MODE_STATUS, Test::MockFile::STRICT_MODE_DISABLED, 'strict mode disabled with :nostrict'; ok !Test::MockFile::is_strict_mode(), "is_strict_mode is false"; # Access an unmocked file - should trace but not die my $result = -e '/no/such/trace/file2'; ok !$result, "-e returns false for non-existent file"; EOS tmf_test_code( name => q[use Test::MockFile qw< :trace :nostrict >], exit => 0, test_code => $test_code, test => sub { my ($out) = @_; like $out->{output}, qr/\[trace\]\s+stat\b.*\/no\/such\/trace\/file2/, "trace output for unmocked -e access"; }, debug => 0, ); note "--- trace without colon ---"; $test_code = <<'EOS'; use Test::MockFile qw< trace nostrict >; ok !Test::MockFile::is_strict_mode(), "nostrict works"; -e '/no/such/trace/file3'; EOS tmf_test_code( name => q[use Test::MockFile qw< trace nostrict > also works], exit => 0, test_code => $test_code, test => sub { my ($out) = @_; like $out->{output}, qr/\[trace\]\s+stat\b.*\/no\/such\/trace\/file3/, "trace output works without colon prefix"; }, debug => 0, ); note "--- :nostrict alias ---"; $test_code = <<'EOS'; use Test::MockFile qw< :nostrict >; is $Test::MockFile::STRICT_MODE_STATUS, Test::MockFile::STRICT_MODE_DISABLED, ':nostrict disables strict mode'; ok !Test::MockFile::is_strict_mode(), "is_strict_mode is false"; EOS tmf_test_code( name => q[use Test::MockFile qw< :nostrict > alias works], exit => 0, test_code => $test_code, debug => 0, ); note "--- trace includes caller location ---"; $test_code = <<'EOS'; use Test::MockFile qw< :trace :nostrict >; -e '/no/such/trace/loc_test'; ok 1, "trace logged to STDERR"; EOS tmf_test_code( name => q[trace output includes caller location], exit => 0, test_code => $test_code, test => sub { my ($out) = @_; like $out->{output}, qr/\[trace\].*at\s+\S+\s+line\s+\d+/, "trace output includes 'at FILE line N'"; }, debug => 0, ); note "--- trace does not fire for mocked files ---"; $test_code = <<'EOS'; use Test::MockFile qw< :trace >; my $mock = Test::MockFile->file('/trace/mocked/file', 'content'); ok -e '/trace/mocked/file', "mocked file exists"; EOS tmf_test_code( name => q[trace does not fire for mocked files], exit => 0, test_code => $test_code, test => sub { my ($out) = @_; unlike $out->{output}, qr/\[trace\].*\/trace\/mocked\/file/, "no trace output for mocked file access"; }, debug => 0, ); note "--- trace fires for open on unmocked files ---"; $test_code = <<'EOS'; use Test::MockFile qw< :trace :nostrict >; open(my $fh, '<', '/no/such/trace/openfile'); ok 1, "open traced to STDERR"; EOS tmf_test_code( name => q[trace fires for open on unmocked files], exit => 0, test_code => $test_code, test => sub { my ($out) = @_; like $out->{output}, qr/\[trace\]\s+open\b.*\/no\/such\/trace\/openfile/, "trace output for unmocked open"; }, debug => 0, ); done_testing(); Test-MockFile-0.039/t/fh-ref-leak.t000644 000765 000024 00000004432 15157362227 020405 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl -w # Test for GitHub issue #179: "Spooky action-at-a-distance" # # File check operators (-S, -f, etc.) on real (unmocked) filehandles should # not retain references that prevent garbage collection. A leaked reference # to a socket filehandle can keep the fd open, causing reads on the other # end of a socketpair to hang waiting for EOF. # # Root cause: $_last_call_for in Overload::FileCheck stored filehandle refs. # Fix: Only cache string filenames, not refs (Overload::FileCheck PR #25). use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Scalar::Util qw(weaken); use Socket; use Test::MockFile qw< nostrict >; # Test 1: Filehandle passed to -f is not retained { my $weak_ref; { open my $fh, '<', '/dev/null' or die "Cannot open /dev/null: $!"; $weak_ref = $fh; weaken($weak_ref); ok( defined $weak_ref, "weak ref is defined before scope exit" ); no warnings; -f $fh; } ok( !defined $weak_ref, "filehandle is garbage collected after -f (GH #179)" ); } # Test 2: Socket filehandle passed to -S is not retained { my $weak_ref; { open my $fh, '<', '/dev/null' or die "Cannot open /dev/null: $!"; $weak_ref = $fh; weaken($weak_ref); no warnings; -S $fh; } ok( !defined $weak_ref, "filehandle is garbage collected after -S (GH #179)" ); } # Test 3: The exact scenario from GH #179 — socketpair with dup'd fd # This would hang without the fix because the dup'd write handle stays open. { socketpair my $r, my $w, AF_UNIX, SOCK_STREAM, 0 or die "socketpair: $!"; my $pid = fork(); die "fork: $!" unless defined $pid; if ( $pid == 0 ) { # Child: reproduce the bug scenario with a timeout $SIG{ALRM} = sub { exit 1 }; # exit 1 = hung (bug present) alarm(5); my $fd = fileno $w; do { open my $w2, "<&=", $fd; -S $w2; }; close $w; my $line = <$r>; # Should get EOF immediately if $w2 was freed exit 0; # exit 0 = success (no hang) } close $w; waitpid $pid, 0; my $exit = $? >> 8; is( $exit, 0, "socketpair read does not hang after -S on dup'd filehandle (GH #179)" ); } done_testing; Test-MockFile-0.039/t/chown-chmod-nostrict.t000644 000765 000024 00000002152 15157362227 022372 0ustar00todd.rinaldostaff000000 000000 #!/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.039/t/rename.t000644 000765 000024 00000023031 15157362227 017567 0ustar00todd.rinaldostaff000000 000000 #!/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 ENOTDIR ENOTEMPTY/; use Test::MockFile qw< nostrict >; note "-------------- rename: basic file rename --------------"; { my $old = Test::MockFile->file( '/mock/old', 'content' ); my $new = Test::MockFile->file('/mock/new'); ok( rename( '/mock/old', '/mock/new' ), 'rename returns true' ); is( $old->contents, undef, 'old file contents cleared' ); is( $new->contents, 'content', 'new file has old contents' ); } note "-------------- rename: non-existent source --------------"; { my $old = Test::MockFile->file('/mock/noexist'); my $new = Test::MockFile->file('/mock/dest'); ok( !rename( '/mock/noexist', '/mock/dest' ), 'rename fails for non-existent source' ); is( $! + 0, ENOENT, 'errno is ENOENT' ); } note "-------------- rename: overwrite existing file --------------"; { my $old = Test::MockFile->file( '/mock/src', 'new content' ); my $new = Test::MockFile->file( '/mock/dst', 'old content' ); ok( rename( '/mock/src', '/mock/dst' ), 'rename overwrites existing file' ); is( $new->contents, 'new content', 'destination has new contents' ); is( $old->contents, undef, 'source is gone' ); } note "-------------- rename: file to existing directory fails --------------"; { my $old = Test::MockFile->file( '/mock/file', 'data' ); my $dir = Test::MockFile->new_dir('/mock/dir'); ok( !rename( '/mock/file', '/mock/dir' ), 'cannot rename file over directory' ); is( $! + 0, EISDIR, 'errno is EISDIR' ); } note "-------------- rename: preserves file mode --------------"; { my $old = Test::MockFile->file( '/mock/moded', 'data', { mode => 0755 } ); my $new = Test::MockFile->file('/mock/modedest'); my $old_mode = $old->{'mode'}; ok( rename( '/mock/moded', '/mock/modedest' ), 'rename preserves mode' ); is( $new->{'mode'}, $old_mode, 'destination has source mode' ); } note "-------------- rename: empty directory rename --------------"; { my $old = Test::MockFile->new_dir('/mock/olddir'); my $new = Test::MockFile->dir('/mock/newdir'); ok( rename( '/mock/olddir', '/mock/newdir' ), 'rename empty directory works' ); ok( !$old->exists, 'old dir no longer exists' ); ok( $new->exists, 'new dir exists' ); } note "-------------- rename: symlink rename --------------"; { my $target = Test::MockFile->file( '/mock/target', 'data' ); my $link = Test::MockFile->symlink( '/mock/target', '/mock/link' ); my $dest = Test::MockFile->file('/mock/linkdest'); ok( rename( '/mock/link', '/mock/linkdest' ), 'rename symlink works' ); ok( !$link->is_link || !defined $link->readlink, 'old symlink is gone' ); } note "-------------- rename: dir over existing file fails --------------"; { my $dir = Test::MockFile->new_dir('/mock/adir'); my $file = Test::MockFile->file( '/mock/afile', 'data' ); ok( !rename( '/mock/adir', '/mock/afile' ), 'cannot rename dir over file' ); is( $! + 0, ENOTDIR, 'errno is ENOTDIR' ); } note "-------------- rename: file to self is no-op (POSIX) --------------"; { my $file = Test::MockFile->file( '/mock/self', 'precious data' ); ok( rename( '/mock/self', '/mock/self' ), 'rename to self returns true' ); is( $file->contents, 'precious data', 'file contents preserved after rename to self' ); ok( $file->exists, 'file still exists after rename to self' ); } note "-------------- rename: directory to self is no-op (POSIX) --------------"; { my $dir = Test::MockFile->new_dir('/mock/selfdir'); ok( rename( '/mock/selfdir', '/mock/selfdir' ), 'rename dir to self returns true' ); ok( $dir->exists, 'directory still exists after rename to self' ); } note "-------------- rename: symlink to self is no-op (POSIX) --------------"; { my $target = Test::MockFile->file( '/mock/selflink_target', 'data' ); my $link = Test::MockFile->symlink( '/mock/selflink_target', '/mock/selflink' ); ok( rename( '/mock/selflink', '/mock/selflink' ), 'rename symlink to self returns true' ); ok( $link->is_link, 'symlink still a link after rename to self' ); is( readlink('/mock/selflink'), '/mock/selflink_target', 'symlink target preserved after rename to self' ); } note "-------------- rename: dir over non-empty dir fails (ENOTEMPTY) --------------"; { my $src = Test::MockFile->new_dir('/mock/srcdir'); my $dst = Test::MockFile->new_dir('/mock/fulldir'); my $child = Test::MockFile->file( '/mock/fulldir/child', 'data' ); ok( !rename( '/mock/srcdir', '/mock/fulldir' ), 'cannot rename dir over non-empty dir' ); is( $! + 0, ENOTEMPTY, 'errno is ENOTEMPTY' ); ok( $src->exists, 'source dir still exists after failed rename' ); ok( $dst->exists, 'dest dir still exists after failed rename' ); ok( $child->exists, 'child file still exists after failed rename' ); } note "-------------- rename: dir over empty dir succeeds (POSIX) --------------"; { my $src = Test::MockFile->new_dir('/mock/srcdir2'); my $dst = Test::MockFile->new_dir('/mock/emptydir'); ok( rename( '/mock/srcdir2', '/mock/emptydir' ), 'rename dir over empty dir succeeds' ); ok( !$src->exists, 'source dir no longer exists' ); ok( $dst->exists, 'dest dir exists after rename' ); } note "-------------- rename: directory with child file re-keys children --------------"; { my $dir = Test::MockFile->new_dir('/mock/parent'); my $child = Test::MockFile->file( '/mock/parent/child.txt', 'hello world' ); my $dest = Test::MockFile->dir('/mock/renamed'); ok( rename( '/mock/parent', '/mock/renamed' ), 'rename directory with child succeeds' ); ok( !$dir->exists, 'old directory no longer exists' ); ok( $dest->exists, 'new directory exists' ); # Child should be accessible under new path my $child_exists = -e '/mock/renamed/child.txt'; ok( $child_exists, 'child file exists under new directory path' ); # Child contents should be preserved open( my $fh, '<', '/mock/renamed/child.txt' ) or die "open failed: $!"; my $got = do { local $/; <$fh> }; close $fh; is( $got, 'hello world', 'child file contents preserved after directory rename' ); # Child should NOT be accessible under old path ok( !-e '/mock/parent/child.txt', 'child file not accessible under old path' ); } note "-------------- rename: directory with nested subdirectory --------------"; { my $dir = Test::MockFile->new_dir('/mock/top'); my $subdir = Test::MockFile->new_dir('/mock/top/sub'); my $file = Test::MockFile->file( '/mock/top/sub/deep.txt', 'nested' ); my $dest = Test::MockFile->dir('/mock/newtop'); ok( rename( '/mock/top', '/mock/newtop' ), 'rename directory with nested subdirectory succeeds' ); # Nested subdirectory accessible under new path ok( -d '/mock/newtop/sub', 'nested subdirectory exists under new path' ); # Deep file accessible under new path my $deep_exists = -e '/mock/newtop/sub/deep.txt'; ok( $deep_exists, 'deeply nested file exists under new path' ); open( my $fh, '<', '/mock/newtop/sub/deep.txt' ) or die "open failed: $!"; my $got = do { local $/; <$fh> }; close $fh; is( $got, 'nested', 'deeply nested file contents preserved' ); # Old paths should not exist ok( !-e '/mock/top/sub/deep.txt', 'deep file not accessible under old path' ); ok( !-d '/mock/top/sub', 'nested subdir not accessible under old path' ); } note "-------------- rename: directory readdir shows re-keyed children --------------"; { my $dir = Test::MockFile->new_dir('/mock/rd_old'); my $f1 = Test::MockFile->file( '/mock/rd_old/a.txt', 'aaa' ); my $f2 = Test::MockFile->file( '/mock/rd_old/b.txt', 'bbb' ); my $dest = Test::MockFile->dir('/mock/rd_new'); ok( rename( '/mock/rd_old', '/mock/rd_new' ), 'rename directory for readdir test' ); opendir( my $dh, '/mock/rd_new' ) or die "opendir failed: $!"; my @entries = sort readdir($dh); closedir($dh); is( \@entries, [ '.', '..', 'a.txt', 'b.txt' ], 'readdir on renamed directory shows re-keyed children' ); } note "-------------- rename: child mock object path updated after rename --------------"; { my $dir = Test::MockFile->new_dir('/mock/pathtest'); my $child = Test::MockFile->file( '/mock/pathtest/item.dat', 'data' ); my $dest = Test::MockFile->dir('/mock/pathtest2'); ok( rename( '/mock/pathtest', '/mock/pathtest2' ), 'rename for path update test' ); is( $child->path, '/mock/pathtest2/item.dat', 'child mock object path updated to new prefix' ); } note "-------------- rename: directory DESTROY cleanup works after rename --------------"; { my $dir = Test::MockFile->new_dir('/mock/dtor'); my $file = Test::MockFile->file( '/mock/dtor/f.txt', 'content' ); my $dest = Test::MockFile->dir('/mock/dtor2'); ok( rename( '/mock/dtor', '/mock/dtor2' ), 'rename for DESTROY test' ); # Verify child still exists under new path before cleanup ok( -e '/mock/dtor2/f.txt', 'child accessible before DESTROY' ); } note "-------------- rename: preserves inode and nlink --------------"; { my $old = Test::MockFile->file( '/mock/ino_old', 'data', { inode => 42, nlink => 3 } ); my $new = Test::MockFile->file('/mock/ino_new'); ok( rename( '/mock/ino_old', '/mock/ino_new' ), 'rename preserves inode metadata' ); my @st = stat('/mock/ino_new'); is( $st[1], 42, 'inode preserved after rename' ); is( $st[3], 3, 'nlink preserved after rename' ); } done_testing(); Test-MockFile-0.039/t/stat_timestamps.t000644 000765 000024 00000025740 15157362227 021552 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Errno qw/ENOENT/; use Fcntl qw/O_RDONLY O_WRONLY O_RDWR O_CREAT O_TRUNC O_APPEND/; use Test::MockFile qw< nostrict >; # Helper: freeze time, perform action, check which timestamps changed. # We set known timestamps before each action, then check which ones # advanced past the frozen values after the action. note "-------------- WRITE UPDATES mtime/ctime --------------"; { my $mock = Test::MockFile->file( '/ts/write', 'initial' ); # Record initial timestamps my $old_atime = $mock->atime(); my $old_mtime = $mock->mtime(); my $old_ctime = $mock->ctime(); # Set timestamps to a known past value so we can detect updates $mock->{'atime'} = 1000; $mock->{'mtime'} = 1000; $mock->{'ctime'} = 1000; open my $fh, '>', '/ts/write' or die "open: $!"; print $fh "hello"; close $fh; isnt( $mock->mtime(), 1000, 'print updates mtime' ); isnt( $mock->ctime(), 1000, 'print updates ctime' ); } note "-------------- SYSWRITE UPDATES mtime/ctime --------------"; { my $mock = Test::MockFile->file( '/ts/syswrite', 'initial' ); $mock->{'atime'} = 1000; $mock->{'mtime'} = 1000; $mock->{'ctime'} = 1000; sysopen my $fh, '/ts/syswrite', O_WRONLY or die "sysopen: $!"; syswrite $fh, "data", 4; close $fh; isnt( $mock->mtime(), 1000, 'syswrite updates mtime' ); isnt( $mock->ctime(), 1000, 'syswrite updates ctime' ); } note "-------------- READ (sysread) UPDATES atime --------------"; { my $mock = Test::MockFile->file( '/ts/sysread', 'content' ); $mock->{'atime'} = 1000; $mock->{'mtime'} = 1000; $mock->{'ctime'} = 1000; sysopen my $fh, '/ts/sysread', O_RDONLY or die "sysopen: $!"; my $buf; sysread $fh, $buf, 100; close $fh; isnt( $mock->atime(), 1000, 'sysread updates atime' ); is( $mock->mtime(), 1000, 'sysread does not update mtime' ); is( $mock->ctime(), 1000, 'sysread does not update ctime' ); } note "-------------- READLINE UPDATES atime --------------"; { my $mock = Test::MockFile->file( '/ts/readline', "line1\nline2\n" ); $mock->{'atime'} = 1000; $mock->{'mtime'} = 1000; $mock->{'ctime'} = 1000; open my $fh, '<', '/ts/readline' or die "open: $!"; my $line = <$fh>; close $fh; isnt( $mock->atime(), 1000, 'readline updates atime' ); is( $mock->mtime(), 1000, 'readline does not update mtime' ); is( $mock->ctime(), 1000, 'readline does not update ctime' ); } note "-------------- READLINE (list context) UPDATES atime --------------"; { my $mock = Test::MockFile->file( '/ts/slurp', "a\nb\nc\n" ); $mock->{'atime'} = 1000; open my $fh, '<', '/ts/slurp' or die "open: $!"; my @lines = <$fh>; close $fh; isnt( $mock->atime(), 1000, 'readline in list context updates atime' ); is( scalar @lines, 3, 'read all three lines' ); } note "-------------- GETC UPDATES atime --------------"; { my $mock = Test::MockFile->file( '/ts/getc', 'XY' ); $mock->{'atime'} = 1000; open my $fh, '<', '/ts/getc' or die "open: $!"; my $c = getc($fh); close $fh; is( $c, 'X', 'getc returns first character' ); isnt( $mock->atime(), 1000, 'getc updates atime' ); } note "-------------- CHMOD UPDATES ctime --------------"; { my $mock = Test::MockFile->file( '/ts/chmod', 'data' ); $mock->{'ctime'} = 1000; $mock->{'mtime'} = 1000; chmod 0644, '/ts/chmod'; isnt( $mock->ctime(), 1000, 'chmod updates ctime' ); is( $mock->mtime(), 1000, 'chmod does not update mtime' ); } note "-------------- CHOWN UPDATES ctime --------------"; { my $mock = Test::MockFile->file( '/ts/chown', 'data' ); $mock->{'ctime'} = 1000; $mock->{'mtime'} = 1000; my ($primary_gid) = split /\s/, $); chown $>, $primary_gid, '/ts/chown'; isnt( $mock->ctime(), 1000, 'chown updates ctime' ); is( $mock->mtime(), 1000, 'chown does not update mtime' ); } note "-------------- OPEN > UPDATES mtime/ctime (truncate) --------------"; { my $mock = Test::MockFile->file( '/ts/trunc', 'existing content' ); $mock->{'mtime'} = 1000; $mock->{'ctime'} = 1000; open my $fh, '>', '/ts/trunc' or die "open: $!"; close $fh; isnt( $mock->mtime(), 1000, 'open > updates mtime' ); isnt( $mock->ctime(), 1000, 'open > updates ctime' ); is( $mock->contents(), '', 'open > truncated contents' ); } note "-------------- SYSOPEN O_TRUNC UPDATES mtime/ctime --------------"; { my $mock = Test::MockFile->file( '/ts/systrunc', 'existing' ); $mock->{'mtime'} = 1000; $mock->{'ctime'} = 1000; sysopen my $fh, '/ts/systrunc', O_WRONLY | O_TRUNC or die "sysopen: $!"; close $fh; isnt( $mock->mtime(), 1000, 'sysopen O_TRUNC updates mtime' ); isnt( $mock->ctime(), 1000, 'sysopen O_TRUNC updates ctime' ); } note "-------------- SYSOPEN O_CREAT UPDATES mtime/ctime --------------"; { my $mock = Test::MockFile->file('/ts/creat'); $mock->{'mtime'} = 1000; $mock->{'ctime'} = 1000; sysopen my $fh, '/ts/creat', O_WRONLY | O_CREAT or die "sysopen: $!"; close $fh; isnt( $mock->mtime(), 1000, 'sysopen O_CREAT on new file updates mtime' ); isnt( $mock->ctime(), 1000, 'sysopen O_CREAT on new file updates ctime' ); } note "-------------- OPEN >> does NOT update until write --------------"; { my $mock = Test::MockFile->file( '/ts/append', 'data' ); $mock->{'mtime'} = 1000; $mock->{'ctime'} = 1000; open my $fh, '>>', '/ts/append' or die "open: $!"; # Opening in append mode alone shouldn't update timestamps is( $mock->mtime(), 1000, 'open >> alone does not update mtime' ); is( $mock->ctime(), 1000, 'open >> alone does not update ctime' ); print $fh "more"; close $fh; isnt( $mock->mtime(), 1000, 'writing in append mode updates mtime' ); isnt( $mock->ctime(), 1000, 'writing in append mode updates ctime' ); } note "-------------- READ+WRITE updates both atime and mtime --------------"; { my $mock = Test::MockFile->file( '/ts/rw', 'hello' ); $mock->{'atime'} = 1000; $mock->{'mtime'} = 1000; $mock->{'ctime'} = 1000; open my $fh, '+<', '/ts/rw' or die "open: $!"; my $line = <$fh>; # read print $fh "world"; # write close $fh; isnt( $mock->atime(), 1000, 'read in +< mode updates atime' ); isnt( $mock->mtime(), 1000, 'write in +< mode updates mtime' ); isnt( $mock->ctime(), 1000, 'write in +< mode updates ctime' ); } note "-------------- PRINTF UPDATES mtime/ctime --------------"; { my $mock = Test::MockFile->file( '/ts/printf', '' ); $mock->{'mtime'} = 1000; $mock->{'ctime'} = 1000; open my $fh, '>', '/ts/printf' or die "open: $!"; printf $fh "num=%d", 42; close $fh; isnt( $mock->mtime(), 1000, 'printf updates mtime' ); isnt( $mock->ctime(), 1000, 'printf updates ctime' ); is( $mock->contents(), 'num=42', 'printf wrote correctly' ); } note "-------------- TRUNCATE UPDATES mtime/ctime --------------"; { my $mock = Test::MockFile->file( '/ts/truncpath', 'some content here' ); $mock->{'mtime'} = 1000; $mock->{'ctime'} = 1000; $mock->{'atime'} = 1000; truncate '/ts/truncpath', 5; isnt( $mock->mtime(), 1000, 'truncate by path updates mtime' ); isnt( $mock->ctime(), 1000, 'truncate by path updates ctime' ); is( $mock->contents(), 'some ', 'truncate shortened contents' ); } note "-------------- TRUNCATE via FH UPDATES mtime/ctime --------------"; { my $mock = Test::MockFile->file( '/ts/truncfh', 'file data here' ); $mock->{'mtime'} = 1000; $mock->{'ctime'} = 1000; open my $fh, '+<', '/ts/truncfh' or die "open: $!"; truncate $fh, 4; close $fh; isnt( $mock->mtime(), 1000, 'truncate via fh updates mtime' ); isnt( $mock->ctime(), 1000, 'truncate via fh updates ctime' ); is( $mock->contents(), 'file', 'truncate via fh shortened contents' ); } note "-------------- TRUNCATE extend UPDATES mtime/ctime --------------"; { my $mock = Test::MockFile->file( '/ts/truncext', 'ab' ); $mock->{'mtime'} = 1000; $mock->{'ctime'} = 1000; truncate '/ts/truncext', 5; isnt( $mock->mtime(), 1000, 'truncate extend updates mtime' ); isnt( $mock->ctime(), 1000, 'truncate extend updates ctime' ); is( length( $mock->contents() ), 5, 'truncate extended to 5 bytes' ); } note "-------------- TRUNCATE same length still UPDATES mtime/ctime --------------"; { my $mock = Test::MockFile->file( '/ts/truncsame', 'abc' ); $mock->{'mtime'} = 1000; $mock->{'ctime'} = 1000; truncate '/ts/truncsame', 3; isnt( $mock->mtime(), 1000, 'truncate to same length updates mtime' ); isnt( $mock->ctime(), 1000, 'truncate to same length updates ctime' ); } note "-------------- LINK UPDATES parent dir mtime/ctime --------------"; { my $dir = Test::MockFile->new_dir('/ts/linkdir'); my $src = Test::MockFile->file( '/ts/linkdir/source', 'data' ); my $dest = Test::MockFile->file('/ts/linkdir/dest'); $dir->{'mtime'} = 1000; $dir->{'ctime'} = 1000; link '/ts/linkdir/source', '/ts/linkdir/dest'; isnt( $dir->mtime(), 1000, 'link updates parent dir mtime' ); isnt( $dir->ctime(), 1000, 'link updates parent dir ctime' ); } note "-------------- SYMLINK UPDATES parent dir mtime/ctime --------------"; { my $dir = Test::MockFile->new_dir('/ts/symlinkdir'); my $link = Test::MockFile->file('/ts/symlinkdir/mylink'); $dir->{'mtime'} = 1000; $dir->{'ctime'} = 1000; symlink '/some/target', '/ts/symlinkdir/mylink'; isnt( $dir->mtime(), 1000, 'symlink updates parent dir mtime' ); isnt( $dir->ctime(), 1000, 'symlink updates parent dir ctime' ); } note "-------------- RENAME UPDATES both parent dirs mtime/ctime --------------"; { my $old_dir = Test::MockFile->new_dir('/ts/olddir'); my $new_dir = Test::MockFile->new_dir('/ts/newdir'); my $file = Test::MockFile->file( '/ts/olddir/moveme', 'content' ); my $dest = Test::MockFile->file('/ts/newdir/moved'); $old_dir->{'mtime'} = 1000; $old_dir->{'ctime'} = 1000; $new_dir->{'mtime'} = 1000; $new_dir->{'ctime'} = 1000; rename '/ts/olddir/moveme', '/ts/newdir/moved'; isnt( $old_dir->mtime(), 1000, 'rename updates old parent dir mtime' ); isnt( $old_dir->ctime(), 1000, 'rename updates old parent dir ctime' ); isnt( $new_dir->mtime(), 1000, 'rename updates new parent dir mtime' ); isnt( $new_dir->ctime(), 1000, 'rename updates new parent dir ctime' ); } note "-------------- RENAME same dir UPDATES parent dir mtime/ctime --------------"; { my $dir = Test::MockFile->new_dir('/ts/samedir'); my $old = Test::MockFile->file( '/ts/samedir/old', 'data' ); my $new = Test::MockFile->file('/ts/samedir/new'); $dir->{'mtime'} = 1000; $dir->{'ctime'} = 1000; rename '/ts/samedir/old', '/ts/samedir/new'; isnt( $dir->mtime(), 1000, 'rename within same dir updates parent mtime' ); isnt( $dir->ctime(), 1000, 'rename within same dir updates parent ctime' ); } done_testing(); exit; Test-MockFile-0.039/t/open_two_arg_special_chars.t000644 000765 000024 00000006305 15157362227 023670 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use Test2::V0; use Test2::Tools::Warnings qw( no_warnings ); use Test::MockFile qw< nostrict >; # Two-arg open with filenames containing special characters. # Previously, filenames with spaces, tildes, or other non-word characters # would die with "Unsupported two-way open" instead of opening for read. subtest '2-arg open with spaces in filename' => sub { my $path = '/tmp/my file.txt'; my $content = "hello world\n"; my $mock = Test::MockFile->file( $path, $content ); my $fh; ok( lives { ok( open( $fh, $path ), "open succeeds" ) }, "no die on filename with spaces" ); is( <$fh>, $content, "read content correctly" ); close $fh; }; subtest '2-arg open with @ in filename' => sub { my $path = '/tmp/user@host.txt'; my $content = "data\n"; my $mock = Test::MockFile->file( $path, $content ); my $fh; ok( lives { ok( open( $fh, $path ), "open succeeds" ) }, "no die on filename with \@" ); is( <$fh>, $content, "read content correctly" ); close $fh; }; subtest '2-arg open with parentheses in filename' => sub { my $path = '/tmp/file (copy).txt'; my $content = "copy data\n"; my $mock = Test::MockFile->file( $path, $content ); my $fh; ok( lives { ok( open( $fh, $path ), "open succeeds" ) }, "no die on filename with parens" ); is( <$fh>, $content, "read content correctly" ); close $fh; }; subtest '2-arg open with hash in filename' => sub { my $path = '/tmp/issue#42.log'; my $content = "log entry\n"; my $mock = Test::MockFile->file( $path, $content ); my $fh; ok( lives { ok( open( $fh, $path ), "open succeeds" ) }, "no die on filename with #" ); is( <$fh>, $content, "read content correctly" ); close $fh; }; subtest '2-arg open with equals and comma in filename' => sub { my $path = '/tmp/key=value,other.conf'; my $content = "config\n"; my $mock = Test::MockFile->file( $path, $content ); my $fh; ok( lives { ok( open( $fh, $path ), "open succeeds" ) }, "no die on = and , in filename" ); is( <$fh>, $content, "read content correctly" ); close $fh; }; subtest '2-arg write mode with special chars still works' => sub { my $path = '/tmp/out file.txt'; my $mock = Test::MockFile->file( $path, '' ); my $fh; ok( open( $fh, ">$path" ), "2-arg write open with spaces works" ); print $fh "written"; close $fh; is( $mock->contents, "written", "content was written" ); }; subtest '2-arg append mode with special chars still works' => sub { my $path = '/tmp/log (daily).txt'; my $mock = Test::MockFile->file( $path, 'old ' ); my $fh; ok( open( $fh, ">>$path" ), "2-arg append open with special chars works" ); print $fh "new"; close $fh; is( $mock->contents, "old new", "content was appended" ); }; subtest '2-arg open still passes through for unmocked files' => sub { # A path with special chars that is NOT mocked should fall through to CORE # (and fail since the file doesn't exist on disk) my $fh; my $ret = open( $fh, '/nonexistent/path with spaces/file.txt' ); ok( !$ret, "2-arg open on unmocked special-char path returns false" ); }; done_testing(); Test-MockFile-0.039/t/lib/000755 000765 000024 00000000000 15160070576 016677 5ustar00todd.rinaldostaff000000 000000 Test-MockFile-0.039/t/open_return_undef.t000644 000765 000024 00000005724 15157362227 022052 0ustar00todd.rinaldostaff000000 000000 #!/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 ELOOP/; use Test::MockFile qw< nostrict >; # =================================================================== # open() failure paths must return undef (not empty list). # # Bare "return;" returns () in list context, which gives scalar(@ret)=0. # Correct behavior: "return undef;" returns (undef) — scalar(@ret)=1. # This matches CORE::open which returns undef on failure. # =================================================================== subtest 'open on non-existent file returns undef in scalar and list context' => sub { my $mock = Test::MockFile->file('/fake/noexist'); # Scalar context my $ret = open( my $fh, '<', '/fake/noexist' ); is( $ret, undef, 'open returns undef in scalar context for non-existent file' ); is( $! + 0, ENOENT, 'errno is ENOENT' ); # List context — should return (undef), not () my @ret = open( my $fh2, '<', '/fake/noexist' ); is( scalar @ret, 1, 'open returns 1-element list in list context (not empty)' ); is( $ret[0], undef, 'the single element is undef' ); }; subtest 'open on directory returns undef (EISDIR)' => sub { my $mock_dir = Test::MockFile->dir('/fake/mydir'); # Scalar context my $ret = open( my $fh, '>', '/fake/mydir' ); is( $ret, undef, 'open on directory returns undef in scalar context' ); is( $! + 0, EISDIR, 'errno is EISDIR' ); # List context my @ret = open( my $fh2, '>', '/fake/mydir' ); is( scalar @ret, 1, 'open on directory returns 1-element list in list context' ); is( $ret[0], undef, 'the single element is undef' ); }; subtest 'open on broken symlink returns undef (ENOENT)' => sub { my $mock_link = Test::MockFile->symlink( '/fake/nonexistent_target', '/fake/broken_link' ); # Scalar context my $ret = open( my $fh, '<', '/fake/broken_link' ); is( $ret, undef, 'open on broken symlink returns undef in scalar context' ); is( $! + 0, ENOENT, 'errno is ENOENT for broken symlink' ); # List context my @ret = open( my $fh2, '<', '/fake/broken_link' ); is( scalar @ret, 1, 'open on broken symlink returns 1-element list in list context' ); is( $ret[0], undef, 'the single element is undef' ); }; subtest 'open on circular symlink returns undef (ELOOP)' => sub { my $mock_a = Test::MockFile->symlink( '/fake/link_b', '/fake/link_a' ); my $mock_b = Test::MockFile->symlink( '/fake/link_a', '/fake/link_b' ); # Scalar context my $ret = open( my $fh, '<', '/fake/link_a' ); is( $ret, undef, 'open on circular symlink returns undef in scalar context' ); is( $! + 0, ELOOP, 'errno is ELOOP for circular symlink' ); # List context my @ret = open( my $fh2, '<', '/fake/link_a' ); is( scalar @ret, 1, 'open on circular symlink returns 1-element list in list context' ); is( $ret[0], undef, 'the single element is undef' ); }; done_testing(); Test-MockFile-0.039/t/filehandle_cleanup.t000644 000765 000024 00000010670 15157362227 022127 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Errno qw/EBADF/; use Test::MockFile qw; # ============================================================ # Test: CLOSE/DESTROY safety when handle outlives mock object # ============================================================ note "--- Handle outlives its mock (reversed scope exit) ---"; { my $fh; { my $mock = Test::MockFile->file( '/tmp/outlive_test', 'hello world' ); ok( open( $fh, '<', '/tmp/outlive_test' ), "open mocked file" ); my $line = <$fh>; is( $line, 'hello world', "read from mocked file" ); } # $mock is now out of scope — weak ref in FileHandle is undef. # close() should not crash. my $closed; my $lived = eval { $closed = close($fh); 1; }; ok( $lived, "close() on orphaned handle does not crash" ) or diag("Error: $@"); } note "--- DESTROY on orphaned handle (scope exit without close) ---"; { my $fh; { my $mock = Test::MockFile->file( '/tmp/destroy_test', 'data' ); ok( open( $fh, '<', '/tmp/destroy_test' ), "open mocked file" ); } # Let $fh go out of scope without explicit close. # DESTROY should not crash even though mock is gone. my $lived = eval { undef $fh; 1; }; ok( $lived, "DESTROY on orphaned handle does not crash" ) or diag("Error: $@"); } # ============================================================ # Test: READ returns EBADF on write-only handles # ============================================================ note "--- sysread on write-only handle returns EBADF ---"; { my $mock = Test::MockFile->file( '/tmp/ebadf_read_test', 'some data' ); ok( open( my $fh, '>', '/tmp/ebadf_read_test' ), "open for write-only" ); my $buf; my $result = sysread( $fh, $buf, 10 ); ok( !defined $result, "sysread on write-only handle returns undef" ); is( $! + 0, EBADF, "errno is EBADF" ); close($fh); } # ============================================================ # Test: syswrite with negative offset # ============================================================ note "--- syswrite with negative offset ---"; { my $mock = Test::MockFile->file( '/tmp/syswrite_neg_offset', '' ); ok( open( my $fh, '>', '/tmp/syswrite_neg_offset' ), "open for write" ); # syswrite with negative offset counts from end of buffer my $buf = "hello world"; my $written = syswrite( $fh, $buf, 5, -5 ); is( $written, 5, "syswrite with negative offset writes correct bytes" ); close($fh); is( $mock->contents, "world", "negative offset selected from end of string" ); } { my $mock = Test::MockFile->file( '/tmp/syswrite_neg_oob', '' ); ok( open( my $fh, '>', '/tmp/syswrite_neg_oob' ), "open for write" ); # Negative offset that goes before start of string — expect warning + EINVAL my $buf = "hi"; my @warnings; local $SIG{__WARN__} = sub { push @warnings, $_[0] }; my $result = syswrite( $fh, $buf, 2, -10 ); is( $result, 0, "syswrite with out-of-bounds negative offset returns 0" ); ok( scalar @warnings, "warning emitted for out-of-bounds offset" ); like( $warnings[0], qr/Offset outside string/, "warning mentions offset" ); close($fh); } # ============================================================ # Test: syswrite with positive offset # ============================================================ note "--- syswrite with positive offset ---"; { my $mock = Test::MockFile->file( '/tmp/syswrite_pos_offset', '' ); ok( open( my $fh, '>', '/tmp/syswrite_pos_offset' ), "open for write" ); my $buf = "hello world"; my $written = syswrite( $fh, $buf, 5, 6 ); is( $written, 5, "syswrite with positive offset writes correct bytes" ); close($fh); is( $mock->contents, "world", "positive offset skipped beginning of buffer" ); } { my $mock = Test::MockFile->file( '/tmp/syswrite_oob_offset', '' ); ok( open( my $fh, '>', '/tmp/syswrite_oob_offset' ), "open for write" ); # Per perlapi: len exceeding available data is NOT an error — syswrite # truncates silently and writes what's available. my $buf = "hi"; my $result = syswrite( $fh, $buf, 5, 0 ); is( $result, 2, "syswrite with len > strlen writes available bytes" ); close($fh); is( $mock->contents, "hi", "file contains truncated write" ); } done_testing(); Test-MockFile-0.039/t/detect-common-mistakes.t000644 000765 000024 00000010646 15157362227 022704 0ustar00todd.rinaldostaff000000 000000 #!/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.039/t/write_tell.t000644 000765 000024 00000031425 15157362227 020500 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Fcntl qw( O_RDWR O_CREAT O_TRUNC O_WRONLY ); use Errno qw( EBADF EINVAL ); use Test::MockFile qw< nostrict >; { note "--- tell() advances after print ---"; my $mock = Test::MockFile->file('/fake/write_tell'); open( my $fh, '>', '/fake/write_tell' ) or die; is( tell($fh), 0, "tell is 0 before any writes" ); print $fh "Hello"; is( tell($fh), 5, "tell is 5 after printing 'Hello'" ); print $fh " World"; is( tell($fh), 11, "tell is 11 after printing ' World'" ); close $fh; is( $mock->contents, "Hello World", "Contents are correct" ); } { note "--- tell() advances after printf ---"; my $mock = Test::MockFile->file('/fake/printf_tell'); open( my $fh, '>', '/fake/printf_tell' ) or die; printf $fh "%04d", 42; is( tell($fh), 4, "tell is 4 after printf '%04d'" ); printf $fh "-%s-", "test"; is( tell($fh), 10, "tell is 10 after second printf" ); close $fh; is( $mock->contents, "0042-test-", "Contents are correct" ); } { note "--- tell() advances after syswrite ---"; my $mock = Test::MockFile->file('/fake/syswrite_tell'); sysopen( my $fh, '/fake/syswrite_tell', O_WRONLY | O_CREAT | O_TRUNC ) or die; syswrite( $fh, "ABCDE", 5 ); is( tell($fh), 5, "tell is 5 after syswrite of 5 bytes" ); syswrite( $fh, "FGH", 3 ); is( tell($fh), 8, "tell is 8 after syswrite of 3 more bytes" ); close $fh; is( $mock->contents, "ABCDEFGH", "Contents are correct" ); } { note "--- tell() after write then read (read+write mode) ---"; my $mock = Test::MockFile->file('/fake/rw_tell'); sysopen( my $fh, '/fake/rw_tell', O_RDWR | O_CREAT | O_TRUNC ) or die; syswrite( $fh, "Hello World", 11 ); is( tell($fh), 11, "tell is 11 after writing 'Hello World'" ); seek( $fh, 0, 0 ); is( tell($fh), 0, "tell is 0 after seeking to start" ); my $buf = ""; read( $fh, $buf, 5 ); is( $buf, "Hello", "Read back 'Hello'" ); is( tell($fh), 5, "tell is 5 after reading 5 bytes" ); } { note "--- tell() after append mode ---"; my $mock = Test::MockFile->file( '/fake/append_tell', "existing" ); open( my $fh, '>>', '/fake/append_tell' ) or die; print $fh " data"; is( tell($fh), 13, "tell is 13 after appending to 'existing'" ); close $fh; is( $mock->contents, "existing data", "Contents are correct" ); } { note "--- printing undef does not change tell ---"; my $mock = Test::MockFile->file('/fake/undef_tell'); open( my $fh, '>', '/fake/undef_tell' ) or die; print $fh "ABC"; is( tell($fh), 3, "tell is 3 after printing 'ABC'" ); print $fh undef; is( tell($fh), 3, "tell unchanged after printing undef" ); close $fh; is( $mock->contents, "ABC", "Contents are correct" ); } { note "--- print with explicit output record separator ---"; my $mock = Test::MockFile->file('/fake/ors_tell'); open( my $fh, '>', '/fake/ors_tell' ) or die; { local $\ = "\n"; print $fh "Hello"; } is( tell($fh), 6, "tell is 6 after print with ORS (5 chars + newline)" ); close $fh; is( $mock->contents, "Hello\n", "Contents include newline from output record separator" ); } # Note: say() with tied filehandles does NOT append the newline via $\. # Perl handles say's newline at the C level (pp_print) after the tied # PRINT method returns, so it is never passed to PRINT. This is a known # limitation of tied filehandles in Perl. { note "--- +< mode: seek + print overwrites at tell position ---"; my $mock = Test::MockFile->file( '/fake/rw_overwrite', "Hello World!" ); open( my $fh, '+<', '/fake/rw_overwrite' ) or die; # Seek to position 6 and overwrite seek( $fh, 6, 0 ); is( tell($fh), 6, "tell is 6 after seek" ); print $fh "Perl!"; is( tell($fh), 11, "tell is 11 after printing 5 bytes at position 6" ); close $fh; is( $mock->contents, "Hello Perl!!", "Overwrite at position 6 replaces 'World' with 'Perl!'" ); } { note "--- +< mode: seek + print does not extend past original when write fits ---"; my $mock = Test::MockFile->file( '/fake/rw_exact', "ABCDEFGH" ); open( my $fh, '+<', '/fake/rw_exact' ) or die; seek( $fh, 3, 0 ); print $fh "XY"; close $fh; is( $mock->contents, "ABCXYFGH", "Overwrite at position 3 replaces 2 bytes" ); } { note "--- +< mode: print at tell 0 overwrites from start ---"; my $mock = Test::MockFile->file( '/fake/rw_start', "old content" ); open( my $fh, '+<', '/fake/rw_start' ) or die; # tell starts at 0 print $fh "NEW"; close $fh; is( $mock->contents, "NEW content", "Print at position 0 overwrites first 3 bytes" ); } { note "--- +< mode: print extending past end grows the file ---"; my $mock = Test::MockFile->file( '/fake/rw_extend', "short" ); open( my $fh, '+<', '/fake/rw_extend' ) or die; seek( $fh, 3, 0 ); print $fh "LONGER"; close $fh; is( $mock->contents, "shoLONGER", "Print past end extends the file" ); is( length( $mock->contents ), 9, "File length is 9" ); } { note "--- >> mode: seek then print still appends ---"; my $mock = Test::MockFile->file( '/fake/append_seek', "AAAA" ); open( my $fh, '>>', '/fake/append_seek' ) or die; # Even after seeking to 0, append mode writes at end seek( $fh, 0, 0 ); print $fh "BB"; close $fh; is( $mock->contents, "AAAABB", "Append mode ignores seek position" ); } { note "--- +< mode: interleaved read and write ---"; my $mock = Test::MockFile->file( '/fake/rw_interleave', "Hello World" ); open( my $fh, '+<', '/fake/rw_interleave' ) or die; # Read first 5 bytes my $buf; read( $fh, $buf, 5 ); is( $buf, "Hello", "Read 'Hello'" ); is( tell($fh), 5, "tell is 5 after read" ); # Write at current position (overwrite ' World' with ' Perl!') print $fh " Perl!"; is( tell($fh), 11, "tell is 11 after write" ); close $fh; is( $mock->contents, "Hello Perl!", "Interleaved read+write produces correct output" ); } { note "--- > mode: print writes at tell position (not append) ---"; my $mock = Test::MockFile->file('/fake/write_overwrite'); open( my $fh, '>', '/fake/write_overwrite' ) or die; # Write initial content print $fh "ABCDEFGH"; is( tell($fh), 8, "tell is 8 after initial write" ); # Seek back and overwrite seek( $fh, 2, 0 ); print $fh "XY"; is( tell($fh), 4, "tell is 4 after overwrite" ); close $fh; is( $mock->contents, "ABXYEFGH", "Overwrite in > mode at seek position" ); } { note "--- syswrite must NOT inherit output record separator (\$\\) ---"; my $mock = Test::MockFile->file('/fake/syswrite_no_ors'); sysopen( my $fh, '/fake/syswrite_no_ors', O_WRONLY | O_CREAT | O_TRUNC ) or die; { local $\ = "\n"; syswrite( $fh, "Hello", 5 ); } is( tell($fh), 5, "tell is 5 after syswrite (no ORS added)" ); close $fh; is( $mock->contents, "Hello", "syswrite ignores \$\\ — no newline appended" ); } { note "--- syswrite must NOT inherit output field separator (\$,) ---"; my $mock = Test::MockFile->file('/fake/syswrite_no_ofs'); sysopen( my $fh, '/fake/syswrite_no_ofs', O_WRONLY | O_CREAT | O_TRUNC ) or die; { local $, = ","; syswrite( $fh, "Hello", 5 ); } is( tell($fh), 5, "tell is 5 after syswrite with \$, set" ); close $fh; is( $mock->contents, "Hello", "syswrite ignores \$, — no separator" ); } { note "--- syswrite returns byte count, not boolean ---"; my $mock = Test::MockFile->file('/fake/syswrite_return'); sysopen( my $fh, '/fake/syswrite_return', O_WRONLY | O_CREAT | O_TRUNC ) or die; my $ret = syswrite( $fh, "ABCDE", 5 ); is( $ret, 5, "syswrite returns 5 for 5 bytes written" ); $ret = syswrite( $fh, "XY", 2 ); is( $ret, 2, "syswrite returns 2 for 2 bytes written" ); # syswrite with $\ set should NOT include $\ in return value { local $\ = "\n"; $ret = syswrite( $fh, "end", 3 ); } is( $ret, 3, "syswrite returns 3 even with \$\\ set (not 4)" ); close $fh; is( $mock->contents, "ABCDEXYend", "All syswrite data correct, no ORS" ); } { note "--- contrast: print DOES use \$\\ while syswrite does NOT ---"; my $mock = Test::MockFile->file('/fake/print_vs_syswrite'); sysopen( my $fh, '/fake/print_vs_syswrite', O_RDWR | O_CREAT | O_TRUNC ) or die; { local $\ = "!"; # print should append $\ print $fh "Hello"; # syswrite should NOT append $\ syswrite( $fh, "World", 5 ); } close $fh; is( $mock->contents, "Hello!World", "print appends ORS, syswrite does not" ); } { note "--- syswrite on read-only handle returns EBADF ---"; my $mock = Test::MockFile->file( '/fake/syswrite_ebadf', "read only data" ); open( my $fh, '<', '/fake/syswrite_ebadf' ) or die; local $!; my $ret = syswrite( $fh, "nope", 4 ); is( $ret, 0, "syswrite on read-only handle returns 0" ); is( $! + 0, EBADF, "errno is EBADF for syswrite on read-only handle" ); close $fh; } { note "--- syswrite with negative offset (counts from end of buffer) ---"; my $mock = Test::MockFile->file('/fake/syswrite_neg_offset'); sysopen( my $fh, '/fake/syswrite_neg_offset', O_WRONLY | O_CREAT | O_TRUNC ) or die; # syswrite with offset -2 on "ABCDE" → starts at position 3, writes "DE" my $ret = syswrite( $fh, "ABCDE", 2, -2 ); is( $ret, 2, "syswrite with negative offset returns bytes written" ); close $fh; is( $mock->contents, "DE", "syswrite with offset -2 writes last 2 bytes of buffer" ); } { note "--- syswrite with negative offset past buffer start → error ---"; my $mock = Test::MockFile->file('/fake/syswrite_neg_oob'); sysopen( my $fh, '/fake/syswrite_neg_oob', O_WRONLY | O_CREAT | O_TRUNC ) or die; # offset -10 on a 3-char string: abs(-10) > 3 → error local $!; my @warns; local $SIG{__WARN__} = sub { push @warns, $_[0] }; my $ret = syswrite( $fh, "abc", 3, -10 ); is( $ret, 0, "syswrite with offset past buffer start returns 0" ); is( $! + 0, EINVAL, "errno is EINVAL for out-of-bounds negative offset" ); ok( grep( /Offset outside string/, @warns ), "warning emitted for out-of-bounds negative offset" ); close $fh; is( $mock->contents, '', "no data written on out-of-bounds negative offset" ); } { note "--- syswrite with positive offset past buffer end → error ---"; my $mock = Test::MockFile->file('/fake/syswrite_pos_oob'); sysopen( my $fh, '/fake/syswrite_pos_oob', O_WRONLY | O_CREAT | O_TRUNC ) or die; # offset 10 on a 3-char string → error local $!; my @warns; local $SIG{__WARN__} = sub { push @warns, $_[0] }; my $ret = syswrite( $fh, "abc", 3, 10 ); is( $ret, 0, "syswrite with offset past buffer end returns 0" ); is( $! + 0, EINVAL, "errno is EINVAL for out-of-bounds positive offset" ); ok( grep( /Offset outside string/, @warns ), "warning emitted for out-of-bounds positive offset" ); close $fh; is( $mock->contents, '', "no data written on out-of-bounds positive offset" ); } { note "--- syswrite with len exceeding available data (truncates silently) ---"; my $mock = Test::MockFile->file('/fake/syswrite_truncate'); sysopen( my $fh, '/fake/syswrite_truncate', O_WRONLY | O_CREAT | O_TRUNC ) or die; # Ask for 100 bytes from offset 2 of "ABCDE" — only 3 available my $ret = syswrite( $fh, "ABCDE", 100, 2 ); is( $ret, 3, "syswrite returns actual bytes written when len exceeds buffer" ); close $fh; is( $mock->contents, "CDE", "syswrite truncates to available data" ); } { note "--- printf must NOT inherit output record separator (\$\\) ---"; my $mock = Test::MockFile->file('/fake/printf_no_ors'); open( my $fh, '>', '/fake/printf_no_ors' ) or die; { local $\ = "\n"; printf $fh "%s=%d", "count", 42; } is( tell($fh), 8, "tell is 8 after printf (no ORS added)" ); close $fh; is( $mock->contents, "count=42", "printf ignores \$\\ — no newline appended" ); } { note "--- contrast: print uses \$\\, printf and syswrite do not ---"; my $mock = Test::MockFile->file('/fake/print_printf_syswrite'); sysopen( my $fh, '/fake/print_printf_syswrite', O_RDWR | O_CREAT | O_TRUNC ) or die; { local $\ = "!"; # print appends $\ print $fh "A"; # printf does NOT append $\ printf $fh "%s", "B"; # syswrite does NOT append $\ syswrite( $fh, "C", 1 ); } close $fh; is( $mock->contents, "A!BC", "print appends ORS; printf and syswrite do not" ); } is( \%Test::MockFile::files_being_mocked, {}, "No mock files are in cache" ); done_testing(); exit; Test-MockFile-0.039/t/symlink_follow_ops.t000644 000765 000024 00000013056 15157362227 022257 0ustar00todd.rinaldostaff000000 000000 use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Errno qw( ENOENT ELOOP EISDIR ); use Test::MockFile qw< nostrict >; # Tests that chmod, chown, utime, and truncate follow symlinks # and operate on the target file, not the symlink itself. subtest 'chmod follows symlinks' => sub { my $file = Test::MockFile->file( '/fake/target', 'data', { mode => 0644 | Test::MockFile::S_IFREG() } ); my $link = Test::MockFile->symlink( '/fake/target', '/fake/link' ); is( chmod( 0755, '/fake/link' ), 1, 'chmod via symlink returns 1' ); is( sprintf( '%04o', ( stat '/fake/target' )[2] & 07777 ), '0755', 'target file permissions changed through symlink', ); }; subtest 'chmod on broken symlink fails with ENOENT' => sub { my $link = Test::MockFile->symlink( '/fake/nowhere', '/fake/broken_chmod' ); is( chmod( 0755, '/fake/broken_chmod' ), 0, 'chmod on broken symlink returns 0' ); is( $! + 0, ENOENT, '$! is ENOENT for broken symlink' ); }; subtest 'chmod follows chain of symlinks' => sub { my $file = Test::MockFile->file( '/fake/chain_target', 'data', { mode => 0600 | Test::MockFile::S_IFREG() } ); my $link1 = Test::MockFile->symlink( '/fake/chain_target', '/fake/chain1' ); my $link2 = Test::MockFile->symlink( '/fake/chain1', '/fake/chain2' ); is( chmod( 0700, '/fake/chain2' ), 1, 'chmod through symlink chain returns 1' ); is( sprintf( '%04o', ( stat '/fake/chain_target' )[2] & 07777 ), '0700', 'target file permissions changed through symlink chain', ); }; subtest 'chown follows symlinks' => sub { my $file = Test::MockFile->file( '/fake/chown_target', 'data' ); my $link = Test::MockFile->symlink( '/fake/chown_target', '/fake/chown_link' ); # chown with current user's uid/gid to avoid permission errors my $result = chown( $>, $) + 0, '/fake/chown_link' ); is( $result, 1, 'chown via symlink returns 1' ); my @stat = stat('/fake/chown_target'); is( $stat[4], $>, 'target uid set through symlink' ); }; subtest 'chown on broken symlink fails with ENOENT' => sub { my $link = Test::MockFile->symlink( '/fake/nowhere', '/fake/broken_chown' ); my $result = chown( $>, $) + 0, '/fake/broken_chown' ); is( $result, 0, 'chown on broken symlink returns 0' ); is( $! + 0, ENOENT, '$! is ENOENT for broken symlink' ); }; subtest 'utime follows symlinks' => sub { my $file = Test::MockFile->file( '/fake/utime_target', 'data' ); my $link = Test::MockFile->symlink( '/fake/utime_target', '/fake/utime_link' ); my $atime = 1_000_000; my $mtime = 2_000_000; is( utime( $atime, $mtime, '/fake/utime_link' ), 1, 'utime via symlink returns 1' ); my @stat = stat('/fake/utime_target'); is( $stat[8], $atime, 'target atime set through symlink' ); is( $stat[9], $mtime, 'target mtime set through symlink' ); }; subtest 'utime on broken symlink fails with ENOENT' => sub { my $link = Test::MockFile->symlink( '/fake/nowhere', '/fake/broken_utime' ); is( utime( 100, 200, '/fake/broken_utime' ), 0, 'utime on broken symlink returns 0' ); is( $! + 0, ENOENT, '$! is ENOENT for broken symlink' ); }; subtest 'utime follows chain of symlinks' => sub { my $file = Test::MockFile->file( '/fake/uchain_target', 'data' ); my $link1 = Test::MockFile->symlink( '/fake/uchain_target', '/fake/uchain1' ); my $link2 = Test::MockFile->symlink( '/fake/uchain1', '/fake/uchain2' ); my $atime = 3_000_000; my $mtime = 4_000_000; is( utime( $atime, $mtime, '/fake/uchain2' ), 1, 'utime through chain returns 1' ); my @stat = stat('/fake/uchain_target'); is( $stat[8], $atime, 'target atime set through symlink chain' ); is( $stat[9], $mtime, 'target mtime set through symlink chain' ); }; subtest 'truncate follows symlinks (by path)' => sub { my $file = Test::MockFile->file( '/fake/trunc_target', 'hello world' ); my $link = Test::MockFile->symlink( '/fake/trunc_target', '/fake/trunc_link' ); ok( truncate( '/fake/trunc_link', 5 ), 'truncate via symlink returns true' ); is( $file->contents(), 'hello', 'target file truncated through symlink' ); }; subtest 'truncate on broken symlink fails with ENOENT' => sub { my $link = Test::MockFile->symlink( '/fake/nowhere', '/fake/broken_trunc' ); ok( !truncate( '/fake/broken_trunc', 0 ), 'truncate on broken symlink returns false' ); is( $! + 0, ENOENT, '$! is ENOENT for broken symlink' ); }; subtest 'truncate follows symlink to directory fails with EISDIR' => sub { my $dir = Test::MockFile->new_dir('/fake/trunc_dir'); my $link = Test::MockFile->symlink( '/fake/trunc_dir', '/fake/trunc_dir_link' ); ok( !truncate( '/fake/trunc_dir_link', 0 ), 'truncate on symlink-to-dir returns false' ); is( $! + 0, EISDIR, '$! is EISDIR' ); }; subtest 'multiple files with symlinks in chmod' => sub { my $file1 = Test::MockFile->file( '/fake/multi1', 'a', { mode => 0600 | Test::MockFile::S_IFREG() } ); my $file2 = Test::MockFile->file( '/fake/multi2', 'b', { mode => 0600 | Test::MockFile::S_IFREG() } ); my $link = Test::MockFile->symlink( '/fake/multi2', '/fake/multi_link' ); is( chmod( 0755, '/fake/multi1', '/fake/multi_link' ), 2, 'chmod on file + symlink returns 2' ); is( sprintf( '%04o', ( stat '/fake/multi1' )[2] & 07777 ), '0755', 'first file permissions changed', ); is( sprintf( '%04o', ( stat '/fake/multi2' )[2] & 07777 ), '0755', 'second file (via symlink) permissions changed', ); }; done_testing(); Test-MockFile-0.039/t/open_dir_symlink.t000644 000765 000024 00000015512 15157362227 021672 0ustar00todd.rinaldostaff000000 000000 #!/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/EISDIR ENOENT ELOOP/; use Test::MockFile qw< nostrict >; # ======================================================= # EISDIR: open() on a directory mock should fail # ======================================================= note "--- open() on directory mocks returns EISDIR ---"; { my $dir = Test::MockFile->new_dir('/fake/dir'); ok( -d '/fake/dir', "Directory mock exists" ); ok( !open( my $fh, '<', '/fake/dir' ), "open('<') on dir fails" ); is( $! + 0, EISDIR, "errno is EISDIR for read open on dir" ); ok( !open( $fh, '>', '/fake/dir' ), "open('>') on dir fails" ); is( $! + 0, EISDIR, "errno is EISDIR for write open on dir" ); ok( !open( $fh, '>>', '/fake/dir' ), "open('>>') on dir fails" ); is( $! + 0, EISDIR, "errno is EISDIR for append open on dir" ); ok( !open( $fh, '+<', '/fake/dir' ), "open('+<') on dir fails" ); is( $! + 0, EISDIR, "errno is EISDIR for read-write open on dir" ); ok( !open( $fh, '+>', '/fake/dir' ), "open('+>') on dir fails" ); is( $! + 0, EISDIR, "errno is EISDIR for write-read open on dir" ); } # ======================================================= # EISDIR: sysopen() on a directory mock should fail # ======================================================= note "--- sysopen() on directory mocks returns EISDIR ---"; { my $dir = Test::MockFile->new_dir('/fake/sysdir'); ok( -d '/fake/sysdir', "Directory mock exists" ); ok( !sysopen( my $fh, '/fake/sysdir', O_RDONLY ), "sysopen(O_RDONLY) on dir fails" ); is( $! + 0, EISDIR, "errno is EISDIR for O_RDONLY sysopen on dir" ); ok( !sysopen( $fh, '/fake/sysdir', O_WRONLY ), "sysopen(O_WRONLY) on dir fails" ); is( $! + 0, EISDIR, "errno is EISDIR for O_WRONLY sysopen on dir" ); ok( !sysopen( $fh, '/fake/sysdir', O_RDWR ), "sysopen(O_RDWR) on dir fails" ); is( $! + 0, EISDIR, "errno is EISDIR for O_RDWR sysopen on dir" ); ok( !sysopen( $fh, '/fake/sysdir', O_WRONLY | O_CREAT ), "sysopen(O_WRONLY|O_CREAT) on dir fails" ); is( $! + 0, EISDIR, "errno is EISDIR even with O_CREAT on dir" ); } # ======================================================= # sysopen() follows symlinks to the target file # ======================================================= note "--- sysopen() follows symlinks ---"; { my $file = Test::MockFile->file( '/fake/target', 'original' ); my $symlink = Test::MockFile->symlink( '/fake/target', '/fake/link' ); ok( -l '/fake/link', "Symlink mock exists" ); ok( -f '/fake/target', "Target file exists" ); # sysopen through symlink for reading ok( sysopen( my $fh, '/fake/link', O_RDONLY ), "sysopen(O_RDONLY) through symlink succeeds" ); my $buf; sysread( $fh, $buf, 100 ); is( $buf, 'original', "Read through symlink returns target contents" ); close $fh; # sysopen through symlink for writing ok( sysopen( $fh, '/fake/link', O_WRONLY | O_TRUNC ), "sysopen(O_WRONLY|O_TRUNC) through symlink succeeds" ); syswrite( $fh, 'updated' ); close $fh; is( $file->contents(), 'updated', "Write through symlink updates target file" ); } # ======================================================= # sysopen() with O_NOFOLLOW rejects symlinks with ELOOP # ======================================================= note "--- sysopen() O_NOFOLLOW rejects symlinks ---"; { my $file = Test::MockFile->file( '/fake/target2', 'data' ); my $symlink = Test::MockFile->symlink( '/fake/target2', '/fake/link2' ); ok( !sysopen( my $fh, '/fake/link2', O_RDONLY | O_NOFOLLOW ), "sysopen(O_NOFOLLOW) on symlink fails" ); is( $! + 0, ELOOP, "errno is ELOOP for O_NOFOLLOW on symlink" ); # O_NOFOLLOW on a regular file should work fine ok( sysopen( $fh, '/fake/target2', O_RDONLY | O_NOFOLLOW ), "sysopen(O_NOFOLLOW) on regular file succeeds" ); close $fh; } # ======================================================= # sysopen() through a broken symlink returns ENOENT # ======================================================= note "--- sysopen() through broken symlink returns ENOENT ---"; { # A symlink pointing to a path with no mock at all my $symlink = Test::MockFile->symlink( '/fake/nowhere', '/fake/broken_link' ); ok( -l '/fake/broken_link', "Broken symlink mock exists" ); ok( !sysopen( my $fh, '/fake/broken_link', O_RDONLY ), "sysopen(O_RDONLY) through broken symlink fails" ); is( $! + 0, ENOENT, "errno is ENOENT for broken symlink" ); ok( !sysopen( $fh, '/fake/broken_link', O_WRONLY ), "sysopen(O_WRONLY) through broken symlink fails" ); is( $! + 0, ENOENT, "errno is ENOENT for broken symlink write" ); } # ======================================================= # sysopen() through a circular symlink returns ELOOP # ======================================================= note "--- sysopen() through circular symlink returns ELOOP ---"; { my $link_a = Test::MockFile->symlink( '/fake/circ_b', '/fake/circ_a' ); my $link_b = Test::MockFile->symlink( '/fake/circ_a', '/fake/circ_b' ); ok( !sysopen( my $fh, '/fake/circ_a', O_RDONLY ), "sysopen through circular symlink fails" ); is( $! + 0, ELOOP, "errno is ELOOP for circular symlink" ); } # ======================================================= # Double O_TRUNC was removed: verify O_TRUNC works correctly once # ======================================================= note "--- sysopen() O_TRUNC applied correctly ---"; { my $file = Test::MockFile->file( '/fake/trunc', 'existing content' ); ok( sysopen( my $fh, '/fake/trunc', O_WRONLY | O_TRUNC ), "sysopen(O_WRONLY|O_TRUNC) succeeds" ); is( $file->contents(), '', "O_TRUNC clears file contents" ); syswrite( $fh, 'new' ); close $fh; is( $file->contents(), 'new', "Contents after O_TRUNC write" ); } { # O_TRUNC without O_CREAT on non-existent file should fail my $file = Test::MockFile->file('/fake/trunc_noexist'); ok( !sysopen( my $fh, '/fake/trunc_noexist', O_RDONLY | O_TRUNC ), "sysopen(O_RDONLY|O_TRUNC) on non-existent fails" ); is( $! + 0, ENOENT, "errno is ENOENT for O_TRUNC on non-existent" ); ok( !defined $file->contents(), "Contents still undef (file not created)" ); } # ======================================================= # Verify directory mock state is not corrupted # ======================================================= note "--- directory mock state preserved after failed open ---"; { my $dir = Test::MockFile->new_dir('/fake/preserved_dir'); # Attempt to open it (should fail) open( my $fh, '>', '/fake/preserved_dir' ); # Verify the mock is still a healthy directory ok( -d '/fake/preserved_dir', "Dir is still a directory after failed open" ); is( ref $dir->contents(), 'ARRAY', "Dir contents still returns arrayref" ); } done_testing(); Test-MockFile-0.039/t/import.t000644 000765 000024 00000005367 15157362227 017646 0ustar00todd.rinaldostaff000000 000000 #!/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.039/t/autodie_sysopen.t000644 000765 000024 00000012635 15160070345 021531 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl # Test autodie compatibility with sysopen in Test::MockFile. # # autodie installs per-package wrappers that call CORE::sysopen directly, # bypassing CORE::GLOBAL::sysopen. Test::MockFile's per-package overrides # handle this. This test verifies that autodie exceptions are properly # thrown when mocked sysopen operations fail. use strict; use warnings; use Test::More; use Fcntl qw( O_RDONLY O_WRONLY O_RDWR O_CREAT O_EXCL O_TRUNC ); # Skip if autodie is not available BEGIN { eval { require autodie }; if ($@) { plan skip_all => 'autodie not available'; } } # Load both — autodie first, then Test::MockFile. use autodie qw(sysopen); use Test::MockFile qw(nostrict); subtest 'sysopen mocked file succeeds with autodie active' => sub { my $file = "/autodie_sysopen_read_$$"; my $mock = Test::MockFile->file( $file, "test content" ); my $ok = eval { sysopen( my $fh, $file, O_RDONLY ); ok( defined $fh, "filehandle defined" ); close($fh); 1; }; ok( $ok, "sysopen O_RDONLY on existing mocked file does not die" ) or diag("Error: $@"); }; subtest 'sysopen O_CREAT creates file with autodie active' => sub { my $file = "/autodie_sysopen_create_$$"; my $mock = Test::MockFile->file( $file, undef ); my $ok = eval { sysopen( my $fh, $file, O_WRONLY | O_CREAT ); ok( defined $fh, "filehandle defined after O_CREAT" ); close($fh); 1; }; ok( $ok, "sysopen O_CREAT on non-existent mocked file does not die" ) or diag("Error: $@"); is( $mock->contents(), '', "file created with empty contents" ) if $ok; }; subtest 'sysopen O_RDWR on existing file with autodie active' => sub { my $file = "/autodie_sysopen_rdwr_$$"; my $mock = Test::MockFile->file( $file, "existing data" ); my $ok = eval { sysopen( my $fh, $file, O_RDWR ); ok( defined $fh, "filehandle defined for O_RDWR" ); close($fh); 1; }; ok( $ok, "sysopen O_RDWR on existing mocked file does not die" ) or diag("Error: $@"); }; SKIP: { subtest 'autodie dies on sysopen O_RDONLY non-existent file' => sub { my $file = "/autodie_sysopen_noexist_$$"; my $mock = Test::MockFile->file( $file, undef ); my $died = !eval { sysopen( my $fh, $file, O_RDONLY ); 1; }; ok( $died, "autodie dies when sysopen O_RDONLY on non-existent mocked file" ); ok( defined $@, "exception is set" ) if $died; }; subtest 'autodie exception is autodie::exception for sysopen' => sub { my $file = "/autodie_sysopen_exc_$$"; my $mock = Test::MockFile->file( $file, undef ); eval { sysopen( my $fh, $file, O_RDONLY ); }; my $err = $@; # Save before next eval clobbers it if ( eval { require autodie::exception; 1 } ) { isa_ok( $err, 'autodie::exception', 'exception is autodie::exception object' ); is( $err->function, 'CORE::sysopen', 'exception function is CORE::sysopen' ); } else { ok( defined $err, "exception is set (autodie::exception not loadable)" ); } }; subtest 'autodie dies on sysopen O_EXCL existing file' => sub { my $file = "/autodie_sysopen_excl_$$"; my $mock = Test::MockFile->file( $file, "already here" ); my $died = !eval { sysopen( my $fh, $file, O_WRONLY | O_CREAT | O_EXCL ); 1; }; my $err = $@; ok( $died, "autodie dies on O_EXCL when file exists" ); if ( $died && eval { require autodie::exception; 1 } ) { isa_ok( $err, 'autodie::exception', 'O_EXCL exception type' ); } }; subtest 'autodie dies on sysopen directory' => sub { my $dir = "/autodie_sysopen_dir_$$"; my $mock = Test::MockFile->new_dir( $dir ); my $died = !eval { sysopen( my $fh, $dir, O_RDONLY ); 1; }; my $err = $@; ok( $died, "autodie dies on sysopen of directory (EISDIR)" ); if ( $died && eval { require autodie::exception; 1 } ) { isa_ok( $err, 'autodie::exception', 'EISDIR exception type' ); } }; subtest 'autodie dies on sysopen broken symlink' => sub { my $link = "/autodie_sysopen_brokenlink_$$"; my $target = "/autodie_sysopen_missing_target_$$"; my $mock_link = Test::MockFile->symlink( $target, $link ); my $died = !eval { sysopen( my $fh, $link, O_RDONLY ); 1; }; my $err = $@; ok( $died, "autodie dies on sysopen of broken symlink (ENOENT)" ); if ( $died && eval { require autodie::exception; 1 } ) { isa_ok( $err, 'autodie::exception', 'broken symlink exception type' ); } }; subtest 'sysopen succeeds through valid symlink with autodie' => sub { my $link = "/autodie_sysopen_goodlink_$$"; my $target = "/autodie_sysopen_target_$$"; my $mock_target = Test::MockFile->file( $target, "via symlink" ); my $mock_link = Test::MockFile->symlink( $target, $link ); my $ok = eval { sysopen( my $fh, $link, O_RDONLY ); ok( defined $fh, "filehandle defined through symlink" ); close($fh); 1; }; ok( $ok, "sysopen through valid symlink does not die with autodie" ) or diag("Error: $@"); }; } done_testing(); Test-MockFile-0.039/t/dir_mtime.t000644 000765 000024 00000013077 15157362227 020302 0ustar00todd.rinaldostaff000000 000000 use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Test::MockFile qw< nostrict >; # GitHub issue #186: parent directory mtime should update when contents change. # # Note: Test::MockFile->dir() creates a mock placeholder that does NOT yet # "exist" (stat returns empty). Use new_dir() to create an existing directory, # or create a file with content inside it first. # Helper: sleep 1 second to ensure mtime changes are detectable. # Perl's time() has second-level granularity. sub wait_for_time_change { sleep 1; } subtest 'file creation updates parent dir mtime' => sub { my $dir = Test::MockFile->new_dir('/mtime_test1'); my $dir_mtime_before = ( stat '/mtime_test1' )[9]; ok( defined $dir_mtime_before, 'directory has mtime' ); wait_for_time_change(); my $file = Test::MockFile->file( '/mtime_test1/newfile.txt', 'content' ); my $dir_mtime_after = ( stat '/mtime_test1' )[9]; ok( $dir_mtime_after > $dir_mtime_before, 'dir mtime updated after file creation' ); }; subtest 'file creation without content does not update parent dir mtime' => sub { my $dir = Test::MockFile->new_dir('/mtime_test2'); my $dir_mtime_before = ( stat '/mtime_test2' )[9]; wait_for_time_change(); # File with undef contents = non-existent file, no directory entry added my $file = Test::MockFile->file('/mtime_test2/ghost.txt'); my $dir_mtime_after = ( stat '/mtime_test2' )[9]; is( $dir_mtime_after, $dir_mtime_before, 'dir mtime NOT updated for file with undef contents' ); }; subtest 'unlink updates parent dir mtime' => sub { my $dir = Test::MockFile->new_dir('/mtime_test3'); my $file = Test::MockFile->file( '/mtime_test3/doomed.txt', 'bye' ); wait_for_time_change(); my $dir_mtime_before = ( stat '/mtime_test3' )[9]; wait_for_time_change(); unlink '/mtime_test3/doomed.txt'; my $dir_mtime_after = ( stat '/mtime_test3' )[9]; ok( $dir_mtime_after > $dir_mtime_before, 'dir mtime updated after unlink' ); }; subtest 'mkdir updates parent dir mtime' => sub { my $parent = Test::MockFile->new_dir('/mtime_test4'); my $child = Test::MockFile->dir('/mtime_test4/subdir'); wait_for_time_change(); my $parent_mtime_before = ( stat '/mtime_test4' )[9]; wait_for_time_change(); mkdir '/mtime_test4/subdir'; my $parent_mtime_after = ( stat '/mtime_test4' )[9]; ok( $parent_mtime_after > $parent_mtime_before, 'parent dir mtime updated after mkdir' ); }; subtest 'rmdir updates parent dir mtime' => sub { my $parent = Test::MockFile->new_dir('/mtime_test5'); my $child = Test::MockFile->new_dir('/mtime_test5/subdir'); wait_for_time_change(); my $parent_mtime_before = ( stat '/mtime_test5' )[9]; wait_for_time_change(); rmdir '/mtime_test5/subdir'; my $parent_mtime_after = ( stat '/mtime_test5' )[9]; ok( $parent_mtime_after > $parent_mtime_before, 'parent dir mtime updated after rmdir' ); }; subtest 'open for write creates file and updates parent dir mtime' => sub { my $dir = Test::MockFile->new_dir('/mtime_test6'); my $mock = Test::MockFile->file('/mtime_test6/new.txt'); # undef contents wait_for_time_change(); my $dir_mtime_before = ( stat '/mtime_test6' )[9]; wait_for_time_change(); open( my $fh, '>', '/mtime_test6/new.txt' ) or die "open: $!"; print {$fh} "hello"; close $fh; my $dir_mtime_after = ( stat '/mtime_test6' )[9]; ok( $dir_mtime_after > $dir_mtime_before, 'dir mtime updated when open creates new file' ); }; subtest 'open existing file for write does NOT update parent dir mtime' => sub { my $dir = Test::MockFile->new_dir('/mtime_test7'); my $mock = Test::MockFile->file( '/mtime_test7/exists.txt', 'old content' ); wait_for_time_change(); my $dir_mtime_before = ( stat '/mtime_test7' )[9]; # Opening an existing file for write (truncate) should NOT update parent mtime # Only creating new directory entries updates parent mtime. open( my $fh, '>', '/mtime_test7/exists.txt' ) or die "open: $!"; print {$fh} "new content"; close $fh; my $dir_mtime_after = ( stat '/mtime_test7' )[9]; is( $dir_mtime_after, $dir_mtime_before, 'dir mtime NOT updated when opening existing file for write' ); }; subtest 'symlink creation updates parent dir mtime' => sub { my $dir = Test::MockFile->new_dir('/mtime_test8'); my $target = Test::MockFile->file( '/mtime_test8/target.txt', 'content' ); wait_for_time_change(); my $dir_mtime_before = ( stat '/mtime_test8' )[9]; wait_for_time_change(); my $link = Test::MockFile->symlink( '/mtime_test8/target.txt', '/mtime_test8/link.txt' ); my $dir_mtime_after = ( stat '/mtime_test8' )[9]; ok( $dir_mtime_after > $dir_mtime_before, 'dir mtime updated after symlink creation' ); }; subtest 'ctime also updates alongside mtime' => sub { my $dir = Test::MockFile->new_dir('/mtime_test9'); my $dir_ctime_before = ( stat '/mtime_test9' )[10]; ok( defined $dir_ctime_before, 'directory has ctime' ); wait_for_time_change(); my $file = Test::MockFile->file( '/mtime_test9/file.txt', 'data' ); my $dir_ctime_after = ( stat '/mtime_test9' )[10]; ok( $dir_ctime_after > $dir_ctime_before, 'dir ctime also updated' ); }; subtest 'no parent dir mocked means no crash' => sub { # File without a mocked parent directory — should not crash my $file = Test::MockFile->file( '/orphan/file.txt', 'content' ); ok( $file, 'file created without mocked parent dir (no crash)' ); }; done_testing(); Test-MockFile-0.039/t/pod-coverage.t000644 000765 000024 00000001244 15160070345 020664 0ustar00todd.rinaldostaff000000 000000 #!perl -T use 5.016; 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.039/t/runtime-bareword-filehandles.t000644 000765 000024 00000001404 15157362227 024062 0ustar00todd.rinaldostaff000000 000000 use 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.039/t/new_dir_interface.t000644 000765 000024 00000007210 15157362227 021770 0ustar00todd.rinaldostaff000000 000000 #!/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] & 07777; my $new_perms = sprintf '%04o', ( stat $dirname )[2] & 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.039/t/goto_is_available.t000644 000765 000024 00000002074 15160070345 021756 0ustar00todd.rinaldostaff000000 000000 #!/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.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.039/t/stat_defaults.t000644 000765 000024 00000010226 15157362227 021164 0ustar00todd.rinaldostaff000000 000000 #!/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 >; # Ensure consistent umask for permission tests umask 022; note "--- nlink defaults ---"; subtest 'regular file has nlink=1' => sub { my $f = Test::MockFile->file( '/mock/nlink_file', 'data' ); my $nlink = ( stat('/mock/nlink_file') )[3]; is( $nlink, 1, 'nlink is 1 for regular file' ); }; subtest 'directory has nlink=2' => sub { my $d = Test::MockFile->new_dir('/mock/nlink_dir'); my $nlink = ( stat('/mock/nlink_dir') )[3]; is( $nlink, 2, 'nlink is 2 for directory' ); }; subtest 'symlink has nlink=1' => sub { my $target = Test::MockFile->file( '/mock/nlink_target', 'data' ); my $link = Test::MockFile->symlink( '/mock/nlink_target', '/mock/nlink_sym' ); my $nlink = ( lstat('/mock/nlink_sym') )[3]; is( $nlink, 1, 'nlink is 1 for symlink' ); }; subtest 'mkdir sets nlink=2' => sub { my $d = Test::MockFile->dir('/mock/nlink_mkdir'); mkdir '/mock/nlink_mkdir'; my $nlink = ( stat('/mock/nlink_mkdir') )[3]; is( $nlink, 2, 'nlink is 2 after mkdir' ); }; subtest 'link increments nlink correctly from 1' => sub { my $src = Test::MockFile->file( '/mock/link_src', 'content' ); my $dest = Test::MockFile->file('/mock/link_dest'); my $before = ( stat('/mock/link_src') )[3]; is( $before, 1, 'nlink starts at 1 before linking' ); link( '/mock/link_src', '/mock/link_dest' ); my $src_nlink = ( stat('/mock/link_src') )[3]; my $dest_nlink = ( stat('/mock/link_dest') )[3]; is( $src_nlink, 2, 'source nlink is 2 after link' ); is( $dest_nlink, 2, 'destination nlink is 2 after link' ); }; subtest 'user-specified nlink overrides default' => sub { my $f = Test::MockFile->file( '/mock/nlink_custom', 'data', { nlink => 5 } ); my $nlink = ( stat('/mock/nlink_custom') )[3]; is( $nlink, 5, 'user-specified nlink=5 is preserved' ); }; note "--- inode defaults ---"; subtest 'each mock gets a unique inode' => sub { my $f1 = Test::MockFile->file( '/mock/ino_a', 'aaa' ); my $f2 = Test::MockFile->file( '/mock/ino_b', 'bbb' ); my $f3 = Test::MockFile->file( '/mock/ino_c', 'ccc' ); my $ino1 = ( stat('/mock/ino_a') )[1]; my $ino2 = ( stat('/mock/ino_b') )[1]; my $ino3 = ( stat('/mock/ino_c') )[1]; ok( $ino1 > 0, 'inode is non-zero' ); ok( $ino2 > 0, 'inode is non-zero' ); ok( $ino3 > 0, 'inode is non-zero' ); isnt( $ino1, $ino2, 'file A and B have different inodes' ); isnt( $ino2, $ino3, 'file B and C have different inodes' ); isnt( $ino1, $ino3, 'file A and C have different inodes' ); }; subtest 'directory gets a unique inode' => sub { my $f = Test::MockFile->file( '/mock/ino_file', 'data' ); my $d = Test::MockFile->new_dir('/mock/ino_dir'); my $f_ino = ( stat('/mock/ino_file') )[1]; my $d_ino = ( stat('/mock/ino_dir') )[1]; ok( $d_ino > 0, 'directory inode is non-zero' ); isnt( $f_ino, $d_ino, 'file and directory have different inodes' ); }; subtest 'symlink gets a unique inode' => sub { my $target = Test::MockFile->file( '/mock/ino_sym_tgt', 'data' ); my $link = Test::MockFile->symlink( '/mock/ino_sym_tgt', '/mock/ino_sym_lnk' ); my $t_ino = ( stat('/mock/ino_sym_tgt') )[1]; my $l_ino = ( lstat('/mock/ino_sym_lnk') )[1]; ok( $l_ino > 0, 'symlink inode is non-zero' ); isnt( $t_ino, $l_ino, 'symlink and target have different inodes' ); }; subtest 'hard links share the same inode' => sub { my $src = Test::MockFile->file( '/mock/ino_hard_src', 'data' ); my $dest = Test::MockFile->file('/mock/ino_hard_dest'); link( '/mock/ino_hard_src', '/mock/ino_hard_dest' ); my $src_ino = ( stat('/mock/ino_hard_src') )[1]; my $dest_ino = ( stat('/mock/ino_hard_dest') )[1]; is( $dest_ino, $src_ino, 'hard link has same inode as source' ); }; subtest 'user-specified inode overrides default' => sub { my $f = Test::MockFile->file( '/mock/ino_custom', 'data', { inode => 42 } ); my $ino = ( stat('/mock/ino_custom') )[1]; is( $ino, 42, 'user-specified inode=42 is preserved' ); }; done_testing(); Test-MockFile-0.039/t/symlink_link.t000644 000765 000024 00000026204 15160057055 021022 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Errno qw/ENOENT EEXIST EPERM EXDEV EINVAL ELOOP/; use Test::MockFile qw< nostrict >; note "-------------- symlink() builtin on mocked paths --------------"; { note "symlink() on a non-existent file mock converts it to a symlink"; my $file = Test::MockFile->file('/mock/target'); my $link = Test::MockFile->file('/mock/mylink'); ok( !-e '/mock/mylink', 'link path does not exist yet' ); ok( !-l '/mock/mylink', 'link path is not a symlink yet' ); my $result = symlink( '/mock/target', '/mock/mylink' ); ok( $result, 'symlink() returns true on success' ); ok( -l '/mock/mylink', '-l detects the new symlink' ); is( readlink('/mock/mylink'), '/mock/target', 'readlink returns the target' ); } { note "symlink() fails with EEXIST when destination already exists (file)"; my $existing = Test::MockFile->file( '/mock/exists', 'content' ); $! = 0; my $result = symlink( '/somewhere', '/mock/exists' ); is( $result, 0, 'symlink() returns 0 when destination exists' ); is( $! + 0, EEXIST, '$! is EEXIST' ); } { note "symlink() fails with EEXIST when destination is an existing dir"; my $dir = Test::MockFile->dir('/mock/existdir'); mkdir '/mock/existdir'; $! = 0; my $result = symlink( '/somewhere', '/mock/existdir' ); is( $result, 0, 'symlink() returns 0 when destination is a dir' ); is( $! + 0, EEXIST, '$! is EEXIST' ); } { note "symlink() fails with EEXIST when destination is an existing symlink"; my $link = Test::MockFile->symlink( '/target1', '/mock/existlink' ); $! = 0; my $result = symlink( '/target2', '/mock/existlink' ); is( $result, 0, 'symlink() returns 0 when destination is already a symlink' ); is( $! + 0, EEXIST, '$! is EEXIST' ); } { note "symlink() updates parent directory content"; my $parent = Test::MockFile->dir('/mock/parentdir'); my $child = Test::MockFile->file('/mock/parentdir/newlink'); ok( !-d '/mock/parentdir', 'parent dir does not exist yet' ); symlink( '/whatever', '/mock/parentdir/newlink' ); ok( -d '/mock/parentdir', 'parent dir now exists (has_content set)' ); opendir my $dh, '/mock/parentdir' or die $!; my @entries = readdir $dh; closedir $dh; is( \@entries, [qw< . .. newlink >], 'parent dir lists the new symlink' ); } { note "symlink() can create a dangling symlink (target not mocked)"; my $link = Test::MockFile->file('/mock/dangling'); my $result = symlink( '/nonexistent/target', '/mock/dangling' ); ok( $result, 'symlink() succeeds even if target is not mocked' ); ok( -l '/mock/dangling', 'the symlink exists' ); is( readlink('/mock/dangling'), '/nonexistent/target', 'readlink returns the dangling target' ); } { note "symlink() on a non-existent dir mock converts it to a symlink"; my $mock = Test::MockFile->dir('/mock/dirlink'); ok( !-e '/mock/dirlink', 'dir mock does not exist initially' ); symlink( '/somewhere', '/mock/dirlink' ); ok( -l '/mock/dirlink', 'now it is a symlink' ); ok( !-d '/mock/dirlink', 'it is NOT a directory anymore' ); } { note "symlink() on a non-existent symlink mock converts it to an existing symlink"; my $mock = Test::MockFile->symlink( undef, '/mock/undeflink' ); ok( !-e '/mock/undeflink', 'undef symlink mock does not exist' ); symlink( '/real_target', '/mock/undeflink' ); ok( -l '/mock/undeflink', 'now it is an existing symlink' ); is( readlink('/mock/undeflink'), '/real_target', 'readlink returns new target' ); } note "-------------- link() builtin on mocked paths --------------"; { note "link() creates a hard link between two mocked files"; my $src = Test::MockFile->file( '/mock/source', 'hello world' ); my $dest = Test::MockFile->file('/mock/hardlink'); ok( !-e '/mock/hardlink', 'hardlink does not exist yet' ); my $result = link( '/mock/source', '/mock/hardlink' ); ok( $result, 'link() returns true on success' ); ok( -e '/mock/hardlink', 'hardlink now exists' ); ok( -f '/mock/hardlink', 'hardlink is a regular file' ); # Contents should match open my $fh, '<', '/mock/hardlink' or die $!; my $content = do { local $/; <$fh> }; close $fh; is( $content, 'hello world', 'hardlink has same contents as source' ); } { note "link() increments nlink on both source and destination"; my $src = Test::MockFile->file( '/mock/src_nlink', 'data' ); my $dest = Test::MockFile->file('/mock/dst_nlink'); my $initial_nlink = ( stat('/mock/src_nlink') )[3]; link( '/mock/src_nlink', '/mock/dst_nlink' ); my $src_nlink = ( stat('/mock/src_nlink') )[3]; my $dst_nlink = ( stat('/mock/dst_nlink') )[3]; is( $src_nlink, $initial_nlink + 1, 'source nlink incremented' ); is( $dst_nlink, $src_nlink, 'destination nlink matches source' ); } { note "link() preserves mode, uid, gid from source"; my $src = Test::MockFile->file( '/mock/src_perms', 'data', { mode => 0755 } ); my $dest = Test::MockFile->file('/mock/dst_perms'); link( '/mock/src_perms', '/mock/dst_perms' ); my @src_stat = stat('/mock/src_perms'); my @dst_stat = stat('/mock/dst_perms'); is( $dst_stat[2], $src_stat[2], 'mode matches' ); is( $dst_stat[4], $src_stat[4], 'uid matches' ); is( $dst_stat[5], $src_stat[5], 'gid matches' ); } { note "link() fails with ENOENT when source does not exist"; my $src = Test::MockFile->file('/mock/nosrc'); my $dest = Test::MockFile->file('/mock/nodest'); $! = 0; my $result = link( '/mock/nosrc', '/mock/nodest' ); is( $result, 0, 'link() returns 0 when source does not exist' ); is( $! + 0, ENOENT, '$! is ENOENT' ); } { note "link() fails with EEXIST when destination already exists"; my $src = Test::MockFile->file( '/mock/src_exist', 'data' ); my $dest = Test::MockFile->file( '/mock/dest_exist', 'other' ); $! = 0; my $result = link( '/mock/src_exist', '/mock/dest_exist' ); is( $result, 0, 'link() returns 0 when destination exists' ); is( $! + 0, EEXIST, '$! is EEXIST' ); } { note "link() fails with EPERM when source is a directory"; my $dir = Test::MockFile->dir('/mock/srcdir'); mkdir '/mock/srcdir'; my $dest = Test::MockFile->file('/mock/linktodir'); $! = 0; my $result = link( '/mock/srcdir', '/mock/linktodir' ); is( $result, 0, 'link() returns 0 for directory source' ); is( $! + 0, EPERM, '$! is EPERM' ); } { note "link() fails with EXDEV when destination is not mocked"; my $src = Test::MockFile->file( '/mock/src_xdev', 'data' ); $! = 0; my $result = link( '/mock/src_xdev', '/unmocked/path' ); is( $result, 0, 'link() returns 0 when destination is not mocked' ); is( $! + 0, EXDEV, '$! is EXDEV (cannot cross mock/real boundary)' ); } { note "link() follows symlinks on source"; my $target = Test::MockFile->file( '/mock/real_file', 'linked data' ); my $symlink = Test::MockFile->symlink( '/mock/real_file', '/mock/sym_src' ); my $dest = Test::MockFile->file('/mock/hard_from_sym'); my $result = link( '/mock/sym_src', '/mock/hard_from_sym' ); ok( $result, 'link() through symlink succeeds' ); ok( -f '/mock/hard_from_sym', 'destination is a regular file (not symlink)' ); open my $fh, '<', '/mock/hard_from_sym' or die $!; my $content = do { local $/; <$fh> }; close $fh; is( $content, 'linked data', 'destination has the symlink target contents' ); } { note "link() fails when symlink source is broken"; my $broken = Test::MockFile->symlink( '/mock/nowhere', '/mock/broken_sym' ); my $dest = Test::MockFile->file('/mock/link_broken'); $! = 0; my $result = link( '/mock/broken_sym', '/mock/link_broken' ); is( $result, 0, 'link() fails for broken symlink source' ); is( $! + 0, ENOENT, '$! is ENOENT' ); } { note "link() updates parent directory content"; my $parent = Test::MockFile->dir('/mock/linkparent'); my $src = Test::MockFile->file( '/mock/linksrc', 'data' ); my $dest = Test::MockFile->file('/mock/linkparent/newhard'); ok( !-d '/mock/linkparent', 'parent dir does not exist yet' ); link( '/mock/linksrc', '/mock/linkparent/newhard' ); ok( -d '/mock/linkparent', 'parent dir now exists' ); opendir my $dh, '/mock/linkparent' or die $!; my @entries = readdir $dh; closedir $dh; is( \@entries, [qw< . .. newhard >], 'parent dir lists the new hard link' ); } { note "link() fails with ELOOP when symlink source is circular"; my $link_a = Test::MockFile->symlink( '/mock/circ_b', '/mock/circ_a' ); my $link_b = Test::MockFile->symlink( '/mock/circ_a', '/mock/circ_b' ); my $dest = Test::MockFile->file('/mock/link_circ'); $! = 0; my $result = link( '/mock/circ_a', '/mock/link_circ' ); is( $result, 0, 'link() fails for circular symlink source' ); is( $! + 0, ELOOP, '$! is ELOOP (not ENOENT)' ); } { note "unlink() decrements nlink on the unlinked file"; my $src = Test::MockFile->file( '/mock/ul_src', 'data', { nlink => 1, inode => 90001 } ); my $dest = Test::MockFile->file('/mock/ul_dst'); link( '/mock/ul_src', '/mock/ul_dst' ); my $nlink_before = ( stat('/mock/ul_src') )[3]; is( $nlink_before, 2, 'source nlink is 2 after link' ); unlink('/mock/ul_src'); my $src_nlink_after = ( stat('/mock/ul_src') )[3]; is( $src_nlink_after, undef, 'stat on unlinked file returns undef (no longer exists)' ); my $dst_nlink = ( stat('/mock/ul_dst') )[3]; is( $dst_nlink, 1, 'remaining hard link nlink decremented after unlink' ); } { note "unlink() on a file with nlink=1 decrements to 0"; my $file = Test::MockFile->file( '/mock/ul_single', 'data', { nlink => 1 } ); my $nlink_before = ( stat('/mock/ul_single') )[3]; is( $nlink_before, 1, 'nlink is 1 before unlink' ); unlink('/mock/ul_single'); # File no longer exists, but the mock object's nlink should be decremented ok( !-e '/mock/ul_single', 'file no longer exists after unlink' ); } { note "link() propagates nlink to all same-inode mocks (3+ hard links)"; my $inode = 99001; my $a = Test::MockFile->file( '/mock/hl_a', 'shared', { inode => $inode, nlink => 1 } ); my $b = Test::MockFile->file('/mock/hl_b'); my $c = Test::MockFile->file('/mock/hl_c'); # First hard link: A → B ok( link( '/mock/hl_a', '/mock/hl_b' ), 'link A to B succeeds' ); is( ( stat('/mock/hl_a') )[3], 2, 'A nlink=2 after first link' ); is( ( stat('/mock/hl_b') )[3], 2, 'B nlink=2 after first link' ); # Second hard link: A → C — B should also get nlink=3 ok( link( '/mock/hl_a', '/mock/hl_c' ), 'link A to C succeeds' ); is( ( stat('/mock/hl_a') )[3], 3, 'A nlink=3 after second link' ); is( ( stat('/mock/hl_b') )[3], 3, 'B nlink=3 after second link (propagated)' ); is( ( stat('/mock/hl_c') )[3], 3, 'C nlink=3 after second link' ); # All three share the same inode is( ( stat('/mock/hl_b') )[1], $inode, 'B has same inode as A' ); is( ( stat('/mock/hl_c') )[1], $inode, 'C has same inode as A' ); } done_testing(); Test-MockFile-0.039/t/utime_strict.t000644 000765 000024 00000001673 15157362227 021043 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Plugin::NoWarnings; use Test2::Tools::Exception qw< dies lives >; use Test::MockFile; subtest( 'utime on unmocked file in strict mode dies' => sub { like( dies( sub { utime 1000, 2000, '/unmocked/strict_test.txt' } ), qr/\Qutime\E/, 'utime on unmocked file in strict mode triggers violation', ); } ); subtest( 'utime on mocked file in strict mode succeeds' => sub { my $file = Test::MockFile->file( '/strict/test', 'content' ); ok( lives( sub { utime 1000, 2000, '/strict/test' } ), 'utime on mocked file in strict mode works', ) or note $@; my @stat = stat('/strict/test'); is( $stat[8], 1000, 'atime set correctly in strict mode' ); is( $stat[9], 2000, 'mtime set correctly in strict mode' ); } ); done_testing(); exit; Test-MockFile-0.039/t/Test-MockFile_file.t000644 000765 000024 00000023320 15157362227 021726 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Fcntl qw( S_IFREG S_IFDIR S_IFLNK ); use constant S_IFPERMS => 07777; use Errno qw( ENOENT ); use Test::MockFile qw< nostrict >; # =================================================================== # Tests for the file() constructor and mock object API. # =================================================================== subtest 'file() constructor — basic creation' => sub { my $mock = Test::MockFile->file('/fake/basic.txt', 'hello'); ok( $mock, 'file() returns a truthy object' ); is( ref $mock, 'Test::MockFile', 'object is a Test::MockFile instance' ); is( $mock->path(), '/fake/basic.txt', 'path() returns the mocked path' ); }; subtest 'file() with contents — existing file' => sub { my $mock = Test::MockFile->file('/fake/existing.txt', "line1\nline2\n"); is( $mock->contents(), "line1\nline2\n", 'contents() returns the file body' ); ok( $mock->exists(), 'exists() is true for file with contents' ); is( $mock->is_file(), 1, 'is_file() returns 1' ); is( $mock->is_dir(), 0, 'is_dir() returns 0' ); is( $mock->is_link(), 0, 'is_link() returns 0' ); }; subtest 'file() without contents — non-existent placeholder' => sub { my $mock = Test::MockFile->file('/fake/absent.txt'); is( $mock->contents(), undef, 'contents() is undef for non-existent file' ); ok( !$mock->exists(), 'exists() is false for non-existent file' ); is( $mock->size(), undef, 'size() is undef for non-existent file' ); }; subtest 'file() with empty string — exists but empty' => sub { my $mock = Test::MockFile->file('/fake/empty.txt', ''); is( $mock->contents(), '', 'contents() is empty string' ); ok( $mock->exists(), 'exists() is true — empty file still exists' ); is( $mock->size(), 0, 'size() is 0 for empty file' ); }; subtest 'size() and blocks()' => sub { my $mock = Test::MockFile->file('/fake/sized.txt', 'x' x 5000); is( $mock->size(), 5000, 'size() matches content length' ); # blocks() = ceil(size / blksize) — no 512-byte conversion my $expected_blocks = int( ( 5000 + 4096 - 1 ) / 4096 ); is( $mock->blocks(), $expected_blocks, 'blocks() computes correctly from size and blksize' ); }; subtest 'stat() returns 13-element list' => sub { my $mock = Test::MockFile->file('/fake/stated.txt', 'abc'); my @stat = $mock->stat(); is( scalar @stat, 13, 'stat() returns 13 elements' ); # Index 2 is mode — should have S_IFREG bit set ok( $stat[2] & S_IFREG, 'mode has S_IFREG set' ); # Index 7 is size is( $stat[7], 3, 'stat[7] (size) is 3' ); # Timestamps should be reasonable (not zero) ok( $stat[8] > 0, 'atime is non-zero' ); ok( $stat[9] > 0, 'mtime is non-zero' ); ok( $stat[10] > 0, 'ctime is non-zero' ); }; subtest 'permissions() and chmod()' => sub { my $mock = Test::MockFile->file('/fake/perms.txt', 'data'); my $orig_perms = $mock->permissions(); ok( defined $orig_perms, 'permissions() returns a value' ); # Set specific permissions $mock->chmod(0644); is( $mock->permissions(), 0644, 'chmod(0644) sets permissions correctly' ); $mock->chmod(0755); is( $mock->permissions(), 0755, 'chmod(0755) updates permissions' ); # Verify mode preserves file type my @stat = $mock->stat(); ok( $stat[2] & S_IFREG, 'mode still has S_IFREG after chmod' ); is( $stat[2] & S_IFPERMS, 0755, 'permission bits match after chmod' ); }; subtest 'mtime(), ctime(), atime() — read and write' => sub { my $mock = Test::MockFile->file('/fake/timed.txt', 'content'); my $base_time = time(); # Reading ok( $mock->mtime() > 0, 'mtime() returns a positive epoch' ); ok( $mock->atime() > 0, 'atime() returns a positive epoch' ); ok( $mock->ctime() > 0, 'ctime() returns a positive epoch' ); # Writing $mock->mtime(1000000); is( $mock->mtime(), 1000000, 'mtime(epoch) sets the value' ); $mock->atime(2000000); is( $mock->atime(), 2000000, 'atime(epoch) sets the value' ); $mock->ctime(3000000); is( $mock->ctime(), 3000000, 'ctime(epoch) sets the value' ); }; subtest 'touch() — creates and updates times' => sub { my $mock = Test::MockFile->file('/fake/touched.txt'); ok( !$mock->exists(), 'file does not exist before touch' ); $mock->touch(); ok( $mock->exists(), 'file exists after touch()' ); is( $mock->contents(), '', 'touch() creates empty file' ); # Touch with a specific time $mock->touch(9999999); is( $mock->mtime(), 9999999, 'touch(epoch) sets mtime' ); is( $mock->atime(), 9999999, 'touch(epoch) sets atime' ); }; subtest 'write() — replaces contents' => sub { my $mock = Test::MockFile->file('/fake/writable.txt', 'old data'); my $ret = $mock->write('new data'); is( $mock->contents(), 'new data', 'write() replaces contents' ); is( ref $ret, 'Test::MockFile', 'write() returns $self for chaining' ); }; subtest 'write() — creates non-existent file' => sub { my $mock = Test::MockFile->file('/fake/created_by_write.txt'); ok( !$mock->exists(), 'file does not exist before write()' ); $mock->write('created'); ok( $mock->exists(), 'file exists after write()' ); is( $mock->contents(), 'created', 'contents are correct' ); }; subtest 'append() — adds to contents' => sub { my $mock = Test::MockFile->file('/fake/appendable.txt', 'start'); my $ret = $mock->append(' + end'); is( $mock->contents(), 'start + end', 'append() adds to contents' ); is( ref $ret, 'Test::MockFile', 'append() returns $self for chaining' ); }; subtest 'append() — creates non-existent file' => sub { my $mock = Test::MockFile->file('/fake/created_by_append.txt'); ok( !$mock->exists(), 'file does not exist before append()' ); $mock->append('appended'); ok( $mock->exists(), 'file exists after append()' ); is( $mock->contents(), 'appended', 'contents are correct' ); }; subtest 'read() — scalar context returns entire contents' => sub { my $mock = Test::MockFile->file('/fake/readable.txt', "line1\nline2\nline3\n"); my $all = $mock->read(); is( $all, "line1\nline2\nline3\n", 'read() in scalar returns all contents' ); }; subtest 'read() — list context returns lines' => sub { my $mock = Test::MockFile->file('/fake/readable2.txt', "aaa\nbbb\nccc\n"); my @lines = $mock->read(); is( \@lines, ["aaa\n", "bbb\n", "ccc\n"], 'read() in list context splits on $/' ); }; subtest 'unlink() — removes the file' => sub { my $mock = Test::MockFile->file('/fake/to_delete.txt', 'disposable'); ok( $mock->exists(), 'file exists before unlink' ); my $ret = $mock->unlink(); is( $ret, 1, 'unlink() returns 1 on success' ); ok( !$mock->exists(), 'file does not exist after unlink()' ); is( $mock->contents(), undef, 'contents() is undef after unlink()' ); }; subtest 'unlink() on non-existent file fails with ENOENT' => sub { my $mock = Test::MockFile->file('/fake/already_gone.txt'); ok( !$mock->exists(), 'file does not exist' ); my $ret = $mock->unlink(); is( $ret, 0, 'unlink() returns 0 for non-existent file' ); is( $! + 0, ENOENT, 'errno is ENOENT' ); }; subtest 'chained write and append' => sub { my $mock = Test::MockFile->file('/fake/chained.txt'); $mock->write('hello')->append(' world'); is( $mock->contents(), 'hello world', 'write/append chaining works' ); }; subtest 'file() with custom stat attributes' => sub { my $mock = Test::MockFile->file( '/fake/custom_stat.txt', 'content', { uid => 1000, gid => 2000, mtime => 1234567890, } ); my @stat = $mock->stat(); is( $stat[4], 1000, 'uid from constructor' ); is( $stat[5], 2000, 'gid from constructor' ); is( $stat[9], 1234567890, 'mtime from constructor' ); }; subtest 'file() — filesystem ops work on mocked file' => sub { my $mock = Test::MockFile->file('/fake/fs_ops.txt', 'content here'); # stat should work via CORE::stat override my @stat = stat('/fake/fs_ops.txt'); is( scalar @stat, 13, 'stat() on mocked path returns 13 elements' ); is( $stat[7], 12, 'stat[7] (size) is 12' ); # -e, -f file tests ok( -e '/fake/fs_ops.txt', '-e returns true for mocked file' ); ok( -f '/fake/fs_ops.txt', '-f returns true for mocked file' ); ok( !-d '/fake/fs_ops.txt', '-d returns false for file' ); # -s must be captured in a variable first — passing directly to is() # causes argument-shifting on Perl < 5.16 due to list-context interaction. my $file_size = -s '/fake/fs_ops.txt'; is( $file_size, 12, '-s returns file size' ); # open and read ok( open( my $fh, '<', '/fake/fs_ops.txt' ), 'open succeeds on mocked file' ); my $data = <$fh>; is( $data, 'content here', 'reading from mocked file handle works' ); close($fh); }; subtest 'file() — open for write creates content' => sub { my $mock = Test::MockFile->file('/fake/writable_via_open.txt', ''); ok( open( my $fh, '>', '/fake/writable_via_open.txt' ), 'open > succeeds' ); print $fh "written via handle"; close($fh); is( $mock->contents(), 'written via handle', 'content written through handle appears in mock' ); }; subtest 'file() — multiple mock objects are independent' => sub { my $mock_a = Test::MockFile->file('/fake/independent_a.txt', 'aaa'); my $mock_b = Test::MockFile->file('/fake/independent_b.txt', 'bbb'); is( $mock_a->contents(), 'aaa', 'mock_a has correct contents' ); is( $mock_b->contents(), 'bbb', 'mock_b has correct contents' ); $mock_a->write('AAA'); is( $mock_a->contents(), 'AAA', 'mock_a updated' ); is( $mock_b->contents(), 'bbb', 'mock_b unchanged' ); }; done_testing(); Test-MockFile-0.039/t/open_edge_cases.t000644 000765 000024 00000006505 15157362227 021432 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Errno qw/ENOENT ENOTDIR ELOOP/; use Test::MockFile qw< nostrict >; # ============================================================ # Test: 2-arg open with +>> mode (read-write append) # Bug: regex ( >> | [+]?> | [+]?< ) matches +> before +>> # ============================================================ subtest '+>> two-arg open mode parsing' => sub { my $mock = Test::MockFile->file( '/tmp/append_test', 'original' ); # +>> should open for read-write append, like 3-arg open($fh, '+>>', $file) ok( open( my $fh, '+>>/tmp/append_test' ), 'open with +>> two-arg succeeds' ) or diag "open failed: $!"; # Append some content print $fh "appended"; close $fh; is( $mock->contents, 'originalappended', '+>> appends to existing content' ); }; subtest '+>> on new file creates it' => sub { my $mock = Test::MockFile->file('/tmp/append_new'); # +>> on non-existent file should create it ok( open( my $fh, '+>>/tmp/append_new' ), '+>> creates non-existent file' ) or diag "open failed: $!"; print $fh "hello"; close $fh; is( $mock->contents, 'hello', '+>> on new file writes correctly' ); }; subtest 'existing >> mode still works' => sub { my $mock = Test::MockFile->file( '/tmp/append_existing', 'data' ); ok( open( my $fh, '>>/tmp/append_existing' ), '>> two-arg still works' ) or diag "open failed: $!"; print $fh "more"; close $fh; is( $mock->contents, 'datamore', '>> appends correctly' ); }; subtest '+> two-arg still works' => sub { my $mock = Test::MockFile->file( '/tmp/trunc_test', 'old' ); ok( open( my $fh, '+>/tmp/trunc_test' ), '+> two-arg works' ) or diag "open failed: $!"; # +> truncates is( $mock->contents, '', '+> truncates on open' ); print $fh "new"; close $fh; is( $mock->contents, 'new', '+> write works' ); }; # ============================================================ # Test: opendir follows symlinks # Bug: __opendir used _get_file_object (no symlink follow) # ============================================================ subtest 'opendir follows symlink to directory' => sub { my $dir = Test::MockFile->new_dir('/tmp/realdir'); my $file = Test::MockFile->file( '/tmp/realdir/child.txt', 'content' ); my $link = Test::MockFile->symlink( '/tmp/realdir', '/tmp/dirlink' ); ok( opendir( my $dh, '/tmp/dirlink' ), 'opendir on symlink to dir succeeds' ) or diag "opendir failed: $!"; my @entries = sort readdir($dh); closedir $dh; ok( grep( { $_ eq 'child.txt' } @entries ), 'readdir through symlink finds child file' ); }; subtest 'opendir on broken symlink fails with ENOENT' => sub { my $link = Test::MockFile->symlink( '/tmp/nonexistent_dir', '/tmp/broken_dirlink' ); ok( !opendir( my $dh, '/tmp/broken_dirlink' ), 'opendir on broken symlink fails' ); is( $! + 0, ENOENT, 'errno is ENOENT for broken symlink' ); }; subtest 'opendir on symlink to file fails with ENOTDIR' => sub { my $file = Test::MockFile->file( '/tmp/afile', 'data' ); my $link = Test::MockFile->symlink( '/tmp/afile', '/tmp/filelink' ); ok( !opendir( my $dh, '/tmp/filelink' ), 'opendir on symlink to file fails' ); is( $! + 0, ENOTDIR, 'errno is ENOTDIR' ); }; done_testing(); Test-MockFile-0.039/t/relative_paths.t000644 000765 000024 00000006003 15157362227 021332 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Explain; use Test2::Plugin::NoWarnings; use Errno qw/ENOTEMPTY ENOENT/; use Cwd (); use Test::MockFile qw< nostrict >; my $cwd = Cwd::getcwd(); # All mocks are registered under absolute paths in %files_being_mocked. # Operations that receive relative paths from user code must resolve them # before doing hash lookups or parent-dir timestamp updates. note "-------------- rmdir: relative path still enforces ENOTEMPTY --------------"; { my $dir = Test::MockFile->new_dir("$cwd/reldir"); my $child = Test::MockFile->file( "$cwd/reldir/child.txt", 'data' ); ok( !rmdir('reldir'), 'rmdir with relative path fails on non-empty dir' ); my $errno = $! + 0; is( $errno, ENOTEMPTY, 'errno is ENOTEMPTY for relative rmdir' ); ok( $dir->exists, 'directory still exists after failed rmdir' ); ok( $child->exists, 'child still exists after failed rmdir' ); } note "-------------- rmdir: relative path succeeds on empty dir --------------"; { my $dir = Test::MockFile->new_dir("$cwd/emptyrel"); ok( rmdir('emptyrel'), 'rmdir with relative path succeeds on empty dir' ); ok( !$dir->exists, 'directory removed after rmdir' ); } note "-------------- rmdir: relative path updates parent dir timestamps --------------"; { my $parent = Test::MockFile->new_dir($cwd); my $dir = Test::MockFile->new_dir("$cwd/tsdir"); # Set parent timestamps to the past $parent->{'mtime'} = 1000; $parent->{'ctime'} = 1000; my $before = time; ok( rmdir('tsdir'), 'rmdir with relative path succeeds' ); ok( $parent->{'mtime'} >= $before, 'parent mtime updated after relative rmdir' ); ok( $parent->{'ctime'} >= $before, 'parent ctime updated after relative rmdir' ); } note "-------------- mkdir: relative path updates parent dir timestamps --------------"; { my $parent = Test::MockFile->new_dir($cwd); my $dir = Test::MockFile->dir("$cwd/newrel"); # Set parent timestamps to the past $parent->{'mtime'} = 1000; $parent->{'ctime'} = 1000; my $before = time; ok( mkdir('newrel'), 'mkdir with relative path succeeds' ); ok( $parent->{'mtime'} >= $before, 'parent mtime updated after relative mkdir' ); ok( $parent->{'ctime'} >= $before, 'parent ctime updated after relative mkdir' ); } note "-------------- rename: relative paths update parent dir timestamps --------------"; { my $parent = Test::MockFile->new_dir($cwd); my $old = Test::MockFile->file( "$cwd/rensrc", 'content' ); my $new = Test::MockFile->file("$cwd/rendst"); $parent->{'mtime'} = 1000; $parent->{'ctime'} = 1000; my $before = time; ok( rename( 'rensrc', 'rendst' ), 'rename with relative paths succeeds' ); ok( $parent->{'mtime'} >= $before, 'parent mtime updated after relative rename' ); ok( $parent->{'ctime'} >= $before, 'parent ctime updated after relative rename' ); is( $new->contents, 'content', 'renamed file has correct contents' ); } done_testing(); Test-MockFile-0.039/t/strict-rules_file-temp-example.t000644 000765 000024 00000003377 15157362227 024366 0ustar00todd.rinaldostaff000000 000000 #!/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.039/t/sysopen.t000644 000765 000024 00000030616 15157362227 020027 0ustar00todd.rinaldostaff000000 000000 #!/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()" ); ok( sysseek( $fh, 5, 0 ), "sysseek to position 5 returns true." ); ok( sysseek( $fh, 10, 1 ), "Seek 10 bytes forward from the current position." ); is( sysseek( $fh, 0, 1 ), 15, "Current position is 15 bytes from start." ); $buf = ""; is( sysread( $fh, $buf, 2, 0 ), 2, "Read 2 bytes from current position (15)." ); is( $buf, "PQ", "Line is as expected." ); ok( sysseek( $fh, -5, 2 ), "Seek 5 bytes back from end of file." ); is( sysseek( $fh, 0, 1 ), 46, "Current position is 46 bytes from start." ); $buf = ""; is( sysread( $fh, $buf, 3, 0 ), 3, "Read 3 bytes from current position (46)." ); is( $buf, "vwx", "Line is as expected." ); } { 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()" ); ok( sysseek( $fh, 5, 0 ), "sysseek to position 5 returns true." ); ok( sysseek( $fh, 10, 1 ), "Seek 10 bytes forward from the current position." ); is( sysseek( $fh, 0, 1 ), 15, "Current position is 15 bytes from start." ); $buf = ""; is( sysread( $fh, $buf, 2, 0 ), 2, "Read 2 bytes from current position (15)." ); is( $buf, "PQ", "Line is as expected." ); ok( sysseek( $fh, -5, 2 ), "Seek 5 bytes back from end of file." ); is( sysseek( $fh, 0, 1 ), 46, "Current position is 46 bytes from start." ); $buf = ""; is( sysread( $fh, $buf, 3, 0 ), 3, "Read 3 bytes from current position (46)." ); is( $buf, "vwx", "Line is as expected." ); { use Errno qw/EINVAL/; $! = 0; my $ret = sysseek( $fh, 10, 3 ); ok( !$ret, "sysseek with invalid whence returns false" ); is( $! + 0, EINVAL, "sysseek with invalid whence sets EINVAL" ); } 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" ); { note "-------------- sysopen O_CREAT applies permissions from 4th arg --------------"; my $mock = Test::MockFile->file($filename); ok( !-e $filename, "Mock file does not exist before sysopen" ); is( sysopen( my $fh, $filename, O_CREAT | O_WRONLY, 0600 ), 1, "sysopen with O_CREAT and explicit perms" ); ok( -e $filename, "Mock file exists after sysopen O_CREAT" ); my @stat = stat($filename); my $got_perms = $stat[2] & 07777; my $expected = 0600 & ~umask; is( $got_perms, $expected, sprintf( "File permissions set from sysopen arg: got %04o, expected %04o", $got_perms, $expected ) ); close $fh; undef $mock; } is( \%Test::MockFile::files_being_mocked, {}, "No mock files are in cache after perms test" ); { note "-------------- sysopen O_CREAT without perms arg keeps default --------------"; my $mock = Test::MockFile->file($filename); is( sysopen( my $fh, $filename, O_CREAT | O_WRONLY ), 1, "sysopen O_CREAT without 4th arg" ); my @stat = stat($filename); my $got_perms = $stat[2] & 07777; my $default = 0666 & ~umask; # constructor default after umask is( $got_perms, $default, sprintf( "File permissions remain default: got %04o, expected %04o", $got_perms, $default ) ); close $fh; undef $mock; } is( \%Test::MockFile::files_being_mocked, {}, "No mock files are in cache after default perms test" ); { note "-------------- sysopen O_CREAT on existing file does not change perms --------------"; my $mock = Test::MockFile->file( $filename, "existing content" ); my @stat_before = stat($filename); is( sysopen( my $fh, $filename, O_CREAT | O_WRONLY, 0600 ), 1, "sysopen O_CREAT on existing file" ); my @stat_after = stat($filename); is( $stat_after[2], $stat_before[2], "Permissions unchanged when O_CREAT on existing file" ); close $fh; undef $mock; } is( \%Test::MockFile::files_being_mocked, {}, "No mock files are in cache after existing file test" ); note "O_NOFOLLOW on a symlink returns ELOOP"; { use Errno qw/ELOOP/; my $target = Test::MockFile->file( '/nofollow_target', "data" ); my $link = Test::MockFile->symlink( '/nofollow_target', '/nofollow_link' ); $! = 0; my $ret = sysopen( my $fh, '/nofollow_link', O_RDONLY | O_NOFOLLOW ); ok( !$ret, 'sysopen with O_NOFOLLOW on symlink returns false' ); is( $! + 0, ELOOP, 'sysopen with O_NOFOLLOW on symlink sets $! to ELOOP' ); } note "sysopen on non-existent file without O_CREAT returns ENOENT for all modes"; { use Errno qw/ENOENT/; my $mock = Test::MockFile->file('/enoent_test'); ok( !-e '/enoent_test', 'mock file does not exist' ); # O_RDONLY without O_CREAT on non-existent file $! = 0; my $ret_ro = sysopen( my $fh_ro, '/enoent_test', O_RDONLY ); ok( !$ret_ro, 'sysopen O_RDONLY on non-existent file returns false' ); is( $! + 0, ENOENT, 'sysopen O_RDONLY on non-existent file sets ENOENT' ); # O_WRONLY without O_CREAT on non-existent file $! = 0; my $ret_wo = sysopen( my $fh_wo, '/enoent_test', O_WRONLY ); ok( !$ret_wo, 'sysopen O_WRONLY on non-existent file returns false' ); is( $! + 0, ENOENT, 'sysopen O_WRONLY on non-existent file sets ENOENT' ); # O_RDWR without O_CREAT on non-existent file $! = 0; my $ret_rw = sysopen( my $fh_rw, '/enoent_test', O_RDWR ); ok( !$ret_rw, 'sysopen O_RDWR on non-existent file returns false' ); is( $! + 0, ENOENT, 'sysopen O_RDWR on non-existent file sets ENOENT' ); } note "sysopen O_WRONLY|O_CREAT on non-existent file succeeds (O_CREAT creates the file)"; { my $mock = Test::MockFile->file('/creat_test'); ok( !-e '/creat_test', 'mock file does not exist before O_CREAT' ); is( sysopen( my $fh, '/creat_test', O_WRONLY | O_CREAT ), 1, 'sysopen O_WRONLY|O_CREAT succeeds' ); ok( -e '/creat_test', 'file exists after O_CREAT' ); close $fh; } note "sysopen failure returns undef in list context (single-element list)"; { use Errno qw/ENOENT/; my $mock = Test::MockFile->file('/list_ctx_test'); my @ret = sysopen( my $fh, '/list_ctx_test', O_RDONLY ); is( scalar @ret, 1, 'sysopen failure returns one element in list context' ); ok( !$ret[0], 'sysopen failure element is false' ); ok( !defined $ret[0], 'sysopen failure element is undef (not "undef" string)' ); } done_testing(); exit; Test-MockFile-0.039/t/autodie_sysopen_reverse.t000644 000765 000024 00000003540 15160070345 023257 0ustar00todd.rinaldostaff000000 000000 #!/usr/bin/perl # Test autodie + sysopen compatibility when Test::MockFile is loaded BEFORE autodie. # This tests the CHECK block re-installation mechanism for sysopen. use strict; use warnings; use Test::More; use Fcntl qw( O_RDONLY O_WRONLY O_CREAT ); BEGIN { eval { require autodie }; if ($@) { plan skip_all => 'autodie not available'; } } # Load T::MF first, then autodie — reverse order tests CHECK block. use Test::MockFile qw(nostrict); use autodie qw(sysopen); subtest 'sysopen mocking works when T::MF loaded before autodie' => sub { my $file = "/autodie_sysopen_rev_read_$$"; my $mock = Test::MockFile->file( $file, "reverse order\n" ); my $ok = eval { sysopen( my $fh, $file, O_RDONLY ); ok( defined $fh, "filehandle defined" ); close($fh); 1; }; ok( $ok, "mocked sysopen works when T::MF loaded before autodie" ) or diag("Error: $@"); }; SKIP: { subtest 'autodie still dies on sysopen failure (reverse load order)' => sub { my $file = "/autodie_sysopen_rev_fail_$$"; my $mock = Test::MockFile->file( $file, undef ); my $died = !eval { sysopen( my $fh, $file, O_RDONLY ); 1; }; ok( $died, "autodie dies on sysopen of non-existent mocked file (reverse load order)" ); }; } subtest 'sysopen O_CREAT works in reverse load order' => sub { my $file = "/autodie_sysopen_rev_create_$$"; my $mock = Test::MockFile->file( $file, undef ); my $ok = eval { sysopen( my $fh, $file, O_WRONLY | O_CREAT ); ok( defined $fh, "filehandle defined after O_CREAT" ); close($fh); 1; }; ok( $ok, "sysopen O_CREAT on mocked file works (reverse load order)" ) or diag("Error: $@"); is( $mock->contents(), '', "file created with empty contents" ) if $ok; }; done_testing(); Test-MockFile-0.039/t/lib/Test/000755 000765 000024 00000000000 15160070576 017616 5ustar00todd.rinaldostaff000000 000000 Test-MockFile-0.039/t/lib/Test/TMF.pm000644 000765 000024 00000011542 15157362227 020610 0ustar00todd.rinaldostaff000000 000000 package 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;