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

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__

=pod

=encoding utf-8

=head1 NAME

Overload::FileCheck - override/mock perl file check -X: -e, -f, -d, ...

=head1 VERSION

version 0.015

=head1 SYNOPSIS

Overload::FileCheck provides a way to mock one or more file checks.
It is also possible to mock stat/lstat functions using L<"mock_all_from_stat"> and let Overload::FileCheck
mock for you for any other -X checks.

By using mock_all_file_checks you can set a hook function to reply any -X check.

 #!perl
 
 use strict;
 use warnings;
 
 use Test::More;
 use Overload::FileCheck q{:all};
 
 my @exist     = qw{cherry banana apple};
 my @not_there = qw{not-there missing-file};
 
 mock_all_file_checks( \&my_custom_check );
 
 sub my_custom_check {
     my ( $check, $f ) = @_;
 
     if ( $check eq 'e' || $check eq 'f' ) {
         return CHECK_IS_TRUE  if grep { $_ eq $f } @exist;
         return CHECK_IS_FALSE if grep { $_ eq $f } @not_there;
     }
 
     return CHECK_IS_FALSE if $check eq 'd' && grep { $_ eq $f } @exist;
 
     # fallback to the original Perl OP
     return FALLBACK_TO_REAL_OP;
 }
 
 foreach my $f (@exist) {
     ok( -e $f,  "-e $f is true" );
     ok( -f $f,  "-f $f is true" );
     ok( !-d $f, "-d $f is false" );
 }
 
 foreach my $f (@not_there) {
     ok( !-e $f, "-e $f is false" );
     ok( !-f $f, "-f $f is false" );
 }
 
 unmock_all_file_checks();
 
 done_testing;

=head1 DESCRIPTION

Overload::FileCheck provides a hook system to mock Perl filechecks OPs

With this module you can provide your own pure perl code when performing
file checks using one of the -X ops: -e, -f, -z, ...

L<https://perldoc.perl.org/functions/-X.html>

    -r  File is readable by effective uid/gid.
    -w  File is writable by effective uid/gid.
    -x  File is executable by effective uid/gid.
    -o  File is owned by effective uid.
    -R  File is readable by real uid/gid.
    -W  File is writable by real uid/gid.
    -X  File is executable by real uid/gid.
    -O  File is owned by real uid.
    -e  File exists.
    -z  File has zero size (is empty).
    -s  File has nonzero size (returns size in bytes).
    -f  File is a plain file.
    -d  File is a directory.
    -l  File is a symbolic link (false if symlinks aren't
        supported by the file system).
    -p  File is a named pipe (FIFO), or Filehandle is a pipe.
    -S  File is a socket.
    -b  File is a block special file.
    -c  File is a character special file.
    -t  Filehandle is opened to a tty.
    -u  File has setuid bit set.
    -g  File has setgid bit set.
    -k  File has sticky bit set.
    -T  File is an ASCII or UTF-8 text file (heuristic guess).
    -B  File is a "binary" file (opposite of -T).
    -M  Script start time minus file modification time, in days.
    -A  Same for access time.
    -C  Same for inode change time (Unix, may differ for other
  platforms)

Also view pp_sys.c from the Perl source code, where are defined the original OPs.

In addition it's also possible to mock the Perl OP C<stat> and C<lstat>, read L</"Mocking stat and lstat"> section for more details.

