File Coverage

blib/lib/Test2/Tools/Process.pm
Criterion Covered Total %
statement 252 276 91.3
branch 58 74 78.3
condition 27 38 71.0
subroutine 54 56 96.4
pod 5 5 100.0
total 396 449 88.2


line stmt bran cond sub pod time code
1             package Test2::Tools::Process;
2              
3 8     8   882211 use strict;
  8         36  
  8         201  
4 8     8   38 use warnings;
  8         11  
  8         204  
5 8     8   138 use 5.010;
  8         32  
6 8     8   578 use Test2::Tools::Compare ();
  8         99576  
  8         159  
7 8     8   49 use Test2::API qw( context );
  8         32  
  8         496  
8 8     8   3441 use Ref::Util qw( is_plain_arrayref is_ref is_plain_coderef is_plain_hashref );
  8         11527  
  8         573  
9 8     8   55 use Carp qw( croak carp );
  8         14  
  8         362  
10 8     8   43 use Test2::Compare::Array ();
  8         16  
  8         117  
11 8     8   58 use Test2::Compare::Wildcard ();
  8         26  
  8         117  
12 8     8   37 use Test2::Compare::Number ();
  8         15  
  8         105  
13 8     8   34 use Test2::Compare::String ();
  8         13  
  8         129  
14 8     8   37 use Test2::Compare::Custom ();
  8         16  
  8         100  
15 8     8   155 use Test2::Compare ();
  8         24  
  8         175  
16 8     8   3304 use Return::MultiLevel qw( with_return );
  8         35083  
  8         444  
17 8     8   3588 use Capture::Tiny qw( capture_stdout );
  8         194946  
  8         578  
18 8     8   66 use base qw( Exporter );
  8         26  
  8         1841  
