File Coverage

blib/lib/Overload/FileCheck.pm

Criterion	Covered	Total	%
statement	270	273	98.9
branch	102	116	87.9
condition	36	51	70.5
subroutine	66	67	98.5
pod	14	15	93.3
total	488	522	93.4

# 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 Overload::FileCheck;

use strict;
use warnings;

# ABSTRACT: override/mock perl file check -X: -e, -f, -d, ...

use Errno ();
use Carp  ();

use base 'Exporter';

BEGIN {

    our $VERSION = '0.015'; # VERSION: generated by DZP::OurPkgVersion

    require XSLoader;
    XSLoader::load(__PACKAGE__);
}

use Fcntl (
    '_S_IFMT',     # bit mask for the file type bit field
                   #'S_IFPERMS',   # bit mask for file perms.
    'S_IFSOCK',    # socket
    'S_IFLNK',     # symbolic link
    'S_IFREG',     # regular file
    'S_IFBLK',     # block device
    'S_IFDIR',     # directory
    'S_IFCHR',     # character device
    'S_IFIFO',     # FIFO

    # qw{S_IRUSR S_IWUSR S_IXUSR S_IRWXU}
);

my @STAT_T_IX = qw{
  ST_DEV
  ST_INO
  ST_MODE
  ST_NLINK
  ST_UID
  ST_GID
  ST_RDEV
  ST_SIZE
  ST_ATIME
  ST_MTIME
  ST_CTIME
  ST_BLKSIZE
  ST_BLOCKS
};

my @CHECK_STATUS = qw{CHECK_IS_FALSE CHECK_IS_TRUE CHECK_IS_NULL FALLBACK_TO_REAL_OP};

my @STAT_HELPERS = qw{ stat_as_directory stat_as_file stat_as_symlink
  stat_as_socket stat_as_chr stat_as_block stat_as_fifo};

our @EXPORT_OK = (
    qw{
      mock_all_from_stat
      mock_all_file_checks mock_file_check mock_file_check_guard mock_stat
      unmock_file_check unmock_all_file_checks unmock_stat
      },
    @CHECK_STATUS,
    @STAT_T_IX,
    @STAT_HELPERS,
);

our %EXPORT_TAGS = (
    all => [@EXPORT_OK],

    # status code
    check => [@CHECK_STATUS],

    # STAT array indexes
    stat => [ @STAT_T_IX, @STAT_HELPERS ],
);

# hash for every filecheck we can mock
#   and their corresonding OP_TYPE
my %MAP_FC_OP = (
    'R' => OP_FTRREAD,
    'W' => OP_FTRWRITE,
    'X' => OP_FTREXEC,
    'r' => OP_FTEREAD,
    'w' => OP_FTEWRITE,
    'x' => OP_FTEEXEC,

    'e' => OP_FTIS,
    's' => OP_FTSIZE,     # OP_CAN_RETURN_INT
    'M' => OP_FTMTIME,    # OP_CAN_RETURN_INT
    'C' => OP_FTCTIME,    # OP_CAN_RETURN_INT
    'A' => OP_FTATIME,    # OP_CAN_RETURN_INT

    'O' => OP_FTROWNED,
    'o' => OP_FTEOWNED,
    'z' => OP_FTZERO,
    'S' => OP_FTSOCK,
    'c' => OP_FTCHR,
    'b' => OP_FTBLK,
    'f' => OP_FTFILE,
    'd' => OP_FTDIR,
    'p' => OP_FTPIPE,
    'u' => OP_FTSUID,
    'g' => OP_FTSGID,
    'k' => OP_FTSVTX,

    'l' => OP_FTLINK,

    't' => OP_FTTTY,

    'T' => OP_FTTEXT,
    'B' => OP_FTBINARY,

    # special cases for stat & lstat
    'stat'  => OP_STAT,
    'lstat' => OP_LSTAT,

);

my %MAP_STAT_T_IX = (
    st_dev     => ST_DEV,
    st_ino     => ST_INO,
    st_mode    => ST_MODE,
    st_nlink   => ST_NLINK,
    st_uid     => ST_UID,
    st_gid     => ST_GID,
    st_rdev    => ST_RDEV,
    st_size    => ST_SIZE,
    st_atime   => ST_ATIME,
    st_mtime   => ST_MTIME,
    st_ctime   => ST_CTIME,
    st_blksize => ST_BLKSIZE,
    st_blocks  => ST_BLOCKS,
);

# op_type_id => check
my %REVERSE_MAP = reverse %MAP_FC_OP;

my %OP_CAN_RETURN_INT   = map { $MAP_FC_OP{$_} => 1 } qw{ s };
my %OP_RETURNS_NV       = map { $MAP_FC_OP{$_} => 1 } qw{ M C A };
my %OP_IS_STAT_OR_LSTAT = map { $MAP_FC_OP{$_} => 1 } qw{ stat lstat };
#
# This is listing the default ERRNO codes
#   used by each test when the test fails and
#   the user did not provide one ERRNO error
#
my %DEFAULT_ERRNO = (
    'default' => Errno::ENOENT,    # default value for any other not listed
    'x'       => Errno::ENOEXEC,
    'X'       => Errno::ENOEXEC,

    # ...
);

# this is saving our custom ops
# optype_id => sub
my $_current_mocks = {};

sub import {
    my ( $class, @args ) = @_;

    # mock on import...
    my $_next_check;
    my @for_exporter;
    foreach my $check (@args) {
        if ( !$_next_check && $check !~ qr{^-} ) {

            # this is a valid arg for exporter
            push @for_exporter, $check;
            next;
        }
        if ( !$_next_check ) {

            # we found a key like '-e' in '-e => sub {} '
            $_next_check = $check;
        }
        else {
            # now this is the value
            my $code = $check;

            # use Overload::FileCheck -from_stat => \&my_stat;
            if ( $_next_check eq q{-from_stat} || $_next_check eq q{-from-stat} ) {
                mock_all_from_stat($code);
            }
            else {
                mock_file_check( $_next_check, $code );
            }

            undef $_next_check;
        }
    }

    if ( defined $_next_check ) {
        Carp::croak(qq[Missing CODE ref for mock '$_next_check' in import list]);
    }

    # callback the exporter logic
    return __PACKAGE__->export_to_level( 1, $class, @for_exporter );
}

sub mock_all_file_checks {
    my ($sub) = @_;

    foreach my $check ( sort keys %MAP_FC_OP ) {
        next if $check =~ qr{^l?stat$};    # we should not mock stat
        mock_file_check(
            $check,
            sub {
                my (@args) = @_;
                return $sub->( $check, @args );
            }
        );
    }

    return 1;
}

sub _resolve_check {
    my ($check) = @_;
    Carp::croak(q[Check is not defined]) unless defined $check;
    $check =~ s{^-+}{};    # strip any extra dashes
    Carp::croak(qq[Unknown check '$check']) unless defined $MAP_FC_OP{$check};
    return ( $check, $MAP_FC_OP{$check} );
}

sub mock_file_check {
    my ( $check, $sub ) = @_;

    Carp::croak(q[Second arg must be a CODE ref]) unless ref $sub eq 'CODE';

    my ( $name, $optype ) = _resolve_check($check);
    Carp::croak(qq[-$name is already mocked by Overload::FileCheck]) if exists $_current_mocks->{$optype};

    $_current_mocks->{$optype} = $sub;

    _xs_mock_op($optype);

    return 1;
}

sub mock_file_check_guard {
    my ( $check, $sub ) = @_;

    mock_file_check( $check, $sub );

    ( my $normalized = $check ) =~ s{^-+}{};

    return Overload::FileCheck::Guard->new($normalized);
}

sub unmock_file_check {
    my (@checks) = @_;

    foreach my $check (@checks) {
        my ( undef, $optype ) = _resolve_check($check);

        delete $_current_mocks->{$optype};

        _xs_unmock_op($optype);
    }

    return 1;
}

sub mock_all_from_stat {
    my ($sub_for_stat) = @_;

    # then mock all -X checks to our custom
    mock_all_file_checks(
        sub {
            my ( $check, $f_or_fh ) = @_;

            # the main call
            my $return = _check_from_stat( $check, $f_or_fh, $sub_for_stat );

            # auto remock the OP (it could have been temporary unmocked to use -X _)
            _xs_mock_op( $MAP_FC_OP{$check} );

            return $return;
        }
    );

    # start by mocking 'stat' and 'lstat' call
    mock_stat($sub_for_stat);

    return 1;
}