=for markdown [![](https://github.com/cpan-authors/Overload-FileCheck/workflows/linux/badge.svg)](https://github.com/cpan-authors/Overload-FileCheck/actions)

=head1 Usage and Examples

When using this module, you can decide to mock filecheck OPs on import or later
at run time.

=head2 Mocking filecheck at import time

You can mock multiple filecheck at import time.
Note that the ':check' will import constants like:
CHECK_IS_TRUE, CHECK_IS_FALSE, FALLBACK_TO_REAL_OP
which are recommended return values to use in your hook functions.

 #!perl
 
 use strict;
 use warnings;
 
 use Overload::FileCheck '-e' => \&my_dash_e, -f => sub { 1 }, ':check';
 
 # example of your own callback function to mock -e
 # when returning
 #  0: the test is false
 #  1: the test is true
 # -1: you want to use the answer from Perl itself :-)
 
 sub dash_e {
     my ($file_or_handle) = @_;
 
     # return true on -e for this specific file
     return CHECK_IS_TRUE if $file_or_handle eq '/this/file/is/not/there/but/act/like/if/it/was';
 
     # claim that /tmp is not available even if it exists
     return CHECK_IS_FALSE if $file_or_handle eq '/tmp';
 
     # delegate the answer to the Perl CORE -e OP
     #   as we do not want to control these files
     return FALLBACK_TO_REAL_OP;
 }

=head2 Mocking filecheck at run time

You can also get a similar behavior by declaring the overload later at run time.

 #!perl
 
 use strict;
 use warnings;
 
 use Overload::FileCheck q(:all);
 
 mock_file_check( '-e' => \&my_dash_e );
 mock_file_check( '-f' => sub { CHECK_IS_TRUE } );
 
 sub dash_e {
     my ($file_or_fh) = @_;
 
     # return true on -e for this specific file
     return CHECK_IS_TRUE if $file_or_fh eq '/this/file/is/not/there/but/act/like/if/it/was';
 
     # claim that /tmp is not available even if it exists
     return CHECK_IS_FALSE if $file_or_fh eq '/tmp';
 
     # delegate the answer to the Perl CORE -e OP
     #   as we do not want to control these files
     return FALLBACK_TO_REAL_OP;
 }

=head2 Check helpers to use in your callback function

In your callback function you should use the following helpers to return.

=over

=item B<CHECK_IS_FALSE>: use this constant when the test is false

=item B<CHECK_IS_TRUE>: use this when you the test is true

=item B<FALLBACK_TO_REAL_OP>: you want to delegate the answer to Perl itself :-)

=back

It's also possible to return one integer. Checks like C<-s>, C<-M>, C<-C>, C<-A> can return
any integers.

Example:

    use Overload::FileCheck q(:all);

    mock_file_check( '-s' => \&my_dash_s );

    sub my_dash_s {
        my ( $file_or_handle ) = @_;

        if ( $file_or_handle eq '/a/b/c' ) {
            return 42;
        }

        return FALLBACK_TO_REAL_OP;
    }

=head2 Tracing all file checks usage

You can trace all file checks in your codebase without altering it.

 #!perl
 
 use strict;
 use warnings;
 
 use Carp;
 use Overload::FileCheck q{:all};
 
 mock_all_file_checks( \&my_custom_check );
 
 sub my_custom_check {
     my ( $check, $f ) = @_;
 
     local $Carp::CarpLevel = 2;    # do not display Overload::FileCheck stack
     printf( "# %-10s called from %s", "-$check '$f'", Carp::longmess() );
 
     # fallback to the original Perl OP
     return FALLBACK_TO_REAL_OP;
 }
 
 -d '/root';
 -l '/root';
 -e '/';
 -d '/';
 
 unmock_all_file_checks();
 
 __END__
 
 # The output looks similar to
 
 -d '/root' called from  at t/perldoc_mock-all-file-check-trace.t line 26.
 -l '/root' called from  at t/perldoc_mock-all-file-check-trace.t line 27.
 -e '/'     called from  at t/perldoc_mock-all-file-check-trace.t line 28.
 -d '/'     called from  at t/perldoc_mock-all-file-check-trace.t line 29.

=head2 Mock one or more file checks: -e, -f

You can mock a single file check type like '-e', '-f', ...

 #!perl
 
 use strict;
 use warnings;
 
 use Overload::FileCheck qw{mock_file_check unmock_file_check unmock_all_file_checks :check};
 use Errno ();
 
 # all -f checks will be true from now
 mock_file_check( '-f' => sub { 1 } );
 
 # mock all calls to -e and delegate to the function dash_e
 mock_file_check( '-e' => \&dash_e );
 
 # example of your own callback function to mock -e
 # when returning
 #  0: the test is false
 #  1: the test is true
 # -1: you want to use the answer from Perl itself :-)
 
 sub dash_e {
     my ($file_or_fh) = @_;
 
     # return true on -e for this specific file
     return CHECK_IS_TRUE
       if $file_or_fh eq '/this/file/is/not/there/but/act/like/if/it/was';
 
     # claim that /tmp is not available even if it exists
     if ( $file_or_fh eq '/tmp' ) {
 
         # you can set Errno to any custom value
         #   or it would be set to Errno::ENOENT() by default
         $! = Errno::ENOENT();    # set errno to "No such file or directory"
         return CHECK_IS_FALSE;
     }
 
     # delegate the answer to the Perl CORE -e OP
     #   as we do not want to control these files
     return FALLBACK_TO_REAL_OP;
 }
 
 # unmock -e and -f
 unmock_file_check('-e');
 unmock_file_check('-f');
 unmock_file_check(qw{-e -f});
 
 # or unmock all existing filecheck
 unmock_all_file_checks();

=head2 Mock check calls at import time

You can also mock the check functions at import time by providing a check test
and a custom function

 #!perl
 
 use strict;
 use warnings;
 
 use Test::More;
 use Overload::FileCheck '-e' => \&my_dash_e, q{:check};
 
 # Mock one or more check
 #use Overload::FileCheck '-e' => \&my_dash_e, '-f' => sub { 1 }, 'x' => sub { 0 }, ':check';
 
 my @exist     = qw{cherry banana apple};
 my @not_there = qw{chocolate and peanuts};
 
 sub my_dash_e {
     my $f = shift;
 
     note "mocked -e called for", $f;
 
     return CHECK_IS_TRUE  if grep { $_ eq $f } @exist;
     return CHECK_IS_FALSE if grep { $_ eq $f } @not_there;
 
     # we have no idea about these files
     return FALLBACK_TO_REAL_OP;
 }
 
 foreach my $f (@exist) {
     ok( -e $f, "file '$f' exists" );
 }
 
 foreach my $f (@not_there) {
     ok( !-e $f, "file '$f' exists" );
 }
 
 # this is using the fallback logic '-1'
 ok -e $0,  q[$0 is there];
 ok -e $^X, q[$^X is there];
 
 done_testing;

=head1 Mocking stat and lstat

=head2 How to mock stat?

Here is a short sample how you can mock stat and lstat.
This is an extract from the testsuite, Test2::* modules are
just there to illustrate the behavior. You should not necessary use them
in your code.

For more advanced samples, browse to the source code and check the test files
in t or examples directories.

 #!perl
 
 use strict;
 use warnings;
 
 use Test2::Bundle::Extended;
 use Test2::Tools::Explain;
 use Test2::Plugin::NoWarnings;
 
 use Overload::FileCheck q(:all);
 
 # our helper would be called for every stat & lstat calls
 mock_stat( \&my_stat );
 
 sub my_stat {
     my ( $opname, $file_or_handle ) = @_;
 
     # $opname can be 'stat' or 'lstat'
     # in this sample only mock stat, leave lstat alone
     return FALLBACK_TO_REAL_OP() if $opname eq 'lstat';
 
     my $f = $file_or_handle;    # alias for readability
 
     # return an array ref with 13 elements containing the stat output
     return [ 1 .. 13 ] if $f eq $0;
 
     my $fake_stat = [ (0) x 13 ];
 
     # you also have access to some constants
     # to set the stat values in the correct slot
     # this is using some fake values, without any specific meaning...
     $fake_stat->[ST_DEV]     = 1;
     $fake_stat->[ST_INO]     = 2;
     $fake_stat->[ST_MODE]    = 4;
     $fake_stat->[ST_NLINK]   = 8;
     $fake_stat->[ST_UID]     = 16;
     $fake_stat->[ST_GID]     = 32;
     $fake_stat->[ST_RDEV]    = 64;
     $fake_stat->[ST_SIZE]    = 128;
     $fake_stat->[ST_ATIME]   = 256;
     $fake_stat->[ST_MTIME]   = 512;
     $fake_stat->[ST_CTIME]   = 1024;
     $fake_stat->[ST_BLKSIZE] = 2048;
     $fake_stat->[ST_BLOCKS]  = 4096;
 
     return $fake_stat if $f eq 'fake.stat';
 
     # can also return stats as a hash ref
     return { st_dev => 1, st_atime => 987654321 } if $f eq 'hash.stat';
 
     return {
         st_dev     => 1,
         st_ino     => 2,
         st_mode    => 3,
         st_nlink   => 4,
         st_uid     => 5,
         st_gid     => 6,
         st_rdev    => 7,
         st_size    => 8,
         st_atime   => 9,
         st_mtime   => 10,
         st_ctime   => 11,
         st_blksize => 12,
         st_blocks  => 13,
     } if $f eq 'hash.stat.full';
 
     # return an empty array if you want to mark the file as not available
     return [] if $f eq 'file.is.not.there';
 
     # fallback to the regular OP
     return FALLBACK_TO_REAL_OP();
 }
 
 is [ stat($0) ], [ 1 .. 13 ], 'stat is mocked for $0';
 is [ stat(_) ], [ 1 .. 13 ],
   '_ also works: your mocked function is not called';
 
 is [ stat('fake.stat') ],
   [ 1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024, 2048, 4096 ], 'fake.stat';
 
 is [ stat('hash.stat.full') ], [ 1 .. 13 ], 'hash.stat.full';
 
 unmock_stat();
 
 done_testing;

=head2 Convenient constants available when mocking stat

When mocking stat or lstat function your callback function should return one of the following

=over

=item either one ARRAY Ref containing 13 entries as described by the stat function (in the same order)

=item or an empty ARRAY Ref, if the file does not exist

=item or one HASH ref using one or more of the following keys: 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

=item or return FALLBACK_TO_REAL_OP when you want to let Perl take back the control for that file

=back

In order to manipulate the ARRAY ref and insert/update one specific entry, some constant are available
to access to the correct index via a 'name':

=over

=item ST_DEV

=item ST_INO

=item ST_MODE

=item ST_NLINK

=item ST_UID

=item ST_GID

=item ST_RDEV

=item ST_SIZE

=item ST_ATIME

=item ST_MTIME

=item ST_CTIME

=item ST_BLKSIZE

=item ST_BLOCKS

=back

=head2 Mocking all file checks from a single 'stat' function

A recommended option is to only mock the 'stat' and 'lstat' function
and let Overload::FileCheck mock for you all file checks: -e, -f, -s, -z, ...

By doing so, using '_' or '*_' (a.k.a. PL_defgv) in your filecheck would work without any extra effort.

    -d "/my/file" && -s _

Netherway some limitations exist. Indeed the checks '-B' and '-T' are using some heuristics to determine
if the file is a binary or a text. This would require more than just a simple stat output.
In these cases you can mock the -B and -T to your own functions.

    mock_file_check( '-B' => sub { ... } );
    mock_file_check( '-T' => sub { ... } );

=head3 mock_all_from_stat

By using 'mock_all_from_stat' function, you will only provide a 'fake' stat / lstat function and
let Overload::FileCheck provide the hooks for all common checks

 #!perl
 
 use strict;
 use warnings;
 
 # setup at import time
 use Overload::FileCheck '-from-stat' => \&mock_stat_from_sys, qw{:check :stat};
 
 # or set it later at run time
 # mock_all_from_stat( \&my_stat );
 
 sub mock_stat_from_sys {
 
     my ( $stat_or_lstat, $f ) = @_;
 
     # $stat_or_lstat would be set to 'stat' or 'lstat' depending
     #   if it's a 'stat' or 'lstat' call
 
     if ( defined $f && $f eq 'mocked.file' ) {    # "<<$f is mocked>>"
         return [                                  # return a fake stat output (regular file)
             64769,      69887159,   33188, 1, 0, 0, 0, 13,
             1539928982, 1539716940, 1539716940,
             4096,       8
         ];
 
         return stat_as_file();
 
         return [];                                # if the file is missing
     }
 
     # let Perl answer the stat question for us
     return FALLBACK_TO_REAL_OP;
 }
 
 # ...
 
 # later in your code
 if ( -e 'mocked.file' && -f _ && !-d _ ) {
     print "# This file looks real...\n";
 }
 
 # ...
 
 # you can unmock the OPs at anytime
 Overload::FileCheck::unmock_all_file_checks();

=head2 Using stat_as_* helpers

When mocking the stat functions you might consider using one of the 'stat_as_*' helper.
Available functions are:

=over

=item stat_as_directory

=item stat_as_file

=item stat_as_symlink

=item stat_as_socket

=item stat_as_chr

=item stat_as_block

=item stat_as_fifo

=back

All of these functions take some optional arguments to set: uid, gid, perms, dev, ino, nlink, rdev, size, atime, mtime, ctime, blksize, blocks.
Example:

    use Overload::FileCheck -from-stat => \&my_stat, q{:check};

    sub my_stat {
        my ( $stat_or_lstat, $f_or_fh ) = @_;

        return stat_as_file() if $f_or_fh eq 'fake.file';

        return stat_as_directory( uid => 0, gid => 'root' ) if $f_or_fh eq 'fake.dir';

        return stat_as_file( mtime => time() ) if $f_or_fh eq 'touch.file';

        return stat_as_file( perms => 0755 ) if $f_or_fh eq 'touch.file.0755';

        return FALLBACK_TO_REAL_OP;
    }

=head1 Available functions

=head2 mock_file_check( $check, CODE )

mock_file_check function is used to mock one of the filecheck op.

The first argument is one of the file check: '-f', '-e', ... where the dash is optional.
It also accepts 'e', 'f', ...

When trying to mock a filecheck already mocked, the function will die with an error like

  -f is already mocked by Overload::FileCheck

This would guarantee that you are not mocking multiple times the same filecheck in your codebase.

Otherwise returns 1 on success.

  # this is probably a very bad idea to do this in your codebase
  # but can be useful for some testing
  # in that sample all '-e' checks will always return true...
  mock_file_check( '-e' => sub { 1 } )

=head2 mock_file_check_guard( $check, CODE )

Like C<mock_file_check>, but returns a guard object instead of C<1>.
When the guard goes out of scope (or is otherwise destroyed), the mock is
automatically removed via C<unmock_file_check>.  This improves test isolation
by guaranteeing cleanup even if the test dies.

  {
      my $guard = mock_file_check_guard( '-e' => sub { CHECK_IS_TRUE } );
      ok( -e "/fake/file", "mocked" );
  }
  # -e is automatically unmocked here

Call C<< $guard->cancel >> to prevent the automatic unmock.

=head2 unmock_file_check( $check, [@extra_checks] )

Disable the effect of one or more specific mock.
The argument to unmock_file_check can be a list or a single scalar value.
The leading dash is optional.

  unmock_file_check( '-e' );
  unmock_file_check( 'e' );            # also work without the dash
  unmock_file_check( qw{-e -f -z} );
  unmock_file_check( qw{e f} );        # also work without the dashes

=head2 unmock_all_file_checks()

By a simple call to unmock_all_file_checks, you would disable the effect of overriding the
filecheck OPs. (not that the XS code is still plugged in, but fallback as soon
as possible to the original OP)

=head2 mock_stat( CODE )

mock_stat provides one interface to setup a hook for all C<stat> and C<lstat> calls.
It's slighly different than the other mock functions. As the first argument passed to
the hook function would be a string 'stat' or 'lstat'.

You can get a more advanced hook sample from L</"Mocking stat">.

    use Overload::FileCheck q(:all);

    # our helper would be called for every stat & lstat calls
    mock_stat( \&my_stat );

    sub my_stat {
        my ( $opname, $file_or_handle ) = @_;

        ...

        return FALLBACK_TO_REAL_OP;
    }

=head2 unmock_stat()

By calling unmock_stat, you would disable any previous hook set using mock_stat

=head2 mock_all_from_stat( CODE )

By providing a single hook for 'stat' and 'lstat' you let OverLoad::FileCheck take care
of mocking all other -X checks.

read L</" Mocking all file checks from a single 'stat' function"> for sample usage.

=head2 stat_as_directory( %OPTS )

Create a stat array ref for a directory.
%OPTS is optional and can set one or more using arguments among: uid, gid, perms, dev, ino, nlink, rdev, size, atime, mtime, ctime, blksize, blocks.
read the section L</"Using stat_as_* helpers"> for some sample usages.

=head2 stat_as_file( %OPTS )

Create a stat array ref for a regular file
view stat_as_directory and L</"Using stat_as_* helpers"> for some sample usages

=head2 stat_as_symlink( %OPTS )

Create a stat array ref for a symlink
view stat_as_directory and L</"Using stat_as_* helpers"> for some sample usages

=head2 stat_as_socket( %OPTS )

Create a stat array ref for a socket
view stat_as_directory and L</"Using stat_as_* helpers"> for some sample usages

=head2 stat_as_chr( %OPTS )

Create a stat array ref for an empty character device
view stat_as_directory and L</"Using stat_as_* helpers"> for some sample usages

=head2 stat_as_block( %OPTS )

Create a stat array ref for an empty block device
view stat_as_directory and L</"Using stat_as_* helpers"> for some sample usages

=head2 stat_as_fifo( %OPTS )

Create a stat array ref for a named pipe (FIFO)
view stat_as_directory and L</"Using stat_as_* helpers"> for some sample usages

=head1 Notice

This is a very early development stage and some behavior might change before the release of a more stable build.

=head1 Known Limitations

=head2 This is design for Unit Test purpose

This code was mainly designed to be used during unit tests. It's far from being optimized at this time.

=head2 Mock as soon as possible

Code loaded/interpreted before mocking a file check, would not take benefit of Overload::FileCheck.
You probably want to load and call the mock function of Overload::FileCheck as early as possible.

=head2 -B and -T are using heuristics

File check operators like -B and -T are using heuristics to guess if the file content is binary or text.
By using mock_all_from_stat or ('-from-stat' at import time), we cannot provide an accurate -B or -T checks.
You would need to provide a custom hooks for them

=head1 LICENSE

This software is copyright (c) 2018 by cPanel, Inc.

This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming
language system itself.

=head1 DISCLAIMER OF WARRANTY

BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY
APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE
SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE
OF THE SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
REPAIR, OR CORRECTION.

IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY
WHO MAY MODIFY AND/OR REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE TO YOU FOR DAMAGES,
INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR
THIRD PARTIES OR A FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS
BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.

=head1 AUTHOR

Nicolas R <atoomic@cpan.org>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2026 by cPanel, L.L.C.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut
