Test-MockFile

 view release on metacpan or  search on metacpan

lib/Test/MockFile.pm  view on Meta::CPAN

        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

lib/Test/MockFile.pm  view on Meta::CPAN

    }

    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,

lib/Test/MockFile.pm  view on Meta::CPAN

    # 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.

lib/Test/MockFile.pm  view on Meta::CPAN

        # 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() ) {

lib/Test/MockFile.pm  view on Meta::CPAN

    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<perldebug>) on any code that
uses L<Test::MockFile> in strict mode, you will need to load
L<Term::ReadLine> beforehand, because it loads a file. Under the
debugger, the debugger will load the module after L<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

=head2 HARD LINKS

The C<link()> override copies file contents and metadata from the
source to the destination mock. However, unlike real hard links,
writes to one file will B<not> be reflected in the other. The
C<nlink> count is incremented on both files.

The destination path must be a pre-declared mock (via C<file()> or
C<dir()>). Attempting to C<link()> a mocked source to an unmocked
destination will fail with C<EXDEV>.

=head2 FILENO IS UNSUPPORTED

Filehandles can provide the file descriptor (in number) using the
C<fileno> keyword but this is purposefully unsupported in
L<Test::MockFile>.

The reason is that by mocking a file, we're creating an alternative
file system. Returning a C<fileno> (file descriptor number) would
require creating file descriptor numbers that would possibly conflict