19              
20             our @EXPORT = qw( process proc_event named_signal intercept_exit intercept_exec );
21             our @CARP_NOT = qw( Test2::Tools::Process::SystemProc );
22              
23             # ABSTRACT: Unit tests for code that calls exit, exec, system or qx()
24             our $VERSION = '0.06'; # VERSION
25              
26              
27             our %handlers;
28              
29             BEGIN {
30              
31             %handlers = (
32 0         0 exit => sub (;$) { CORE::exit(@_) },
33 0         0 exec => sub { CORE::exec(@_) },
34 0         0 system => sub { CORE::system(@_) },
35 0         0 readpipe => sub (_) { CORE::readpipe(@_) },
36 8     8   127 );
37              
38 8     8   120 no warnings 'redefine';
  8         20  
  8         1399  
39 8     11   91 *CORE::GLOBAL::exit = sub (;$) { $handlers{exit}->(@_) };
  11         81  
40 8     21   39 *CORE::GLOBAL::exec = sub { $handlers{exec}->(@_) };
  21         512  
41 8     15   21 *CORE::GLOBAL::system = sub { $handlers{system}->(@_) };
  15         2212  
42 8     2   15475 *CORE::GLOBAL::readpipe = sub (_) { $handlers{readpipe}->(@_) };
  2         7  
43             }
44              
45              
46             sub process (&;@)
47             {
48 33     33 1 11884 my $sub = shift;
49 33         53 my @expected = ();
50 33         50 my $test_name = 'process ok';
51 33         44 my @events;
52 33         45 my $i = 0;
53              
54 33 100       100 if(is_plain_arrayref $_[0])
55             {
56 31         44 @expected = @{ shift() };
  31         56  
57             }
58              
59 33 100       99 $test_name = shift if defined $_[0];
60              
61             with_return {
62 33     33   414 my($return) = @_;
63              
64 33         141 local %handlers = %handlers;
65              
66             $handlers{exit} = sub {
67 8         15 my $expected = $expected[$i++];
68              
69 8         11 my $status = shift;
70 8 100       20 $status = 0 unless defined $status;
71 8         11 $status = int($status);
72 8         24 push @events, { event_type => 'exit', exit_status => $status };
73              
74 8 100 33     247 if(defined $expected && $expected->is_exit && defined $expected->callback)
      66        
75             {
76 2         17 my $proc = Test2::Tools::Process::Proc->new($return);
77 2         41 my $ret = $expected->callback->($proc, $status);
78 2 50       17 if(exists $proc->{errno})
79             {
80 0         0 $! = $proc->{errno};
81 0         0 return 0;
82             }
83 2         9 return $ret;
84             }
85             else
86             {
87 6         59 $return->();
88             }
89 33         161 };
90              
91             $handlers{exec} = sub {
92 13         24 my $expected = $expected[$i++];
93              
94 13 100 100     66 if(@_ == 1 || @_ == 0)
95             {
96 8         25 push @events, { event_type => 'exec', command => $_[0] };
97             }
98             else
99             {
100 5         20 push @events, { event_type => 'exec', command => [@_] };
101             }
102              
103 13 100 33     352 if(defined $expected && $expected->is_exec && defined $expected->callback)
      66        
104             {
105 1         15 my $proc = Test2::Tools::Process::Proc->new($return);
106 1         26 my $ret = $expected->callback->($proc, @_);
107 1 50       16 if(exists $proc->{errno})
108             {
109 0         0 $! = $proc->{errno};
110 0         0 return 0;
111             }
112 1         7 return $ret;
113             }
114             else
115             {
116 12         98 $return->();
117             }
118 33         113 };
119              
120 33         69 foreach my $type (qw( system readpipe ))
121             {
122             $handlers{$type} = sub {
123 17         29 my $expected = $expected[$i++];
124              
125 17         20 my $event;
126 17         25 my $args = \@_;
127 17 100 100     56 if(@_ == 1 || @_ == 0)
128             {
129 11         35 push @events, $event = { event_type => 'system', command => $_[0] };
130             }
131             else
132             {
133 6         24 push @events, $event = { event_type => 'system', command => [@_] };
134             }
135              
136 17 50 33     426 if(defined $expected && $expected->is_system && defined $expected->callback)
      33        
137             {
138             my $inner = sub {
139 17         23 my($return) = @_;
140 17         56 my $proc = Test2::Tools::Process::SystemProc->new($return, $event, $type);
141 17         271 $expected->callback->($proc, @$args);
142 9         48 $event->{status} = 0;
143 9         31 $? = 0;
144 17         138 };
145 17 100       39 if($type eq 'system')
146             {
147 15         56 with_return { $inner->(@_) };
  15         181  
148 15 100       129 return -1 if exists $event->{errno};
149 14         195 return $?;
150             }
151             else
152             {
153 2         45 return scalar capture_stdout { with_return { $inner->(@_) } };
  2         1805  
  2         26  
154             }
155             }
156             else
157             {
158             local $SIG{__WARN__} = sub {
159 0         0 my($message) = @_;
160 0         0 $message =~ s/ at .*? line [0-9]+\.$//;
161 0         0 chomp $message;
162 0         0 carp($message);
163 0         0 };
164 0 0       0 my $ret = $type eq 'system' ? CORE::system(@_) : CORE::readpipe(@_);
165 0 0       0 if($? == -1)
    0          
166             {
167 0         0 $event->{errno} = $!;
168             }
169             elsif($? & 127)
170             {
171 0         0 $event->{signal} = $? & 127;
172             }
173             else
174             {
175 0         0 $event->{status} = $? >> 8;
176             }
177 0         0 return $ret;
178             }
179 66         283 };
180             }
181              
182 33         78 $sub->();
183 33         211 };
184              
185             @_ = (
186             \@events,
187 33         3370 [ map { $_->to_check } @expected ],
  41         146  
188             $test_name
189             );
190              
191 33         489 goto \&Test2::Tools::Compare::is;
192             }
193              
194              
195             {
196             my $sig;
197             sub named_signal ($)
198             {
199 71     71 1 28687 my($name) = @_;
200              
201             # build hash on demand.
202 71   66     140 $sig ||= do {
203 1         7 require Config;
204 1         2 my %sig;
205 1         98 my @num = split /\s+/, $Config::Config{sig_num};
206 1         41 foreach my $name (split /\s+/, $Config::Config{sig_name})
207             {
208 69         110 $sig{$name} = shift @num;
209             }
210 1         8 \%sig;
211             };
212              
213 71 100       335 croak "no such signal: $name" unless exists $sig->{$name};
214              
215 70         152 $sig->{$name};
216             }
217             }
218              
219              
220             sub intercept_exit (&)
221             {
222 4     4 1 9597 my $sub = shift;
223              
224 4         6 my $ret;
225              
226             with_return {
227 4     4   55 my $return = shift;
228             local $handlers{exit} = sub {
229 3         6 $ret = shift;
230 3 100       8 $ret = 0 unless defined $ret;
231 3         5 $ret = int $ret;
232 3         8 $return->();
233 4         17 };
234 4         11 $sub->();
235 4         25 };
236              
237 4         368 $ret;
238             }
239              
240              
241             sub intercept_exec (&)
242             {
243 3     3 1 398 my $sub = shift;
244              
245 3         4 my $ret;
246              
247             with_return {
248 3     3   32 my $return = shift;
249             local $handlers{exec} = sub {
250 2         4 $ret = \@_;
251 2         7 $return->();
252 3         10 };
253 3         8 $sub->();
254 3         17 };
255              
256 3         320 $ret;
257             }
258              
259              
260             sub proc_event ($;$$$)
261             {
262 41     41 1 182040 my $type = shift;
263 41 50       104 croak("no such process event undef") unless defined $type;
264              
265 41         92 my $check;
266             my $check2;
267 41         0 my $callback;
268              
269 41 100 100     228 $check = shift if defined $_[0] && !is_plain_coderef $_[0] && !is_plain_hashref $_[0];
      100        
270 41 100 100     116 $check2 = shift if defined $_[0] && is_plain_hashref $_[0];
271              
272 41 100       77 if(defined $_[0])
273             {
274 21 50       48 if(is_plain_coderef $_[0])
275             {
276 21         35 $callback = shift;
277             }
278             else
279             {
280 0         0 croak("callback is not a code reference");
281             }
282             }
283              
284 41         117 my @caller = caller;
285              
286 41 100       193 if($type eq 'exit')
    50          
287             {
288 9 100       47 if(defined $check)
289             {
290 6 100       18 unless(is_ref $check)
291             {
292 4         24 $check = Test2::Compare::Number->new(
293             file => $caller[1],
294             lines => [$caller[2]],
295             input => $check,
296             );
297             }
298             }
299             else
300             {
301             $check = Test2::Compare::Custom->new(
302 2 50   2   1620 code => sub { defined $_ ? 1 : 0 },
303 3         37 name => 'DEFINED',
304             operator => 'DEFINED()',
305             file => $caller[1],
306             lines => [$caller[2]],
307             );
308             }
309              
310 9         365 return Test2::Tools::Process::Exit->new(status_check => $check, callback => $callback);
311             }
312              
313             elsif($type =~ /^(exec|system)$/)
314             {
315 32 100       76 if(defined $check)
316             {
317 22 100       56 if(is_plain_arrayref $check)
    100          
318             {
319 5         23 my $array = Test2::Compare::Array->new(
320             called => \@caller,
321             );
322 5         159 foreach my $item (@$check)
323             {
324 11         143 my $wc = Test2::Compare::Wildcard->new(
325             expect => $item,
326             file => $caller[1],
327             lines => [$caller[2]],
328             );
329 11         218 $array->add_item($wc);
330             }
331 5         105 $check = $array;
332             }
333             elsif(!is_ref $check)
334             {
335 4         17 $check = Test2::Compare::String->new(
336             file => $caller[1],
337             lines => [$caller[2]],
338             input => $check,
339             );
340             }
341             }
342             else
343             {
344             $check = Test2::Compare::Custom->new(
345 8 50   8   4403 code => sub { defined $_ ? 1 : 0 },
346 10         48 name => 'DEFINED',
347             operator => 'DEFINED()',
348             file => $caller[1],
349             lines => [$caller[2]],
350             );
351             }
352              
353 32 100       353 if($type eq 'system')
354             {
355 18   100     49 $check2 ||= { status => 0 };
356             }
357              
358 32 100       65 my $class = $type eq 'exec'
359             ? 'Test2::Tools::Process::Exec'
360             : 'Test2::Tools::Process::System';
361 32         147 return $class->new( command_check => $check, result_check => $check2, callback => $callback);
362             }
363              
364 0         0 croak("no such process event $type");
365             }
366              
367             package Test2::Tools::Process::Event;
368              
369 8     8   69 use constant is_exit => 0;
  8         16  
  8         657  
