File Coverage

blib/lib/Overload/FileCheck.pm

Criterion	Covered	Total	%
statement	214	225	95.1
branch	124	146	84.9
condition	29	45	64.4
subroutine	31	32	96.8
pod	12	13	92.3
total	410	461	88.9

# 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 base 'Exporter';

BEGIN {

    our $VERSION = '0.011'; # 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 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};

our @EXPORT_OK = (
    qw{
      mock_all_from_stat
      mock_all_file_checks mock_file_check 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;

my %OP_CAN_RETURN_INT   = map { $MAP_FC_OP{$_} => 1 } qw{ s 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;
        }
    }

    # 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 mock_file_check {
    my ( $check, $sub ) = @_;

    die q[Check is not defined] unless defined $check;
    die q[Second arg must be a CODE ref] unless ref $sub eq 'CODE';

    $check =~ s{^-+}{};    # strip any extra dashes
                           #return -1 unless defined $MAP_FC_OP{$check}; # we should not do that
    die qq[Unknown check '$check'] unless defined $MAP_FC_OP{$check};

    my $optype = $MAP_FC_OP{$check};
    die qq[-$check is already mocked by Overload::FileCheck] if exists $_current_mocks->{$optype};

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

    _xs_mock_op($optype);

    return 1;
}

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

    foreach my $check (@checks) {
        die q[Check is not defined] unless defined $check;
        $check =~ s{^-+}{};    # strip any extra dashes
        die qq[Unknown check '$check'] unless defined $MAP_FC_OP{$check};

        my $optype = $MAP_FC_OP{$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 _

    my $can_use_stat;
    $can_use_stat = 1 if $check =~ qr{^[sfdMXxzACORWeorw]$};

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

    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 ($can_use_stat) {
        no warnings;    # throw warnings with Perl <= 5.14
        @stat = stat($f_or_fh) if defined $f_or_fh;
    }
    else {
        no warnings;
        @lstat = lstat($f_or_fh) if defined $f_or_fh;
    }

    if ( $check eq 'r' ) {

        # -r  File is readable by effective uid/gid.
        #  return _cando(stat_mode, effective, &PL_statcache)
        #   return _cando( S_IRUSR, 1 )

        # ugly need a better way to do this...
        _xs_unmock_op($optype);
        return _to_bool( scalar -r _ );
    }
    elsif ( $check eq 'w' ) {

        # -w  File is writable by effective uid/gid.
        _xs_unmock_op($optype);
        return _to_bool( scalar -w _ );
    }
    elsif ( $check eq 'x' ) {

        # -x  File is executable by effective uid/gid.
        _xs_unmock_op($optype);
        return _to_bool( scalar -x _ );
    }
    elsif ( $check eq 'o' ) {

        # -o  File is owned by effective uid.
        _xs_unmock_op($optype);
        return _to_bool( scalar -o _ );
    }
    elsif ( $check eq 'R' ) {

        # -R  File is readable by real uid/gid.
        _xs_unmock_op($optype);
        return _to_bool( scalar -R _ );
    }
    elsif ( $check eq 'W' ) {

        # -W  File is writable by real uid/gid.
        _xs_unmock_op($optype);
        return _to_bool( scalar -W _ );
    }
    elsif ( $check eq 'X' ) {

        # -X  File is executable by real uid/gid.

        _xs_unmock_op($optype);
        return _to_bool( scalar -X _ );
    }
    elsif ( $check eq 'O' ) {

        # -O  File is owned by real uid.
        _xs_unmock_op($optype);
        return _to_bool( scalar -O _ );
    }
    elsif ( $check eq 'e' ) {

        # -e  File exists.
        # a file can only exists if MODE is set ?
        return _to_bool( scalar @stat && $stat[ST_MODE] );
    }
    elsif ( $check eq 'z' ) {

        # -z  File has zero size (is empty).

        # TODO: can probably avoid the extra called...
        #   by checking it ourself

        _xs_unmock_op($optype);
        return _to_bool( scalar -z _ );
    }
    elsif ( $check eq 's' ) {

        # -s  File has nonzero size (returns size in bytes).

        # fallback does not work with symlinks
        #   do the check ourself, which also save a few calls

        return $stat[ST_SIZE];
    }
    elsif ( $check eq 'f' ) {

        # -f  File is a plain file.
        return _check_mode_type( $stat[ST_MODE], S_IFREG );
    }
    elsif ( $check eq 'd' ) {

        # -d  File is a directory.

        return _check_mode_type( $stat[ST_MODE], S_IFDIR );
    }
    elsif ( $check eq 'l' ) {

        # -l  File is a symbolic link (false if symlinks aren't
        #    supported by the file system).

        return _check_mode_type( $lstat[ST_MODE], S_IFLNK );
    }
    elsif ( $check eq 'p' ) {

        # -p  File is a named pipe (FIFO), or Filehandle is a pipe.
        return _check_mode_type( $lstat[ST_MODE], S_IFIFO );
    }
    elsif ( $check eq 'S' ) {

        # -S  File is a socket.
        return _check_mode_type( $lstat[ST_MODE], S_IFSOCK );
    }
    elsif ( $check eq 'b' ) {

        # -b  File is a block special file.
        return _check_mode_type( $lstat[ST_MODE], S_IFBLK );
    }
    elsif ( $check eq 'c' ) {

        # -c  File is a character special file.
        return _check_mode_type( $lstat[ST_MODE], S_IFCHR );
    }
    elsif ( $check eq 't' ) {

        # -t  Filehandle is opened to a tty.
        _xs_unmock_op($optype);
        return _to_bool( scalar -t _ );
    }
    elsif ( $check eq 'u' ) {

        # -u  File has setuid bit set.
        _xs_unmock_op($optype);
        return _to_bool( scalar -u _ );
    }
    elsif ( $check eq 'g' ) {

        # -g  File has setgid bit set.
        _xs_unmock_op($optype);
        return _to_bool( scalar -g _ );
    }
    elsif ( $check eq 'k' ) {

        # -k  File has sticky bit set.

        _xs_unmock_op($optype);
        return _to_bool( scalar -k _ );
    }
    elsif ( $check eq 'T' ) {    # heuristic guess.. throw a die?

        # -T  File is an ASCII or UTF-8 text file (heuristic guess).

        #return CHECK_IS_FALSE if -d $f_or_fh;

        _xs_unmock_op($optype);
        return _to_bool( scalar -T *_ );
    }
    elsif ( $check eq 'B' ) {    # heuristic guess.. throw a die?

        # -B  File is a "binary" file (opposite of -T).

        return CHECK_IS_TRUE if -d $f_or_fh;

        # ... we cannot really know...
        # ... this is an heuristic guess...

        _xs_unmock_op($optype);
        return _to_bool( scalar -B *_ );
    }
    elsif ( $check eq 'M' ) {

        # -M  Script start time minus file modification time, in days.

        return CHECK_IS_NULL unless scalar @stat && defined $stat[ST_MTIME];
        return ( ( get_basetime() - $stat[ST_MTIME] ) / 86400.0 );

        #return int( scalar -M _ );
    }
    elsif ( $check eq 'A' ) {

        # -A  Same for access time.
        #
        # ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0
        return CHECK_IS_NULL unless scalar @stat && defined $stat[ST_ATIME];

        return ( ( get_basetime() - $stat[ST_ATIME] ) / 86400.0 );
    }
    elsif ( $check eq 'C' ) {

        # -C  Same for inode change time (Unix, may differ for other
        #_xs_unmock_op($optype);
        #return scalar -C *_;
        return CHECK_IS_NULL unless scalar @stat && defined $stat[ST_CTIME];

        return ( ( get_basetime() - $stat[ST_CTIME] ) / 86400.0 );
    }
    else {
        die "Unknown check $check.\n";
    }

    die "FileCheck -$check is not implemented by Overload::FileCheck...";

    return FALLBACK_TO_REAL_OP;
}

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

    return ( $s ? CHECK_IS_TRUE : CHECK_IS_FALSE );
}

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

    return CHECK_IS_FALSE 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) = @_;

    die 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};
        die 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 {

    if ( !scalar %REVERSE_MAP ) {
        foreach my $k ( keys %MAP_FC_OP ) {
            $REVERSE_MAP{ $MAP_FC_OP{$k} } = $k;
        }
    }

    my @mocks = sort map { $REVERSE_MAP{$_} } keys %$_current_mocks;
    return 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, @others ) = @_;

    die if scalar @others;    # need to move this in a unit test

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

    $file = $_last_call_for if !defined $file && defined $_last_call_for && !defined $_current_mocks->{ $MAP_FC_OP{'stat'} };
    my ( $out, @extra ) = $_current_mocks->{$optype}->($file);
    $_last_call_for = $file;

    # FIXME return undef when not defined out

    if ( defined $out && $OP_CAN_RETURN_INT{$optype} ) {
        return $out;          # limitation to int for now in fact some returns NVs
    }

    if ( !$out ) {

        # check if the user provided a custom ERRNO error otherwise
        #   set one for him, so a test could never fail without having
        #   ERRNO set
        if ( !int($!) ) {
            $! = $DEFAULT_ERRNO{ $REVERSE_MAP{$optype} || 'default' } || $DEFAULT_ERRNO{'default'};
        }

        #return undef unless defined $out;
        return CHECK_IS_FALSE;
    }

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

    # stat and lstat OP are returning a stat ARRAY in addition to the status code
    if ( $OP_IS_STAT_OR_LSTAT{$optype} ) {

        # .......... Stat_t
        # dev_t     st_dev     Device ID of device containing file.
        # ino_t     st_ino     File serial number.
        # mode_t    st_mode    Mode of file (see below).
        # nlink_t   st_nlink   Number of hard links to the file.
        # uid_t     st_uid     User ID of file.
        # gid_t     st_gid     Group ID of file.
        # dev_t     st_rdev    Device ID (if file is character or block special).
        # off_t     st_size    For regular files, the file size in bytes.
        # time_t    st_atime   Time of last access.
        # time_t    st_mtime   Time of last data modification.
        # time_t    st_ctime   Time of last status change.
        # blksize_t st_blksize A file system-specific preferred I/O block size for
        # blkcnt_t  st_blocks  Number of blocks allocated for this object.
        # ......

        my $stat      = $out // $others[0];    # can be array or hash at this point
        my $stat_is_a = ref $stat;
        die q[Your mocked function for stat should return a stat array or hash] unless $stat_is_a;

        my $stat_as_arrayref;

        # can handle one ARRAY or a HASH
        my $stat_t_max = STAT_T_MAX;
        if ( $stat_is_a eq 'ARRAY' ) {
            $stat_as_arrayref = $stat;
            my $av_size = scalar @$stat;
            if (
                $av_size                       # 0 is valid when the file is missing
                && $av_size != $stat_t_max
            ) {
                die qq[Stat array should contain exactly 0 or $stat_t_max values];
            }
        }
        elsif ( $stat_is_a eq 'HASH' ) {
            $stat_as_arrayref = [ (0) x $stat_t_max ];    # start with an empty array
            foreach my $k ( keys %$stat ) {
                my $ix = $MAP_STAT_T_IX{ lc($k) };
                die qq[Unknown index for stat_t struct key $k] unless defined $ix;
                $stat_as_arrayref->[$ix] = $stat->{$k};
            }
        }
        else {
            die q[Your mocked function for stat should return a stat array or hash];
        }

        return ( CHECK_IS_TRUE, $stat_as_arrayref );
    }

    return CHECK_IS_TRUE;
}

# 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_for {
    my ( $type, $opts ) = @_;

    my @stat = ( (0) x 13 );    # 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 {

            $stat[ST_UID] = getpwnam( $opts->{uid} );
        }
    }

    if ( defined $opts->{gid} ) {
        if ( $opts->{gid} =~ qr{^[0-9]+$} ) {
            $stat[ST_GID] = $opts->{gid};
        }
        else {
            $stat[ST_GID] = getgrnam( $opts->{gid} );
        }
    }

    # options that we can simply copy to a slot
    my %name2ix = (
        size    => ST_SIZE,
        atime   => ST_ATIME,
        mtime   => ST_MTIME,
        ctime   => ST_CTIME,
        blksize => ST_BLKSIZE,
        blocks  => ST_BLOCKS,
    );

    foreach my $k ( keys %$opts ) {
        $k = lc($k);
        $k =~ s{^st_}{};
        next unless defined $name2ix{$k};

        $stat[ $name2ix{$k} ] = $opts->{$k};
    }

    return \@stat;
}

1;

__END__