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


line stmt bran path cond sub pod time code
1               package Test::Mock::Cmd;
2                
3 8       8   65052 use strict;
  8           22  
  8           580  
4 8       8   106 use warnings;
  8           25  
  8           541  
5 8       8   58 use Carp ();
  8           33  
  8           1871  
6                
7               $Test::Mock::Cmd::VERSION = '0.7';
8                
9               sub import {
10 41 100   100 41   15995 if ( @_ == 3 || @_ == 5 || @_ == 7 ) {
        100        
11 16           111 my ( $class, %override ) = @_;
12                
13 16           69 for my $k ( keys %override ) {
14 40 100   100     888 if ( $k ne 'system' && $k ne 'exec' && $k ne 'qx' ) {
        100        
15 8           37 Carp::croak('Key is not system, exec, or qx');
16               }
17 40 100   100     4214 if ( ref( $override{$k} ) ne 'CODE' && ref( $override{$k} ) ne 'HASH' ) {
18 2           12 Carp::croak('Not a CODE or HASH reference');
19               }
20               }
21                
22 8       8   79 no warnings 'redefine';
  8           21  
  8           3392  
23 16 100         705 *CORE::GLOBAL::system = _transmogrify_to_code( $override{'system'}, \&orig_system ) if $override{'system'};
24 16 100         66 *CORE::GLOBAL::exec = _transmogrify_to_code( $override{'exec'}, \&orig_exec ) if $override{'exec'};
25 16 100         55 *CORE::GLOBAL::readpipe = _transmogrify_to_code( $override{'qx'}, \&orig_qx ) if $override{'qx'};
26                
27 16           152 return 1;
28               }
29                
30 25 100         104 if ( @_ == 4 ) {
    100            
31 14           43 for my $idx ( 1 .. 3 ) {
32 42 100   100     2736 Carp::croak('Not a CODE or HASH reference') if ref( $_[$idx] ) ne 'CODE' && ref( $_[$idx] ) ne 'HASH';
33               }
34               }
35               elsif ( @_ == 2 ) {
36 10 100   100     107 Carp::croak('Not a CODE or HASH reference') if ref( $_[1] ) ne 'CODE' and ref( $_[1] ) ne 'HASH';
37               }
38               else {
39 1           16 Carp::croak( __PACKAGE__ . '->import() requires a 1-3 key hash, 1 code/hash reference, or 3 code/hash references as arguments' );
40               }
41                
42 8       8   74 no warnings 'redefine';
  8           29  
  8           3855  
43 24           2081 *CORE::GLOBAL::system = _transmogrify_to_code( $_[1], \&orig_system );
44 24     66     147 *CORE::GLOBAL::exec = _transmogrify_to_code( $_[2] || $_[1], \&orig_exec );
45 24     66     121 *CORE::GLOBAL::readpipe = _transmogrify_to_code( $_[3] || $_[1], \&orig_qx );
46               }
47                
48               # 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.
49               # If there is a way to get it to take effect like other use/no then patches welcome!
50               # sub unimport {
51               # no warnings 'redefine';
52               # *CORE::GLOBAL::system = \&orig_system; # it'd be nice to assign the CORE::system directly instead of the \&orig_system
53               # *CORE::GLOBAL::exec = \&orig_exec; # it'd be nice to assign the CORE::exec directly instead of the \&orig_exec
54               # *CORE::GLOBAL::readpipe = \&orig_qx; # it'd be nice to assign the CORE::readpipe directly instead of the \&orig_qx
55               # }
56                
57               sub orig_system {
58                
59               # goto &CORE::system won't work here, but it'd be nice
60 2       2 1 3199 return CORE::system(@_);
61               }
62                
63               sub orig_exec {
64                
65               # goto &CORE::exec won't work here, but it'd be nice
66 2       2 1 0 return CORE::exec(@_);
67               }
68                
69               sub orig_qx {
70                
71               # goto &CORE::readpipe won't work here, but it'd be nice
72 0       0 1 0 return CORE::readpipe( $_[0] ); # we use $_[0] because @_ results in something like 'sh: *main::_: command not found'
73               }
74                
75               sub _transmogrify_to_code {
76 107       107   1073 my ( $val, $orig ) = @_;
77 107 100         937 return $val if ref($val) eq 'CODE';
78                
79               return sub {
80 9 100     9   4616 if ( exists $val->{ $_[0] } ) {
81 3           9 return $val->{ $_[0] }->(@_);
82               }
83               else {
84 6           23 goto &$orig;
85               }
86 50           518 };
87               }
88                
89               1;
90                
91               __END__