370 8     8   52 use constant is_exec => 0;
  8         15  
  8         451  
371 8     8   46 use constant is_system => 0;
  8         72  
  8         525  
372 8     8   4366 use Class::Tiny qw( callback );
  8         14093  
  8         32  
373              
374             package Test2::Tools::Process::Exit;
375              
376 8     8   1730 use constant is_exit => 1;
  8         16  
  8         719  
377 8     8   156 use base qw( Test2::Tools::Process::Event );
  8         14  
  8         2794  
378 8     8   56 use Class::Tiny qw( status_check );
  8         15  
  8         28  
379              
380             sub to_check
381             {
382 9     9   16 my($self) = @_;
383 9         156 { event_type => 'exit', exit_status => $self->status_check };
384             }
385              
386             package Test2::Tools::Process::Exec;
387              
388 8     8   1876 use constant is_exec => 1;
  8         35  
  8         498  
389 8     8   55 use base qw( Test2::Tools::Process::Event );
  8         13  
  8         1966  
390 8     8   51 use Class::Tiny qw( command_check );
  8         16  
  8         30  
391              
392             sub to_check
393             {
394 14     14   45 my($self) = @_;
395 14         238 { event_type => 'exec', command => $self->command_check };
396             }
397              
398             package Test2::Tools::Process::System;
399              
400 8     8   1885 use constant is_system => 1;
  8         16  
  8         615  
