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__ |