File Coverage

blib/lib/Test/MockCommand.pm
Criterion Covered Total %
statement 175 178 98.3
branch 75 100 75.0
condition 18 28 64.2
subroutine 33 33 100.0
pod 12 12 100.0
total 313 351 89.1


line stmt bran cond sub pod time code
1             package Test::MockCommand;
2 18     18   1066909 use warnings;
  18         191  
  18         499  
3 18     18   78 use strict;
  18         30  
  18         388  
4              
5 18     18   79 use Carp qw(carp croak);
  18         27  
  18         881  
6 18     18   8989 use Data::Dumper;
  18         99045  
  18         1017  
7 18     18   6503 use Symbol;
  18         11011  
  18         972  
8              
9             # Not all systems implement the WIFEXITED/WEXITSTATUS macros
10 18     18   7158 use POSIX qw(WIFEXITED WEXITSTATUS);
  18         94060  
  18         97  
11             eval { WIFEXITED(0); };
12             if ($@ =~ /not (?:defined|a valid|implemented)/) {
13 18     18   22550 no warnings 'redefine';
  18         38  
  18         1588  
14             *WIFEXITED = sub { not $_[0] & 0xff };
15             *WEXITSTATUS = sub { $_[0] >> 8 };
16             }
17              
18 18     18   20941 use Test::MockCommand::Recorder;
  18         46  
  18         468  
19 18     18   95 use Test::MockCommand::Result;
  18         33  
  18         316  
20 18     18   79 use Test::MockCommand::ScalarReadline qw(scalar_readline);
  18         30  
  18         16582  