sub _check_from_stat {
    my ( $check, $f_or_fh, $sub_for_stat ) = @_;

    my $optype = $MAP_FC_OP{$check};

    # stat would need to be called twice
    # 1/ we first need to check if we are mocking the file
    #   or if we let it fallback to the Perl OP
    # 2/ doing a second stat call in order to cache _

    # In Perl, only -l uses lstat (does not follow symlinks).
    # All other file test ops use stat (follows symlinks).
    my $use_lstat = ( $check eq 'l' );

    my $stat_or_lstat = $use_lstat ? 'lstat' : 'stat';

    my (@mocked_lstat_result) = $sub_for_stat->( $stat_or_lstat, $f_or_fh );
    if (   scalar @mocked_lstat_result == 1
        && !ref $mocked_lstat_result[0]
        && $mocked_lstat_result[0] == FALLBACK_TO_REAL_OP ) {
        return FALLBACK_TO_REAL_OP;
    }

    # avoid a second callback to the user hook (do not really happen for now)
    local $_current_mocks->{ $MAP_FC_OP{$stat_or_lstat} } = sub {
        return @mocked_lstat_result;
    };

    # now performing a real stat call [ using the mocked stat function ]
    my ( @stat, @lstat );

    if ($use_lstat) {
        no warnings;
        @lstat = lstat($f_or_fh) if defined $f_or_fh;
    }
    else {
        no warnings;    # throw warnings with Perl <= 5.14
        @stat = stat($f_or_fh) if defined $f_or_fh;
    }

    # Dispatch table mapping each check letter to its handler.
    # Closures capture @stat, @lstat, $optype, and $f_or_fh from the enclosing scope.
    my %dispatch = (

        # Unmock then delegate to _ (effective uid/gid checks)
        r => sub { _xs_unmock_op($optype); _to_bool( scalar -r _ ) },    # readable by effective uid/gid
        w => sub { _xs_unmock_op($optype); _to_bool( scalar -w _ ) },    # writable by effective uid/gid
        x => sub { _xs_unmock_op($optype); _to_bool( scalar -x _ ) },    # executable by effective uid/gid
        o => sub { _xs_unmock_op($optype); _to_bool( scalar -o _ ) },    # owned by effective uid

        # Unmock then delegate to _ (real uid/gid checks)
        R => sub { _xs_unmock_op($optype); _to_bool( scalar -R _ ) },    # readable by real uid/gid
        W => sub { _xs_unmock_op($optype); _to_bool( scalar -W _ ) },    # writable by real uid/gid
        X => sub { _xs_unmock_op($optype); _to_bool( scalar -X _ ) },    # executable by real uid/gid
        O => sub { _xs_unmock_op($optype); _to_bool( scalar -O _ ) },    # owned by real uid

        # Unmock then delegate to _ (other permission/attribute checks)
        z => sub { _xs_unmock_op($optype); _to_bool( scalar -z _ ) },    # zero size
        t => sub { _xs_unmock_op($optype); _to_bool( scalar -t _ ) },    # filehandle is a tty
        u => sub { _xs_unmock_op($optype); _to_bool( scalar -u _ ) },    # setuid bit
        g => sub { _xs_unmock_op($optype); _to_bool( scalar -g _ ) },    # setgid bit
        k => sub { _xs_unmock_op($optype); _to_bool( scalar -k _ ) },    # sticky bit

        # Heuristic text/binary checks (use glob _ to pass the cached stat)
        T => sub { return CHECK_IS_NULL unless @stat; _xs_unmock_op($optype); _to_bool( scalar -T *_ ) },   # ASCII or UTF-8 text (heuristic)
        B => sub {                                                         # binary file (opposite of -T)
            return CHECK_IS_NULL unless @stat;                             # file not found
            # Check directory via mode bits directly instead of calling the
            # mocked -d operator, which would trigger a redundant stat callback.
            return CHECK_IS_TRUE if _check_mode_type( $stat[ST_MODE], S_IFDIR ) == CHECK_IS_TRUE;
            _xs_unmock_op($optype);
            return _to_bool( scalar -B *_ );
        },

        # Existence and size (computed directly from cached stat)
        e => sub { return CHECK_IS_NULL unless scalar @stat; CHECK_IS_TRUE },  # file exists (stat success implies existence)
        s => sub { $stat[ST_SIZE] },                                       # nonzero size (returns bytes); fallback breaks on symlinks

        # File type checks via mode bits (using @stat — follows symlinks)
        f => sub { _check_mode_type( $stat[ST_MODE],  S_IFREG ) },       # plain file
        d => sub { _check_mode_type( $stat[ST_MODE],  S_IFDIR ) },       # directory

        # Symlink check — only op that uses lstat (does not follow symlinks)
        l => sub { _check_mode_type( $lstat[ST_MODE], S_IFLNK ) },       # symbolic link

        # File type checks via mode bits (using @stat — follows symlinks like Perl)
        p => sub { _check_mode_type( $stat[ST_MODE], S_IFIFO ) },        # named pipe (FIFO)
        S => sub { _check_mode_type( $stat[ST_MODE], S_IFSOCK ) },       # socket
        b => sub { _check_mode_type( $stat[ST_MODE], S_IFBLK ) },        # block special file
        c => sub { _check_mode_type( $stat[ST_MODE], S_IFCHR ) },        # character special file

        # Age calculations: (basetime - timestamp) / seconds_per_day
        # Returns scalar ref to distinguish real NV values from the
        # FALLBACK_TO_REAL_OP sentinel (-1) — see _check() NV handling.
        M => sub {
            return CHECK_IS_NULL unless scalar @stat && defined $stat[ST_MTIME];
            \( ( get_basetime() - $stat[ST_MTIME] ) / 86400.0 );         # days since modification
        },
        A => sub {
            return CHECK_IS_NULL unless scalar @stat && defined $stat[ST_ATIME];
            \( ( get_basetime() - $stat[ST_ATIME] ) / 86400.0 );         # days since access
        },
        C => sub {
            return CHECK_IS_NULL unless scalar @stat && defined $stat[ST_CTIME];
            \( ( get_basetime() - $stat[ST_CTIME] ) / 86400.0 );         # days since inode change
        },
    );

    my $handler = $dispatch{$check}
        or Carp::croak(qq[Unknown check '$check']);
    return $handler->();
}

