File Coverage

blib/lib/Test/Mock/Cmd.pm

Criterion	Covered	Total	%
statement	42	43	97.6
branch	24	24	100.0
path			n/a
condition	25	27	92.5
subroutine	10	11	90.9
pod	3	3	100.0
total	104	108	96.3

package Test::Mock::Cmd;

use strict;
use warnings;
use Carp ();

$Test::Mock::Cmd::VERSION = '0.6';

sub import {
    if ( @_ == 3 || @_ == 5 || @_ == 7 ) {
        my ( $class, %override ) = @_;

        for my $k ( keys %override ) {
            if ( $k ne 'system' && $k ne 'exec' && $k ne 'qr' ) {
                Carp::croak('Key is not system, exec, or qr');
            }
            if ( ref( $override{$k} ) ne 'CODE' && ref( $override{$k} ) ne 'HASH' ) {
                Carp::croak('Not a CODE or HASH reference');
            }
        }

        no warnings 'redefine';
        *CORE::GLOBAL::system   = _transmogrify_to_code( $override{'system'}, \&orig_system ) if $override{'system'};
        *CORE::GLOBAL::exec     = _transmogrify_to_code( $override{'exec'},   \&orig_exec )   if $override{'exec'};
        *CORE::GLOBAL::readpipe = _transmogrify_to_code( $override{'qr'},     \&orig_qr )     if $override{'qr'};

        return 1;
    }

    if ( @_ == 4 ) {
        for my $idx ( 1 .. 3 ) {
            Carp::croak('Not a CODE or HASH reference') if ref( $_[$idx] ) ne 'CODE' && ref( $_[$idx] ) ne 'HASH';
        }
    }
    elsif ( @_ == 2 ) {
        Carp::croak('Not a CODE or HASH reference') if ref( $_[1] ) ne 'CODE' and ref( $_[1] ) ne 'HASH';
    }
    else {
        Carp::croak( __PACKAGE__ . '->import() requires a 1-3 key hash, 1 code/hash reference, or 3 code/hash references as arguments' );
    }

    no warnings 'redefine';
    *CORE::GLOBAL::system = _transmogrify_to_code( $_[1], \&orig_system );
    *CORE::GLOBAL::exec     = _transmogrify_to_code( $_[2] || $_[1], \&orig_exec );
    *CORE::GLOBAL::readpipe = _transmogrify_to_code( $_[3] || $_[1], \&orig_qr );
}

# This doesn't make sense w/ the once-set-always-set behavior of these functions and it's just weird so we leave it out for now.
# If there is a way to get it to take effect like other use/no then patches welcome!
# sub unimport {
#     no warnings 'redefine';
#     *CORE::GLOBAL::system   = \&orig_system;    # it'd be nice to assign the CORE::system directly instead of the \&orig_system
#     *CORE::GLOBAL::exec     = \&orig_exec;      # it'd be nice to assign the CORE::exec directly instead of the \&orig_exec
#     *CORE::GLOBAL::readpipe = \&orig_qx;        # it'd be nice to assign the CORE::readpipe directly instead of the \&orig_qx
# }

sub orig_system {

    # goto &CORE::system won't work here, but it'd be nice
    return CORE::system(@_);
}

sub orig_exec {

    # goto &CORE::exec won't work here, but it'd be nice
    return CORE::exec(@_);
}

sub orig_qx {

    # goto &CORE::readpipe won't work here,  but it'd be nice
    return CORE::readpipe( $_[0] );    # we use $_[0] because @_ results in something like 'sh: *main::_: command not found'
}

sub _transmogrify_to_code {
    my ( $val, $orig ) = @_;
    return $val if ref($val) eq 'CODE';

    return sub {
        if ( exists $val->{ $_[0] } ) {
            return $val->{ $_[0] }->(@_);
        }
        else {
            goto &$orig;
        }
    };
}

1;

__END__