21              
22             our $VERSION = '0.05';
23             our $CLASS = __PACKAGE__;
24             our $OPEN_HANDLER = undef; # this gets set to _default_open_handler
25             our $RECORDING = 0; # are we recording commands or playing them back?
26             our $RECORDING_TO = undef; # where to save results when the program ends
27             our %COMMANDS; # results db: $COMMANDS{$cmd} = [ $result, ... ]
28             our @RECORDERS = ( Test::MockCommand::Recorder->new() );
29              
30             #carp "WARNING: need perl v5.9.5 or better to mock qx// and backticks"
31             # if $] < 5.009005;
32              
33             $CLASS->open_handler(undef); # set up _default_open_handler
34             $CLASS->_hook_core_functions();
35              
36             sub import {
37 18 100 100 18   358 if (@_ >= 3 && $_[1] eq 'record') {
    100 66        
38 3         12 $CLASS->auto_save($_[2]);
39 3         6 $CLASS->recording(1);
40             }
41             elsif (@_ >= 3 && $_[1] eq 'playback') {
42 1         3 $CLASS->load($_[2]);
43             }
44             }
45              
46 18     18   16019 END { $CLASS->_do_autosave(); }
47              
48             sub _do_autosave {
49 19     19   95 my $class = shift;
50 19 100       440 $class->save($RECORDING_TO) if defined $RECORDING_TO;
51              
52             }
53              
54             # hook into core functions that can execute external commands
55             sub _hook_core_functions {
56 18     18   28 my $class = shift;
57              
58             *CORE::GLOBAL::system = sub {
59 14     14   1598 my $cmd = join(' ', @_);
60 14         123 return $class->_handle('system', $cmd, \@_, [caller()]);
61 18         83 };
62              
63             *CORE::GLOBAL::exec = sub {
64 1     1   7 my $cmd = join(' ', @_);
65 1         12 return $class->_handle('exec', $cmd, \@_, [caller()]);
66 18         52 };
67              
68             *CORE::GLOBAL::readpipe = sub {
69 38     38   5309 my $cmd = $_[-1];
70 38         514 return $class->_handle('readpipe', $cmd, \@_, [caller()]);
71 18         47 };
72              
73             *CORE::GLOBAL::open = sub (*;$@) {
74 68 50   68   30650 croak "Not enough arguments for open()" unless @_ > 0;
75             # handle open()s that invoke a command
76 68 100       230 if (@_ < 3) {
77             # 1/2-arg open()
78 58         228 my $file = $_[-1];
79 58 50       432 croak "Can't open bidirectional pipe" if $file =~/^\s*\|(.+)\|\s*$/;
80 58 50       177 return $class->_handle('open', $1, \@_, [caller()])
81             if $file =~ /^\s*\|\s*(.+?)\s*$/;
82 58 100       810 return $class->_handle('open', $1, \@_, [caller()])
83             if $file =~ /^\s*(.+?)\s*\|\s*$/;
84             }
85             else {
86             # 3-arg open()
87 10 50       25 return $class->_handle('open', join(' ', splice(@_, 2)), \@_,
88             [caller()])
89             if $_[1] =~ /^\s*-\|/;
90 10 50       22 return $class->_handle('open', join(' ', splice(@_, 2)), \@_,
91             [caller()])
92             if $_[1] =~ /^\s*\|-/;
93             }
94              
95             # pass through the rest
96 39         208 return $OPEN_HANDLER->(\@_, caller());
97 18         83 };
98             }
99              
100             sub _handle {
101 82     82   610 my ($class, $func, $cmd, $args, $caller) = @_;
102              
103 82         486 my %args = (
104             command => $cmd,
105             function => $func,
106             arguments => $args,
107             caller => $caller,
108             );
109              
110 82         163 my $result = undef;
111 82         180 my $return = undef;
112              
113 82 100       253 if ($RECORDING) {
114             # recording mode: find a capable recorder
115 52         164 for my $recorder (@RECORDERS) {
116 53         652 $result = $recorder->handle(%args);
117 53 100       857 last if defined $result;
118             }
119              
120 52 50       211 if ($result) {
121             # save result in database
122 52   100     929 $COMMANDS{"$func:$cmd"} ||= [];
123 52         135 push @{$COMMANDS{"$func:$cmd"}}, $result;
  52         1313  
124 52         223 $return = $result->return_value();
125             }
126             }
127             else {
128             # not in recording mode; look up results database instead.
129 30         188 my @possible = $class->find(%args);
130 30 100       218 if (@possible) {
131 29         146 $result = $possible[0];
132 29         457 $return = $result->handle(%args, all_results => \@possible);
133             }
134             }
135              
136             # warn and pass through if no matching commands
137 82 100       329 if (! defined $result) {
138 1         336 carp "can't mock $func() command \"$cmd\", passing through";
139 1 50       7 return $OPEN_HANDLER->($args, $caller->[0]) if $func eq 'open';
140 1 50       4 return CORE::readpipe(@{$args}) if $func eq 'readpipe';
  0         0  
141 1 50       15 return CORE::system(@{$args}) if $func eq 'system';
  1         4039  
142 0 0       0 return CORE::exec(@{$args}) if $func eq 'exec';
  0         0  
143             }
144              
145             # if exec() was called, save the db and exit
146 81 100       310 if ($func eq 'exec') {
147 1         8 $class->_do_autosave();
148 1         8 my $code = $result->exit_code();
149 1 50       956 exit(WIFEXITED($code) ? WEXITSTATUS($code) : $code);
150             }
151              
152             # readpipe() emulation should always return a scalar, so
153             # emulation of $/ behaviour is used in list context
154 80 100 100     1058 return scalar_readline($return) if $func eq 'readpipe' && wantarray();
155              
156             # return with the function's result
157 53         1458 return $return;
158             }
159              
160             # this is the default $OPEN_HANDLER, use for any non-command-executing
161             # open(), also for command-executing open()s when there's no matching
162             # recorder or result
163             sub _default_open_handler {
164 28     28   76 my ($args, $pkg) = @_;
165              
166             # we might need to use a bareword symbol reference in the open() call
167 18     18   124 no strict 'refs';
  18         47  
  18         19103  
168              
169             # if defined, open()'s file handle is a bareword symbol reference which
170             # should be qualified as being in the calling package's namespace.
171 28 100       108 my $ref = defined($args->[0]) ? Symbol::qualify($args->[0], $pkg) : undef;
172              
173             # open() is finicky about its arguments, it doesn't like just @{$args}.
174             # If the file handle is undefined, we refer directly to it so that open()
175             # can use the pass-by-reference to assign a new value into it.
176 28 50 0     203 return CORE::open($ref || $args->[0]) if @{$args} == 1;
  28         96  
177 28 100 66     51 return CORE::open($ref || $args->[0], $args->[1]) if @{$args} == 2;
  28         1235  
178 7   66     37 return CORE::open($ref || $args->[0], $args->[1], splice(@{$args}, 2));
  7         273  
179             }
180              
181             sub clear {
182 8     8 1 2095 %COMMANDS = ();
183             }
184              
185             sub load {
186 6     6 1 1137 my $class = shift;
187 6         14 my $file = shift;
188 6 100       179 croak "no file specified" unless defined $file;
189              
190 5         27 $class->clear();
191 5         23 $class->merge($file);
192             }
193              
194             sub merge {
195 10     10 1 756 my $class = shift;
196 10         22 my $file = shift;
197 10 100       90 croak "no file specified" unless defined $file;
198 9 100       265 croak "$file is a directory" if -d $file;
199              
200             # read and evaluate file, which should set up $VAR1
201 7         1075 my $VAR1 = undef;
202 7         31 local $/; # enable slurp mode
203 7 100       355 open(my $fh, '<', $file) or croak "can't open $file: $!";
204 5         588 eval <$fh>;
205 5         58 close $fh;
206 5 50       19 croak "failure loading $file: $@" if $@;
207 5 50       568 croak "failure loading $file: \$VAR1 not defined" unless defined $VAR1;
208              
209             # merge $VAR1 into %COMMANDS
210 5         12 for my $cmd (keys %{$VAR1}) {
  5         26  
211 8   100     41 $COMMANDS{$cmd} ||= [];
212 8         39 push @{$COMMANDS{$cmd}}, @{$VAR1->{$cmd}};
  8         14  
  8         50  
213             }
214             }
215              
216             sub save {
217 7     7 1 62 my $class = shift;
218 7         32 my $file = shift;
219              
220             # use auto-save file if no file specified
221 7 50       44 $file = $RECORDING_TO unless defined $file;
222 7 50       43 croak "no file specified and auto-save not enabled" unless defined $file;
223              
224 7 50       635 open FH, ">$file" or croak "can't save to $file: $!";
225 7 50       115 print FH Dumper(\%COMMANDS) or croak "can't write results to $file: $!";
226 7 50       3818 close FH or croak "can't close $file: $!";
227             }
228              
229             sub add_recorder {
230 2     2 1 22 my $class = shift;
231 2   33     10 my $recorder = shift || croak 'no recorder provided';
232 2 50       7 croak "recorder has no handle() method"
233             unless UNIVERSAL::can($recorder, 'handle');
234 2         5 unshift @RECORDERS, $recorder;
235             }
236              
237             sub remove_recorder {
238 1     1 1 629 my $class = shift;
239 1   33     4 my $recorder = shift || croak 'no recorder provided';
240 1         2 @RECORDERS = grep { $_ != $recorder } @RECORDERS;
  3         12  
241             }
242              
243             sub recorders {
244 2     2 1 10 return @RECORDERS;
245             }
246              
247             sub find {
248 68     68 1 278 my $class = shift;
249 68 50       308 croak "odd number of parameters" if @_ % 2;
250 68         323 my %args = @_;
251              
252 68         125 my @keys;
253 68 100       253 if (exists $args{command}) {
254 54 100       231 if (ref $args{command} eq 'Regexp') {
255             my $re = exists $args{function}
256 11 100       120 ? qr/^\Q$args{function}\E:(.+)/
257             : qr/^(?:exec|open|readpipe|system):(.+)/;
258 11 100       45 @keys = grep { $_ =~ $re && $1 =~ $args{command} } keys %COMMANDS;
  33         446  
259             }
260             else {
261 55         277 @keys = grep {exists $COMMANDS{$_}} map {"$_:$args{command}"}
  55         233  
262             (exists $args{function}
263             ? ($args{function})
264 43 100       200 : qw(exec open readpipe system));
265             }
266             }
267             else {
268 14         56 @keys = keys %COMMANDS;
269 14 100       43 @keys = grep {/^\Q$args{function}\E:/} @keys if exists $args{function};
  12         128  
270             }
271              
272             # we can't just return sort{} grep{}... as the expression gives
273             # undef when the caller wants a scalar context... why?
274 68         135 my %score;
275 586         1947 my @results = sort { $score{$b} <=> $score{$a} }
276 340         3435 grep { $score{$_} = $_->matches(%args) }
277 68         161 map { @{$COMMANDS{$_}} }
  79         109  
  79         275  
278             @keys;
279 68         2389 return @results;
280             }
281              
282             sub all_commands {
283 11     11 1 3422 return map { @{$_} } values %COMMANDS;
  20         45  
  20         98  
284             }
285              
286             sub recording {
287 30     30 1 8744 my $class = shift;
288 30 100       136 if (@_ >= 1) {
289 25 50       81 croak 'value to recording() not valid' unless defined $_[0];
290 25         48 $RECORDING = shift;
291             }
292 30         106 return $RECORDING;
293             }
294              
295             sub auto_save {
296 15     15 1 806 my $class = shift;
297 15 100       55 $RECORDING_TO = shift if @_ >= 1;
298 15         304 return $RECORDING_TO;
299             }
300              
301             sub open_handler {
302 22     22 1 1168 my $class = shift;
303 22 50       69 croak 'wrong number of parameters' unless @_ == 1;
304 22 100       65 if (defined $_[0]) {
305 3 50       10 croak 'parameter must be coderef' unless ref $_[0] eq 'CODE';
306 3         9 $OPEN_HANDLER = $_[0];
307             }
308             else {
309 19         44 $OPEN_HANDLER = \&_default_open_handler;
310             }
311             }
312              
313             1;
314              
315             __END__