sub _to_bool {
    my ($s) = @_;

    return ( $s ? CHECK_IS_TRUE : CHECK_IS_FALSE );
}

sub _check_mode_type {
    my ( $mode, $type ) = @_;

    return CHECK_IS_NULL unless defined $mode;
    return _to_bool( ( $mode & _S_IFMT ) == $type );
}

# this is a special case used to mock OP_STAT & OP_LSTAT
sub mock_stat {
    my ($sub) = @_;

    Carp::croak(q[First arg must be a CODE ref]) unless ref $sub eq 'CODE';

    foreach my $opname (qw{stat lstat}) {
        my $optype = $MAP_FC_OP{$opname};
        Carp::croak(qq[No optype found for $opname]) unless $optype;

        # plug the sub
        $_current_mocks->{$optype} = sub {
            my $file_or_handle = shift;
            return $sub->( $opname, $file_or_handle );
        };

        # setup the mock for the OP
        _xs_mock_op($optype);
    }

    return 1;
}

# just an alias to unmock stat & lstat at the same time
sub unmock_stat {
    return unmock_file_check(qw{stat lstat});
}

sub unmock_all_file_checks {

    my @mocks = sort map { $REVERSE_MAP{$_} } keys %$_current_mocks;
    return 1 unless scalar @mocks;

    return unmock_file_check(@mocks);
}

# should not be called directly
# this is called from XS to check if one OP is mocked
# and trigger the callback function when mocked
my $_last_call_for;