401 8     8   49 use base qw( Test2::Tools::Process::Event );
  8         15  
  8         1928  
402 8     8   52 use Class::Tiny qw( command_check result_check );
  8         12  
  8         36  
403              
404             sub to_check
405             {
406 18     18   28 my($self) = @_;
407 18         309 { event_type => 'system', command => $self->command_check, %{ $self->result_check } };
  18         271  
408             }
409              
410             package Test2::Tools::Process::Proc;
411              
412             sub new
413             {
414 3     3   7 my($class, $return) = @_;
415 3         9 bless {
416             return => $return,
417             }, $class;
418             }
419              
420 0     0   0 sub terminate { shift->{return}->() }
421              
422             sub errno
423             {
424 0     0   0 my($self, $errno) = @_;
425 0         0 $self->{errno} = $errno;
426             }
427              
428             package Test2::Tools::Process::SystemProc;
429              
430             sub new
431             {
432 17     17   37 my($class, $return, $result, $type) = @_;
433 17         57 bless {
434             return => $return,
435             result => $result,
436             type => $type,
437             }, $class;
438             }
439              
440 2     2   792 sub type { shift->{type} }
441              
442             sub exit
443             {
444 5     5   6959 my($self, $status) = @_;
445 5 100       16 $status = 0 unless defined $status;
446 5         12 $status = int $status;
447 5         14 $self->{result}->{status} = $status;
448 5         13 $? = $status << 8;
449 5         14 $self->{return}->();
450             }
451              
452             sub signal
453             {
454 3     3   549 my($self, $signal) = @_;
455 3 50       7 $signal = 0 unless defined $signal;
456 3 100       11 if($signal =~ /^[A-Z]/i)
457             {
458 2         7 $signal = Test2::Tools::Process::named_signal($signal);
459             }
460             else
461             {
462 1         2 $signal = int $signal;
463             }
464 2         5 $self->{result}->{signal} = $signal;
465 2         4 $? = $signal;
466 2         5 $self->{return}->();
467             }
468              
469             sub errno
470             {
471 1     1   10 my($self, $errno) = @_;
472 1 50       13 $errno = 0 unless defined $errno;
473 1         2 $errno = int $errno;
474 1         9 $self->{result}->{errno} = $! = $errno;
475 1         4 $self->{return}->();
476             }
477              
478             1;
479              
480             __END__