view release on metacpan or  search on metacpan

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

    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 = '';
            }