sub _check {
    my ( $optype, $file ) = @_;

    # we have no custom mock at this point
    return FALLBACK_TO_REAL_OP unless defined $_current_mocks->{$optype};

    # Fall back to the last filename when the current file is undef
    # and stat is not independently mocked (stacked -X _ scenario).
    if ( !defined $file && defined $_last_call_for
        && !defined $_current_mocks->{ $MAP_FC_OP{'stat'} } ) {
        $file = $_last_call_for;
    }

    # Save $_last_call_for before callback dispatch so that re-entrant
    # calls (e.g. mock_all_from_stat callbacks invoking mocked file tests)
    # cannot corrupt the outer call's filename context.  See GH #68.
    my $saved_last_call_for = $_last_call_for;
    my ( $out, @extra ) = $_current_mocks->{$optype}->($file);
    # Cache string filenames for stacked -X _ ops.  When the file is a
    # reference (filehandle), restore the pre-callback value instead of
    # clobbering with undef — an inner re-entrant call may have set a
    # valid filename that a subsequent stacked op needs.  See GH #179.
    $_last_call_for = ref($file) ? $saved_last_call_for : $file;

    if ( !defined $out ) {
        # CHECK_IS_NULL: callback returned undef — propagate as undef
        # so the OP returns undef to the caller (file not found / unknown)
        if ( !int($!) ) {
            $! = $DEFAULT_ERRNO{ $REVERSE_MAP{$optype} || 'default' } || $DEFAULT_ERRNO{'default'};
        }
        return CHECK_IS_NULL;
    }

    if ( $OP_CAN_RETURN_INT{$optype} ) {

        # Auto-set errno for falsy returns from int ops (e.g. -s returning 0)
        # consistent with the boolean op path below.  GH #62.
        if ( !$out && !int($!) ) {
            $! = $DEFAULT_ERRNO{ $REVERSE_MAP{$optype} || 'default' } || $DEFAULT_ERRNO{'default'};
        }
        return $out;
    }

    # NV ops (-M, -C, -A) return a (status, value) pair to avoid the -1
    # sentinel collision: FALLBACK_TO_REAL_OP is -1, but -1.0 is a valid
    # NV result (file modified exactly 1 day in the future).  The XS
    # handler uses the status code instead of checking value == -1.
    if ( $OP_RETURNS_NV{$optype} ) {
        # Scalar ref: from _check_from_stat — always a real value, never FALLBACK
        if ( ref $out eq 'SCALAR' ) {
            return ( CHECK_IS_TRUE, $$out );
        }
        # Bare scalar: from direct mock_file_check callbacks
        if ( !ref $out && $out == FALLBACK_TO_REAL_OP ) {
            return (FALLBACK_TO_REAL_OP);
        }
        return ( CHECK_IS_TRUE, $out );
    }

    if ( !$out ) {

        # Set a default ERRNO when the user didn't provide one,
        # so tests never pass with $! left at zero.
        if ( !int($!) ) {
            $! = $DEFAULT_ERRNO{ $REVERSE_MAP{$optype} || 'default' } || $DEFAULT_ERRNO{'default'};
        }

        return CHECK_IS_FALSE;
    }

    return FALLBACK_TO_REAL_OP if !ref $out && $out == FALLBACK_TO_REAL_OP;

    # stat/lstat return a stat array in addition to the status code
    if ( $OP_IS_STAT_OR_LSTAT{$optype} ) {
        my $stat_as_arrayref = _normalize_stat_result( $out, @extra );
        return ( CHECK_IS_TRUE, $stat_as_arrayref );
    }

    return CHECK_IS_TRUE;
}

# Normalize a mock stat return value (array or hash) into a 13-element arrayref.
sub _normalize_stat_result {
    my ( $out, @extra ) = @_;

    my $stat      = $out // $extra[0];
    my $stat_is_a = ref $stat;
    Carp::croak(q[Your mocked function for stat should return a stat array or hash]) unless $stat_is_a;

    my $stat_t_max = STAT_T_MAX;

    if ( $stat_is_a eq 'ARRAY' ) {
        my $av_size = scalar @$stat;
        if ( $av_size && $av_size != $stat_t_max ) {
            Carp::croak(qq[Stat array should contain exactly 0 or $stat_t_max values]);
        }
        return $stat;
    }

    if ( $stat_is_a eq 'HASH' ) {
        my $stat_as_arrayref = [ (0) x $stat_t_max ];
        foreach my $k ( keys %$stat ) {
            ( my $normalized = lc($k) ) =~ s{^st_}{};
            my $ix = $MAP_STAT_T_IX{"st_$normalized"};
            Carp::croak(qq[Unknown index for stat_t struct key $k]) unless defined $ix;
            $stat_as_arrayref->[$ix] = $stat->{$k};
        }
        return $stat_as_arrayref;
    }

    Carp::croak(q[Your mocked function for stat should return a stat array or hash]);
}

# accessors for testing purpose mainly
sub _get_filecheck_ops_map {
    return {%MAP_FC_OP};    # return a copy
}

######################################################
### stat helpers
######################################################

sub stat_as_directory {
    my (%opts) = @_;

    return _stat_for( S_IFDIR, \%opts );
}

sub stat_as_file {
    my (%opts) = @_;

    return _stat_for( S_IFREG, \%opts );
}

sub stat_as_symlink {
    my (%opts) = @_;

    return _stat_for( S_IFLNK, \%opts );
}

sub stat_as_socket {
    my (%opts) = @_;

    return _stat_for( S_IFSOCK, \%opts );
}

sub stat_as_chr {
    my (%opts) = @_;

    return _stat_for( S_IFCHR, \%opts );
}

sub stat_as_block {
    my (%opts) = @_;

    return _stat_for( S_IFBLK, \%opts );
}

sub stat_as_fifo {
    my (%opts) = @_;

    return _stat_for( S_IFIFO, \%opts );
}

sub _stat_for {
    my ( $type, $opts ) = @_;

    my @stat = ( (0) x STAT_T_MAX );

    # set file type
    if ( defined $type ) {

        # _S_IFMT is used as a protection to do not flip outside the mask
        $stat[ST_MODE] |= ( $type & _S_IFMT );
    }

    # set permission using octal
    if ( defined $opts->{perms} ) {

        # _S_IFMT is used as a protection to do not flip outside the mask
        $stat[ST_MODE] |= ( $opts->{perms} & ~_S_IFMT );
    }

    # deal with UID / GID
    if ( defined $opts->{uid} ) {
        if ( $opts->{uid} =~ qr{^[0-9]+$} ) {
            $stat[ST_UID] = $opts->{uid};
        }
        else {
            my $uid = getpwnam( $opts->{uid} );
            Carp::croak("Unknown user '$opts->{uid}' passed to uid option") unless defined $uid;
            $stat[ST_UID] = $uid;
        }
    }

    if ( defined $opts->{gid} ) {
        if ( $opts->{gid} =~ qr{^[0-9]+$} ) {
            $stat[ST_GID] = $opts->{gid};
        }
        else {
            my $gid = getgrnam( $opts->{gid} );
            Carp::croak("Unknown group '$opts->{gid}' passed to gid option") unless defined $gid;
            $stat[ST_GID] = $gid;
        }
    }

    # options that we can simply copy to a slot
    my %name2ix = (
        dev     => ST_DEV,
        ino     => ST_INO,
        nlink   => ST_NLINK,
        rdev    => ST_RDEV,
        size    => ST_SIZE,
        atime   => ST_ATIME,
        mtime   => ST_MTIME,
        ctime   => ST_CTIME,
        blksize => ST_BLKSIZE,
        blocks  => ST_BLOCKS,
    );

    # all valid option names (after normalization: lc + strip st_ prefix)
    my %known_opts = ( perms => 1, uid => 1, gid => 1, map { $_ => 1 } keys %name2ix );

    foreach my $orig_key ( keys %$opts ) {
        my $k = lc($orig_key);
        $k =~ s{^st_}{};

        unless ( $known_opts{$k} ) {
            if ( $k eq 'mode' ) {
                Carp::croak("Unknown option '$orig_key': use 'perms' for permission bits (file type is set automatically)");
            }
            Carp::croak("Unknown option '$orig_key' passed to stat helper");
        }

        next unless defined $name2ix{$k};
        $stat[ $name2ix{$k} ] = $opts->{$orig_key};
    }

    return \@stat;
}

######################################################
### Scope guard for automatic mock cleanup
######################################################

package Overload::FileCheck::Guard;

sub new {
    my ( $class, @checks ) = @_;

    return bless { checks => \@checks, active => 1 }, $class;
}

sub cancel {
    my ($self) = @_;

    $self->{active} = 0;
    return;
}

sub DESTROY {
    my ($self) = @_;

    return unless $self->{active};
    $self->{active} = 0;

    local $@;
    eval { Overload::FileCheck::unmock_file_check( @{ $self->{checks} } ) };
    return;
}

1;

__END__