line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
#line 1 |
2
|
|
|
|
|
|
|
package Test::Builder; |
3
|
1
|
|
|
1
|
|
11
|
|
|
1
|
|
|
|
|
2
|
|
4
|
1
|
|
|
1
|
|
3
|
use 5.006; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
13
|
|
5
|
1
|
|
|
1
|
|
3
|
use strict; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
52
|
|
6
|
|
|
|
|
|
|
use warnings; |
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
our $VERSION = '1.001014'; |
9
|
|
|
|
|
|
|
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) |
10
|
|
|
|
|
|
|
|
11
|
1
|
50
|
|
1
|
|
20
|
BEGIN { |
12
|
0
|
|
|
|
|
0
|
if( $] < 5.008 ) { |
13
|
|
|
|
|
|
|
require Test::Builder::IO::Scalar; |
14
|
|
|
|
|
|
|
} |
15
|
|
|
|
|
|
|
} |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
# Make Test::Builder thread-safe for ithreads. |
19
|
1
|
|
|
1
|
|
3
|
BEGIN { |
|
1
|
|
|
|
|
0
|
|
|
1
|
|
|
|
|
234
|
|
20
|
|
|
|
|
|
|
use Config; |
21
|
|
|
|
|
|
|
# Load threads::shared when threads are turned on. |
22
|
1
|
50
|
33
|
1
|
|
21
|
# 5.8.0's threads are so busted we no longer support them. |
|
|
|
33
|
|
|
|
|
23
|
0
|
|
|
|
|
0
|
if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) { |
24
|
|
|
|
|
|
|
require threads::shared; |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
# Hack around YET ANOTHER threads::shared bug. It would |
27
|
|
|
|
|
|
|
# occasionally forget the contents of the variable when sharing it. |
28
|
|
|
|
|
|
|
# So we first copy the data, then share, then put our copy back. |
29
|
0
|
|
|
|
|
0
|
*share = sub (\[$@%]) { |
30
|
0
|
|
|
|
|
0
|
my $type = ref $_[0]; |
31
|
|
|
|
|
|
|
my $data; |
32
|
0
|
0
|
|
|
|
0
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
33
|
0
|
|
|
|
|
0
|
if( $type eq 'HASH' ) { |
|
0
|
|
|
|
|
0
|
|
34
|
|
|
|
|
|
|
%$data = %{ $_[0] }; |
35
|
|
|
|
|
|
|
} |
36
|
0
|
|
|
|
|
0
|
elsif( $type eq 'ARRAY' ) { |
|
0
|
|
|
|
|
0
|
|
37
|
|
|
|
|
|
|
@$data = @{ $_[0] }; |
38
|
|
|
|
|
|
|
} |
39
|
0
|
|
|
|
|
0
|
elsif( $type eq 'SCALAR' ) { |
|
0
|
|
|
|
|
0
|
|
40
|
|
|
|
|
|
|
$$data = ${ $_[0] }; |
41
|
|
|
|
|
|
|
} |
42
|
0
|
|
|
|
|
0
|
else { |
43
|
|
|
|
|
|
|
die( "Unknown type: " . $type ); |
44
|
|
|
|
|
|
|
} |
45
|
0
|
|
|
|
|
0
|
|
46
|
|
|
|
|
|
|
$_[0] = &threads::shared::share( $_[0] ); |
47
|
0
|
0
|
|
|
|
0
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
48
|
0
|
|
|
|
|
0
|
if( $type eq 'HASH' ) { |
|
0
|
|
|
|
|
0
|
|
49
|
|
|
|
|
|
|
%{ $_[0] } = %$data; |
50
|
|
|
|
|
|
|
} |
51
|
0
|
|
|
|
|
0
|
elsif( $type eq 'ARRAY' ) { |
|
0
|
|
|
|
|
0
|
|
52
|
|
|
|
|
|
|
@{ $_[0] } = @$data; |
53
|
|
|
|
|
|
|
} |
54
|
0
|
|
|
|
|
0
|
elsif( $type eq 'SCALAR' ) { |
|
0
|
|
|
|
|
0
|
|
55
|
|
|
|
|
|
|
${ $_[0] } = $$data; |
56
|
|
|
|
|
|
|
} |
57
|
0
|
|
|
|
|
0
|
else { |
58
|
|
|
|
|
|
|
die( "Unknown type: " . $type ); |
59
|
|
|
|
|
|
|
} |
60
|
0
|
|
|
|
|
0
|
|
61
|
0
|
|
|
|
|
0
|
return $_[0]; |
62
|
|
|
|
|
|
|
}; |
63
|
|
|
|
|
|
|
} |
64
|
|
|
|
|
|
|
# 5.8.0's threads::shared is busted when threads are off |
65
|
|
|
|
|
|
|
# and earlier Perls just don't have that module at all. |
66
|
1
|
|
|
2
|
|
3
|
else { |
|
2
|
|
|
|
|
2
|
|
67
|
1
|
|
|
1
|
|
2136
|
*share = sub { return $_[0] }; |
|
1
|
|
|
|
|
1
|
|
68
|
|
|
|
|
|
|
*lock = sub { 0 }; |
69
|
|
|
|
|
|
|
} |
70
|
|
|
|
|
|
|
} |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
#line 117 |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
our $Test = Test::Builder->new; |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
sub new { |
77
|
|
|
|
|
|
|
my($class) = shift; |
78
|
|
|
|
|
|
|
$Test ||= $class->create; |
79
|
|
|
|
|
|
|
return $Test; |
80
|
|
|
|
|
|
|
} |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
#line 139 |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
sub create { |
85
|
|
|
|
|
|
|
my $class = shift; |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
my $self = bless {}, $class; |
88
|
|
|
|
|
|
|
$self->reset; |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
return $self; |
91
|
|
|
|
|
|
|
} |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
# Copy an object, currently a shallow. |
95
|
|
|
|
|
|
|
# This does *not* bless the destination. This keeps the destructor from |
96
|
|
|
|
|
|
|
# firing when we're just storing a copy of the object to restore later. |
97
|
|
|
|
|
|
|
sub _copy { |
98
|
|
|
|
|
|
|
my($src, $dest) = @_; |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
%$dest = %$src; |
101
|
|
|
|
|
|
|
_share_keys($dest); |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
return; |
104
|
|
|
|
|
|
|
} |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
#line 182 |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
sub child { |
110
|
|
|
|
|
|
|
my( $self, $name ) = @_; |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
if( $self->{Child_Name} ) { |
113
|
|
|
|
|
|
|
$self->croak("You already have a child named ($self->{Child_Name}) running"); |
114
|
|
|
|
|
|
|
} |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
my $parent_in_todo = $self->in_todo; |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
# Clear $TODO for the child. |
119
|
|
|
|
|
|
|
my $orig_TODO = $self->find_TODO(undef, 1, undef); |
120
|
|
|
|
|
|
|
|
121
|
3
|
|
|
3
|
1
|
4
|
my $class = ref $self; |
122
|
3
|
|
66
|
|
|
13
|
my $child = $class->create; |
123
|
3
|
|
|
|
|
6
|
|
124
|
|
|
|
|
|
|
# Add to our indentation |
125
|
|
|
|
|
|
|
$child->_indent( $self->_indent . ' ' ); |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
# Make the child use the same outputs as the parent |
128
|
|
|
|
|
|
|
for my $method (qw(output failure_output todo_output)) { |
129
|
|
|
|
|
|
|
$child->$method( $self->$method ); |
130
|
|
|
|
|
|
|
} |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
# Ensure the child understands if they're inside a TODO |
133
|
|
|
|
|
|
|
if( $parent_in_todo ) { |
134
|
|
|
|
|
|
|
$child->failure_output( $self->todo_output ); |
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
# This will be reset in finalize. We do this here lest one child failure |
138
|
|
|
|
|
|
|
# cause all children to fail. |
139
|
|
|
|
|
|
|
$child->{Child_Error} = $?; |
140
|
|
|
|
|
|
|
$? = 0; |
141
|
1
|
|
|
1
|
1
|
1
|
$child->{Parent} = $self; |
142
|
|
|
|
|
|
|
$child->{Parent_TODO} = $orig_TODO; |
143
|
1
|
|
|
|
|
2
|
$child->{Name} = $name || "Child of " . $self->name; |
144
|
1
|
|
|
|
|
2
|
$self->{Child_Name} = $child->name; |
145
|
|
|
|
|
|
|
return $child; |
146
|
1
|
|
|
|
|
2
|
} |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
#line 233 |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
sub subtest { |
152
|
|
|
|
|
|
|
my $self = shift; |
153
|
|
|
|
|
|
|
my($name, $subtests, @args) = @_; |
154
|
0
|
|
|
0
|
|
0
|
|
155
|
|
|
|
|
|
|
if ('CODE' ne ref $subtests) { |
156
|
0
|
|
|
|
|
0
|
$self->croak("subtest()'s second argument must be a code ref"); |
157
|
0
|
|
|
|
|
0
|
} |
158
|
|
|
|
|
|
|
|
159
|
0
|
|
|
|
|
0
|
# Turn the child into the parent so anyone who has stored a copy of |
160
|
|
|
|
|
|
|
# the Test::Builder singleton will get the child. |
161
|
|
|
|
|
|
|
my $error; |
162
|
|
|
|
|
|
|
my $child; |
163
|
|
|
|
|
|
|
my $parent = {}; |
164
|
|
|
|
|
|
|
{ |
165
|
|
|
|
|
|
|
# child() calls reset() which sets $Level to 1, so we localize |
166
|
|
|
|
|
|
|
# $Level first to limit the scope of the reset to the subtest. |
167
|
|
|
|
|
|
|
local $Test::Builder::Level = $Test::Builder::Level + 1; |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
# Store the guts of $self as $parent and turn $child into $self. |
170
|
|
|
|
|
|
|
$child = $self->child($name); |
171
|
|
|
|
|
|
|
_copy($self, $parent); |
172
|
|
|
|
|
|
|
_copy($child, $self); |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
my $run_the_subtests = sub { |
175
|
|
|
|
|
|
|
# Add subtest name for clarification of starting point |
176
|
|
|
|
|
|
|
$self->note("Subtest: $name"); |
177
|
|
|
|
|
|
|
$subtests->(@args); |
178
|
|
|
|
|
|
|
$self->done_testing unless $self->_plan_handled; |
179
|
|
|
|
|
|
|
1; |
180
|
|
|
|
|
|
|
}; |
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
if( !eval { $run_the_subtests->() } ) { |
183
|
|
|
|
|
|
|
$error = $@; |
184
|
0
|
|
|
0
|
1
|
0
|
} |
185
|
|
|
|
|
|
|
} |
186
|
0
|
0
|
|
|
|
0
|
|
187
|
0
|
|
|
|
|
0
|
# Restore the parent and the copied child. |
188
|
|
|
|
|
|
|
_copy($self, $child); |
189
|
|
|
|
|
|
|
_copy($parent, $self); |
190
|
0
|
|
|
|
|
0
|
|
191
|
|
|
|
|
|
|
# Restore the parent's $TODO |
192
|
|
|
|
|
|
|
$self->find_TODO(undef, 1, $child->{Parent_TODO}); |
193
|
0
|
|
|
|
|
0
|
|
194
|
|
|
|
|
|
|
# Die *after* we restore the parent. |
195
|
0
|
|
|
|
|
0
|
die $error if $error and !eval { $error->isa('Test::Builder::Exception') }; |
196
|
0
|
|
|
|
|
0
|
|
197
|
|
|
|
|
|
|
local $Test::Builder::Level = $Test::Builder::Level + 1; |
198
|
|
|
|
|
|
|
my $finalize = $child->finalize; |
199
|
0
|
|
|
|
|
0
|
|
200
|
|
|
|
|
|
|
$self->BAIL_OUT($child->{Bailed_Out_Reason}) if $child->{Bailed_Out}; |
201
|
|
|
|
|
|
|
|
202
|
0
|
|
|
|
|
0
|
return $finalize; |
203
|
0
|
|
|
|
|
0
|
} |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
#line 312 |
206
|
|
|
|
|
|
|
|
207
|
0
|
0
|
|
|
|
0
|
sub _plan_handled { |
208
|
0
|
|
|
|
|
0
|
my $self = shift; |
209
|
|
|
|
|
|
|
return $self->{Have_Plan} || $self->{No_Plan} || $self->{Skip_All}; |
210
|
|
|
|
|
|
|
} |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
|
213
|
0
|
|
|
|
|
0
|
#line 337 |
214
|
0
|
|
|
|
|
0
|
|
215
|
0
|
|
|
|
|
0
|
sub finalize { |
216
|
0
|
|
|
|
|
0
|
my $self = shift; |
217
|
0
|
|
0
|
|
|
0
|
|
218
|
0
|
|
|
|
|
0
|
return unless $self->parent; |
219
|
0
|
|
|
|
|
0
|
if( $self->{Child_Name} ) { |
220
|
|
|
|
|
|
|
$self->croak("Can't call finalize() with child ($self->{Child_Name}) active"); |
221
|
|
|
|
|
|
|
} |
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
local $? = 0; # don't fail if $subtests happened to set $? nonzero |
224
|
|
|
|
|
|
|
$self->_ending; |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
# XXX This will only be necessary for TAP envelopes (we think) |
227
|
|
|
|
|
|
|
#$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" ); |
228
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
local $Test::Builder::Level = $Test::Builder::Level + 1; |
230
|
|
|
|
|
|
|
my $ok = 1; |
231
|
|
|
|
|
|
|
$self->parent->{Child_Name} = undef; |
232
|
|
|
|
|
|
|
unless ($self->{Bailed_Out}) { |
233
|
|
|
|
|
|
|
if ( $self->{Skip_All} ) { |
234
|
|
|
|
|
|
|
$self->parent->skip($self->{Skip_All}, $self->name); |
235
|
0
|
|
|
0
|
1
|
0
|
} |
236
|
0
|
|
|
|
|
0
|
elsif ( not @{ $self->{Test_Results} } ) { |
237
|
|
|
|
|
|
|
$self->parent->ok( 0, sprintf q[No tests run for subtest "%s"], $self->name ); |
238
|
0
|
0
|
|
|
|
0
|
} |
239
|
0
|
|
|
|
|
0
|
else { |
240
|
|
|
|
|
|
|
$self->parent->ok( $self->is_passing, $self->name ); |
241
|
|
|
|
|
|
|
} |
242
|
|
|
|
|
|
|
} |
243
|
|
|
|
|
|
|
$? = $self->{Child_Error}; |
244
|
0
|
|
|
|
|
0
|
delete $self->{Parent}; |
245
|
|
|
|
|
|
|
|
246
|
0
|
|
|
|
|
0
|
return $self->is_passing; |
247
|
|
|
|
|
|
|
} |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
sub _indent { |
250
|
0
|
|
|
|
|
0
|
my $self = shift; |
|
0
|
|
|
|
|
0
|
|
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
if( @_ ) { |
253
|
0
|
|
|
|
|
0
|
$self->{Indent} = shift; |
254
|
0
|
|
|
|
|
0
|
} |
255
|
0
|
|
|
|
|
0
|
|
256
|
|
|
|
|
|
|
return $self->{Indent}; |
257
|
|
|
|
|
|
|
} |
258
|
|
|
|
|
|
|
|
259
|
0
|
|
|
0
|
|
0
|
#line 392 |
260
|
0
|
|
|
|
|
0
|
|
261
|
0
|
0
|
|
|
|
0
|
sub parent { shift->{Parent} } |
262
|
0
|
|
|
|
|
0
|
|
263
|
0
|
|
|
|
|
0
|
#line 404 |
264
|
|
|
|
|
|
|
|
265
|
0
|
0
|
|
|
|
0
|
sub name { shift->{Name} } |
|
0
|
|
|
|
|
0
|
|
266
|
0
|
|
|
|
|
0
|
|
267
|
|
|
|
|
|
|
sub DESTROY { |
268
|
|
|
|
|
|
|
my $self = shift; |
269
|
|
|
|
|
|
|
if ( $self->parent and $$ == $self->{Original_Pid} ) { |
270
|
|
|
|
|
|
|
my $name = $self->name; |
271
|
0
|
|
|
|
|
0
|
$self->diag(<<"FAIL"); |
272
|
0
|
|
|
|
|
0
|
Child ($name) exited without calling finalize() |
273
|
|
|
|
|
|
|
FAIL |
274
|
|
|
|
|
|
|
$self->parent->{In_Destroy} = 1; |
275
|
0
|
|
|
|
|
0
|
$self->parent->ok(0, $name); |
276
|
|
|
|
|
|
|
} |
277
|
|
|
|
|
|
|
} |
278
|
0
|
0
|
0
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
279
|
|
|
|
|
|
|
#line 428 |
280
|
0
|
|
|
|
|
0
|
|
281
|
0
|
|
|
|
|
0
|
our $Level; |
282
|
|
|
|
|
|
|
|
283
|
0
|
0
|
|
|
|
0
|
sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms) |
284
|
|
|
|
|
|
|
my($self) = @_; |
285
|
0
|
|
|
|
|
0
|
|
286
|
|
|
|
|
|
|
# We leave this a global because it has to be localized and localizing |
287
|
|
|
|
|
|
|
# hash keys is just asking for pain. Also, it was documented. |
288
|
|
|
|
|
|
|
$Level = 1; |
289
|
|
|
|
|
|
|
|
290
|
|
|
|
|
|
|
$self->{Name} = $0; |
291
|
|
|
|
|
|
|
$self->is_passing(1); |
292
|
|
|
|
|
|
|
$self->{Ending} = 0; |
293
|
|
|
|
|
|
|
$self->{Have_Plan} = 0; |
294
|
|
|
|
|
|
|
$self->{No_Plan} = 0; |
295
|
|
|
|
|
|
|
$self->{Have_Output_Plan} = 0; |
296
|
|
|
|
|
|
|
$self->{Done_Testing} = 0; |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
$self->{Original_Pid} = $$; |
299
|
|
|
|
|
|
|
$self->{Child_Name} = undef; |
300
|
|
|
|
|
|
|
$self->{Indent} ||= ''; |
301
|
|
|
|
|
|
|
|
302
|
|
|
|
|
|
|
$self->{Curr_Test} = 0; |
303
|
|
|
|
|
|
|
$self->{Test_Results} = &share( [] ); |
304
|
|
|
|
|
|
|
|
305
|
|
|
|
|
|
|
$self->{Exported_To} = undef; |
306
|
|
|
|
|
|
|
$self->{Expected_Tests} = 0; |
307
|
|
|
|
|
|
|
|
308
|
|
|
|
|
|
|
$self->{Skip_All} = 0; |
309
|
|
|
|
|
|
|
|
310
|
|
|
|
|
|
|
$self->{Use_Nums} = 1; |
311
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
$self->{No_Header} = 0; |
313
|
|
|
|
|
|
|
$self->{No_Ending} = 0; |
314
|
0
|
|
|
0
|
|
0
|
|
315
|
0
|
|
0
|
|
|
0
|
$self->{Todo} = undef; |
316
|
|
|
|
|
|
|
$self->{Todo_Stack} = []; |
317
|
|
|
|
|
|
|
$self->{Start_Todo} = 0; |
318
|
|
|
|
|
|
|
$self->{Opened_Testhandles} = 0; |
319
|
|
|
|
|
|
|
|
320
|
|
|
|
|
|
|
$self->_share_keys; |
321
|
|
|
|
|
|
|
$self->_dup_stdhandles; |
322
|
|
|
|
|
|
|
|
323
|
|
|
|
|
|
|
return; |
324
|
|
|
|
|
|
|
} |
325
|
|
|
|
|
|
|
|
326
|
|
|
|
|
|
|
|
327
|
|
|
|
|
|
|
# Shared scalar values are lost when a hash is copied, so we have |
328
|
|
|
|
|
|
|
# a separate method to restore them. |
329
|
|
|
|
|
|
|
# Shared references are retained across copies. |
330
|
|
|
|
|
|
|
sub _share_keys { |
331
|
|
|
|
|
|
|
my $self = shift; |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
share( $self->{Curr_Test} ); |
334
|
|
|
|
|
|
|
|
335
|
|
|
|
|
|
|
return; |
336
|
|
|
|
|
|
|
} |
337
|
|
|
|
|
|
|
|
338
|
|
|
|
|
|
|
|
339
|
0
|
|
|
0
|
1
|
0
|
#line 520 |
340
|
|
|
|
|
|
|
|
341
|
0
|
0
|
|
|
|
0
|
my %plan_cmds = ( |
342
|
0
|
0
|
|
|
|
0
|
no_plan => \&no_plan, |
343
|
0
|
|
|
|
|
0
|
skip_all => \&skip_all, |
344
|
|
|
|
|
|
|
tests => \&_plan_tests, |
345
|
|
|
|
|
|
|
); |
346
|
0
|
|
|
|
|
0
|
|
347
|
0
|
|
|
|
|
0
|
sub plan { |
348
|
|
|
|
|
|
|
my( $self, $cmd, $arg ) = @_; |
349
|
|
|
|
|
|
|
|
350
|
|
|
|
|
|
|
return unless $cmd; |
351
|
|
|
|
|
|
|
|
352
|
0
|
|
|
|
|
0
|
local $Level = $Level + 1; |
353
|
0
|
|
|
|
|
0
|
|
354
|
0
|
|
|
|
|
0
|
$self->croak("You tried to plan twice") if $self->{Have_Plan}; |
355
|
0
|
0
|
|
|
|
0
|
|
356
|
0
|
0
|
|
|
|
0
|
if( my $method = $plan_cmds{$cmd} ) { |
|
|
0
|
|
|
|
|
|
357
|
0
|
|
|
|
|
0
|
local $Level = $Level + 1; |
358
|
|
|
|
|
|
|
$self->$method($arg); |
359
|
0
|
|
|
|
|
0
|
} |
360
|
0
|
|
|
|
|
0
|
else { |
361
|
|
|
|
|
|
|
my @args = grep { defined } ( $cmd, $arg ); |
362
|
|
|
|
|
|
|
$self->croak("plan() doesn't understand @args"); |
363
|
0
|
|
|
|
|
0
|
} |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
return 1; |
366
|
0
|
|
|
|
|
0
|
} |
367
|
0
|
|
|
|
|
0
|
|
368
|
|
|
|
|
|
|
|
369
|
0
|
|
|
|
|
0
|
sub _plan_tests { |
370
|
|
|
|
|
|
|
my($self, $arg) = @_; |
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
if($arg) { |
373
|
2
|
|
|
2
|
|
3
|
local $Level = $Level + 1; |
374
|
|
|
|
|
|
|
return $self->expected_tests($arg); |
375
|
2
|
50
|
|
|
|
4
|
} |
376
|
0
|
|
|
|
|
0
|
elsif( !defined $arg ) { |
377
|
|
|
|
|
|
|
$self->croak("Got an undefined number of tests"); |
378
|
|
|
|
|
|
|
} |
379
|
2
|
|
|
|
|
4
|
else { |
380
|
|
|
|
|
|
|
$self->croak("You said to run 0 tests"); |
381
|
|
|
|
|
|
|
} |
382
|
|
|
|
|
|
|
|
383
|
|
|
|
|
|
|
return; |
384
|
|
|
|
|
|
|
} |
385
|
|
|
|
|
|
|
|
386
|
|
|
|
|
|
|
#line 575 |
387
|
|
|
|
|
|
|
|
388
|
|
|
|
|
|
|
sub expected_tests { |
389
|
|
|
|
|
|
|
my $self = shift; |
390
|
|
|
|
|
|
|
my($max) = @_; |
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
if(@_) { |
393
|
0
|
|
|
0
|
1
|
0
|
$self->croak("Number of tests must be a positive integer. You gave it '$max'") |
394
|
|
|
|
|
|
|
unless $max =~ /^\+?\d+$/; |
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
$self->{Expected_Tests} = $max; |
397
|
|
|
|
|
|
|
$self->{Have_Plan} = 1; |
398
|
|
|
|
|
|
|
|
399
|
|
|
|
|
|
|
$self->_output_plan($max) unless $self->no_header; |
400
|
|
|
|
|
|
|
} |
401
|
|
|
|
|
|
|
return $self->{Expected_Tests}; |
402
|
|
|
|
|
|
|
} |
403
|
|
|
|
|
|
|
|
404
|
|
|
|
|
|
|
#line 599 |
405
|
0
|
|
|
0
|
1
|
0
|
|
406
|
|
|
|
|
|
|
sub no_plan { |
407
|
|
|
|
|
|
|
my($self, $arg) = @_; |
408
|
0
|
|
|
0
|
|
0
|
|
409
|
0
|
0
|
0
|
|
|
0
|
$self->carp("no_plan takes no arguments") if $arg; |
410
|
0
|
|
|
|
|
0
|
|
411
|
0
|
|
|
|
|
0
|
$self->{No_Plan} = 1; |
412
|
|
|
|
|
|
|
$self->{Have_Plan} = 1; |
413
|
|
|
|
|
|
|
|
414
|
0
|
|
|
|
|
0
|
return 1; |
415
|
0
|
|
|
|
|
0
|
} |
416
|
|
|
|
|
|
|
|
417
|
|
|
|
|
|
|
#line 632 |
418
|
|
|
|
|
|
|
|
419
|
|
|
|
|
|
|
sub _output_plan { |
420
|
|
|
|
|
|
|
my($self, $max, $directive, $reason) = @_; |
421
|
|
|
|
|
|
|
|
422
|
|
|
|
|
|
|
$self->carp("The plan was already output") if $self->{Have_Output_Plan}; |
423
|
|
|
|
|
|
|
|
424
|
|
|
|
|
|
|
my $plan = "1..$max"; |
425
|
|
|
|
|
|
|
$plan .= " # $directive" if defined $directive; |
426
|
|
|
|
|
|
|
$plan .= " $reason" if defined $reason; |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
$self->_print("$plan\n"); |
429
|
|
|
|
|
|
|
|
430
|
|
|
|
|
|
|
$self->{Have_Output_Plan} = 1; |
431
|
|
|
|
|
|
|
|
432
|
1
|
|
|
1
|
1
|
1
|
return; |
433
|
|
|
|
|
|
|
} |
434
|
|
|
|
|
|
|
|
435
|
|
|
|
|
|
|
|
436
|
1
|
|
|
|
|
1
|
#line 684 |
437
|
|
|
|
|
|
|
|
438
|
1
|
|
|
|
|
6
|
sub done_testing { |
439
|
1
|
|
|
|
|
2
|
my($self, $num_tests) = @_; |
440
|
1
|
|
|
|
|
1
|
|
441
|
1
|
|
|
|
|
1
|
# If done_testing() specified the number of tests, shut off no_plan. |
442
|
1
|
|
|
|
|
1
|
if( defined $num_tests ) { |
443
|
1
|
|
|
|
|
1
|
$self->{No_Plan} = 0; |
444
|
1
|
|
|
|
|
1
|
} |
445
|
|
|
|
|
|
|
else { |
446
|
1
|
|
|
|
|
6
|
$num_tests = $self->current_test; |
447
|
1
|
|
|
|
|
1
|
} |
448
|
1
|
|
50
|
|
|
5
|
|
449
|
|
|
|
|
|
|
if( $self->{Done_Testing} ) { |
450
|
1
|
|
|
|
|
1
|
my($file, $line) = @{$self->{Done_Testing}}[1,2]; |
451
|
1
|
|
|
|
|
2
|
$self->ok(0, "done_testing() was already called at $file line $line"); |
452
|
|
|
|
|
|
|
return; |
453
|
1
|
|
|
|
|
1
|
} |
454
|
1
|
|
|
|
|
1
|
|
455
|
|
|
|
|
|
|
$self->{Done_Testing} = [caller]; |
456
|
1
|
|
|
|
|
2
|
|
457
|
|
|
|
|
|
|
if( $self->expected_tests && $num_tests != $self->expected_tests ) { |
458
|
1
|
|
|
|
|
1
|
$self->ok(0, "planned to run @{[ $self->expected_tests ]} ". |
459
|
|
|
|
|
|
|
"but done_testing() expects $num_tests"); |
460
|
1
|
|
|
|
|
2
|
} |
461
|
1
|
|
|
|
|
1
|
else { |
462
|
|
|
|
|
|
|
$self->{Expected_Tests} = $num_tests; |
463
|
1
|
|
|
|
|
1
|
} |
464
|
1
|
|
|
|
|
1
|
|
465
|
1
|
|
|
|
|
1
|
$self->_output_plan($num_tests) unless $self->{Have_Output_Plan}; |
466
|
1
|
|
|
|
|
1
|
|
467
|
|
|
|
|
|
|
$self->{Have_Plan} = 1; |
468
|
1
|
|
|
|
|
2
|
|
469
|
1
|
|
|
|
|
2
|
# The wrong number of tests were run |
470
|
|
|
|
|
|
|
$self->is_passing(0) if $self->{Expected_Tests} != $self->{Curr_Test}; |
471
|
1
|
|
|
|
|
1
|
|
472
|
|
|
|
|
|
|
# No tests were run |
473
|
|
|
|
|
|
|
$self->is_passing(0) if $self->{Curr_Test} == 0; |
474
|
|
|
|
|
|
|
|
475
|
|
|
|
|
|
|
return 1; |
476
|
|
|
|
|
|
|
} |
477
|
|
|
|
|
|
|
|
478
|
|
|
|
|
|
|
|
479
|
1
|
|
|
1
|
|
1
|
#line 735 |
480
|
|
|
|
|
|
|
|
481
|
1
|
|
|
|
|
1
|
sub has_plan { |
482
|
|
|
|
|
|
|
my $self = shift; |
483
|
1
|
|
|
|
|
1
|
|
484
|
|
|
|
|
|
|
return( $self->{Expected_Tests} ) if $self->{Expected_Tests}; |
485
|
|
|
|
|
|
|
return('no_plan') if $self->{No_Plan}; |
486
|
|
|
|
|
|
|
return(undef); |
487
|
|
|
|
|
|
|
} |
488
|
|
|
|
|
|
|
|
489
|
|
|
|
|
|
|
#line 752 |
490
|
|
|
|
|
|
|
|
491
|
|
|
|
|
|
|
sub skip_all { |
492
|
|
|
|
|
|
|
my( $self, $reason ) = @_; |
493
|
|
|
|
|
|
|
|
494
|
|
|
|
|
|
|
$self->{Skip_All} = $self->parent ? $reason : 1; |
495
|
|
|
|
|
|
|
|
496
|
|
|
|
|
|
|
$self->_output_plan(0, "SKIP", $reason) unless $self->no_header; |
497
|
|
|
|
|
|
|
if ( $self->parent ) { |
498
|
|
|
|
|
|
|
die bless {} => 'Test::Builder::Exception'; |
499
|
|
|
|
|
|
|
} |
500
|
|
|
|
|
|
|
exit(0); |
501
|
|
|
|
|
|
|
} |
502
|
|
|
|
|
|
|
|
503
|
|
|
|
|
|
|
#line 777 |
504
|
|
|
|
|
|
|
|
505
|
|
|
|
|
|
|
sub exported_to { |
506
|
|
|
|
|
|
|
my( $self, $pack ) = @_; |
507
|
|
|
|
|
|
|
|
508
|
|
|
|
|
|
|
if( defined $pack ) { |
509
|
|
|
|
|
|
|
$self->{Exported_To} = $pack; |
510
|
|
|
|
|
|
|
} |
511
|
|
|
|
|
|
|
return $self->{Exported_To}; |
512
|
|
|
|
|
|
|
} |
513
|
|
|
|
|
|
|
|
514
|
|
|
|
|
|
|
#line 807 |
515
|
|
|
|
|
|
|
|
516
|
|
|
|
|
|
|
sub ok { |
517
|
|
|
|
|
|
|
my( $self, $test, $name ) = @_; |
518
|
|
|
|
|
|
|
|
519
|
|
|
|
|
|
|
if ( $self->{Child_Name} and not $self->{In_Destroy} ) { |
520
|
|
|
|
|
|
|
$name = 'unnamed test' unless defined $name; |
521
|
|
|
|
|
|
|
$self->is_passing(0); |
522
|
|
|
|
|
|
|
$self->croak("Cannot run test ($name) with active children"); |
523
|
|
|
|
|
|
|
} |
524
|
|
|
|
|
|
|
# $test might contain an object which we don't want to accidentally |
525
|
|
|
|
|
|
|
# store, so we turn it into a boolean. |
526
|
|
|
|
|
|
|
$test = $test ? 1 : 0; |
527
|
|
|
|
|
|
|
|
528
|
1
|
|
|
1
|
1
|
1
|
lock $self->{Curr_Test}; |
529
|
|
|
|
|
|
|
$self->{Curr_Test}++; |
530
|
1
|
50
|
|
|
|
3
|
|
531
|
|
|
|
|
|
|
# In case $name is a string overloaded object, force it to stringify. |
532
|
1
|
|
|
|
|
1
|
$self->_unoverload_str( \$name ); |
533
|
|
|
|
|
|
|
|
534
|
1
|
50
|
|
|
|
3
|
$self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/; |
535
|
|
|
|
|
|
|
You named your test '$name'. You shouldn't use numbers for your test names. |
536
|
1
|
50
|
|
|
|
3
|
Very confusing. |
537
|
1
|
|
|
|
|
1
|
ERR |
538
|
1
|
|
|
|
|
2
|
|
539
|
|
|
|
|
|
|
# Capture the value of $TODO for the rest of this ok() call |
540
|
|
|
|
|
|
|
# so it can more easily be found by other routines. |
541
|
0
|
|
|
|
|
0
|
my $todo = $self->todo(); |
|
0
|
|
|
|
|
0
|
|
542
|
0
|
|
|
|
|
0
|
my $in_todo = $self->in_todo; |
543
|
|
|
|
|
|
|
local $self->{Todo} = $todo if $in_todo; |
544
|
|
|
|
|
|
|
|
545
|
1
|
|
|
|
|
2
|
$self->_unoverload_str( \$todo ); |
546
|
|
|
|
|
|
|
|
547
|
|
|
|
|
|
|
my $out; |
548
|
|
|
|
|
|
|
my $result = &share( {} ); |
549
|
|
|
|
|
|
|
|
550
|
1
|
|
|
1
|
|
1
|
unless($test) { |
551
|
|
|
|
|
|
|
$out .= "not "; |
552
|
1
|
50
|
|
|
|
2
|
@$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 ); |
|
|
0
|
|
|
|
|
|
553
|
1
|
|
|
|
|
1
|
} |
554
|
1
|
|
|
|
|
1
|
else { |
555
|
|
|
|
|
|
|
@$result{ 'ok', 'actual_ok' } = ( 1, $test ); |
556
|
|
|
|
|
|
|
} |
557
|
0
|
|
|
|
|
0
|
|
558
|
|
|
|
|
|
|
$out .= "ok"; |
559
|
|
|
|
|
|
|
$out .= " $self->{Curr_Test}" if $self->use_numbers; |
560
|
0
|
|
|
|
|
0
|
|
561
|
|
|
|
|
|
|
if( defined $name ) { |
562
|
|
|
|
|
|
|
$name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. |
563
|
0
|
|
|
|
|
0
|
$out .= " - $name"; |
564
|
|
|
|
|
|
|
$result->{name} = $name; |
565
|
|
|
|
|
|
|
} |
566
|
|
|
|
|
|
|
else { |
567
|
|
|
|
|
|
|
$result->{name} = ''; |
568
|
|
|
|
|
|
|
} |
569
|
|
|
|
|
|
|
|
570
|
|
|
|
|
|
|
if( $self->in_todo ) { |
571
|
|
|
|
|
|
|
$out .= " # TODO $todo"; |
572
|
|
|
|
|
|
|
$result->{reason} = $todo; |
573
|
|
|
|
|
|
|
$result->{type} = 'todo'; |
574
|
|
|
|
|
|
|
} |
575
|
|
|
|
|
|
|
else { |
576
|
|
|
|
|
|
|
$result->{reason} = ''; |
577
|
1
|
|
|
1
|
1
|
2
|
$result->{type} = ''; |
578
|
1
|
|
|
|
|
1
|
} |
579
|
|
|
|
|
|
|
|
580
|
1
|
50
|
|
|
|
3
|
$self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result; |
581
|
1
|
50
|
|
|
|
6
|
$out .= "\n"; |
582
|
|
|
|
|
|
|
|
583
|
|
|
|
|
|
|
$self->_print($out); |
584
|
1
|
|
|
|
|
2
|
|
585
|
1
|
|
|
|
|
1
|
unless($test) { |
586
|
|
|
|
|
|
|
my $msg = $self->in_todo ? "Failed (TODO)" : "Failed"; |
587
|
1
|
50
|
|
|
|
608
|
$self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE}; |
588
|
|
|
|
|
|
|
|
589
|
1
|
|
|
|
|
2
|
my( undef, $file, $line ) = $self->caller; |
590
|
|
|
|
|
|
|
if( defined $name ) { |
591
|
|
|
|
|
|
|
$self->diag(qq[ $msg test '$name'\n]); |
592
|
|
|
|
|
|
|
$self->diag(qq[ at $file line $line.\n]); |
593
|
|
|
|
|
|
|
} |
594
|
|
|
|
|
|
|
else { |
595
|
|
|
|
|
|
|
$self->diag(qq[ $msg test at $file line $line.\n]); |
596
|
|
|
|
|
|
|
} |
597
|
|
|
|
|
|
|
} |
598
|
|
|
|
|
|
|
|
599
|
|
|
|
|
|
|
$self->is_passing(0) unless $test || $self->in_todo; |
600
|
|
|
|
|
|
|
|
601
|
0
|
|
|
0
|
1
|
0
|
# Check that we haven't violated the plan |
602
|
|
|
|
|
|
|
$self->_check_is_passing_plan(); |
603
|
0
|
0
|
|
|
|
0
|
|
604
|
|
|
|
|
|
|
return $test ? 1 : 0; |
605
|
0
|
|
|
|
|
0
|
} |
606
|
0
|
|
|
|
|
0
|
|
607
|
|
|
|
|
|
|
|
608
|
0
|
|
|
|
|
0
|
# Check that we haven't yet violated the plan and set |
609
|
|
|
|
|
|
|
# is_passing() accordingly |
610
|
|
|
|
|
|
|
sub _check_is_passing_plan { |
611
|
|
|
|
|
|
|
my $self = shift; |
612
|
|
|
|
|
|
|
|
613
|
|
|
|
|
|
|
my $plan = $self->has_plan; |
614
|
|
|
|
|
|
|
return unless defined $plan; # no plan yet defined |
615
|
|
|
|
|
|
|
return unless $plan !~ /\D/; # no numeric plan |
616
|
|
|
|
|
|
|
$self->is_passing(0) if $plan < $self->{Curr_Test}; |
617
|
|
|
|
|
|
|
} |
618
|
|
|
|
|
|
|
|
619
|
|
|
|
|
|
|
|
620
|
|
|
|
|
|
|
sub _unoverload { |
621
|
|
|
|
|
|
|
my $self = shift; |
622
|
|
|
|
|
|
|
my $type = shift; |
623
|
|
|
|
|
|
|
|
624
|
|
|
|
|
|
|
$self->_try(sub { require overload; }, die_on_fail => 1); |
625
|
|
|
|
|
|
|
|
626
|
|
|
|
|
|
|
foreach my $thing (@_) { |
627
|
|
|
|
|
|
|
if( $self->_is_object($$thing) ) { |
628
|
|
|
|
|
|
|
if( my $string_meth = overload::Method( $$thing, $type ) ) { |
629
|
|
|
|
|
|
|
$$thing = $$thing->$string_meth(); |
630
|
|
|
|
|
|
|
} |
631
|
|
|
|
|
|
|
} |
632
|
|
|
|
|
|
|
} |
633
|
|
|
|
|
|
|
|
634
|
1
|
|
|
1
|
|
1
|
return; |
635
|
|
|
|
|
|
|
} |
636
|
1
|
50
|
|
|
|
2
|
|
637
|
|
|
|
|
|
|
sub _is_object { |
638
|
1
|
|
|
|
|
2
|
my( $self, $thing ) = @_; |
639
|
1
|
50
|
|
|
|
2
|
|
640
|
1
|
50
|
|
|
|
1
|
return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0; |
641
|
|
|
|
|
|
|
} |
642
|
1
|
|
|
|
|
5
|
|
643
|
|
|
|
|
|
|
sub _unoverload_str { |
644
|
1
|
|
|
|
|
1
|
my $self = shift; |
645
|
|
|
|
|
|
|
|
646
|
1
|
|
|
|
|
2
|
return $self->_unoverload( q[""], @_ ); |
647
|
|
|
|
|
|
|
} |
648
|
|
|
|
|
|
|
|
649
|
|
|
|
|
|
|
sub _unoverload_num { |
650
|
|
|
|
|
|
|
my $self = shift; |
651
|
|
|
|
|
|
|
|
652
|
|
|
|
|
|
|
$self->_unoverload( '0+', @_ ); |
653
|
|
|
|
|
|
|
|
654
|
|
|
|
|
|
|
for my $val (@_) { |
655
|
|
|
|
|
|
|
next unless $self->_is_dualvar($$val); |
656
|
|
|
|
|
|
|
$$val = $$val + 0; |
657
|
|
|
|
|
|
|
} |
658
|
|
|
|
|
|
|
|
659
|
|
|
|
|
|
|
return; |
660
|
|
|
|
|
|
|
} |
661
|
|
|
|
|
|
|
|
662
|
|
|
|
|
|
|
# This is a hack to detect a dualvar such as $! |
663
|
|
|
|
|
|
|
sub _is_dualvar { |
664
|
|
|
|
|
|
|
my( $self, $val ) = @_; |
665
|
|
|
|
|
|
|
|
666
|
|
|
|
|
|
|
# Objects are not dualvars. |
667
|
|
|
|
|
|
|
return 0 if ref $val; |
668
|
|
|
|
|
|
|
|
669
|
|
|
|
|
|
|
no warnings 'numeric'; |
670
|
|
|
|
|
|
|
my $numval = $val + 0; |
671
|
|
|
|
|
|
|
return ($numval != 0 and $numval ne $val ? 1 : 0); |
672
|
|
|
|
|
|
|
} |
673
|
|
|
|
|
|
|
|
674
|
|
|
|
|
|
|
#line 985 |
675
|
|
|
|
|
|
|
|
676
|
|
|
|
|
|
|
sub is_eq { |
677
|
|
|
|
|
|
|
my( $self, $got, $expect, $name ) = @_; |
678
|
|
|
|
|
|
|
local $Level = $Level + 1; |
679
|
|
|
|
|
|
|
|
680
|
|
|
|
|
|
|
if( !defined $got || !defined $expect ) { |
681
|
|
|
|
|
|
|
# undef only matches undef and nothing else |
682
|
|
|
|
|
|
|
my $test = !defined $got && !defined $expect; |
683
|
|
|
|
|
|
|
|
684
|
|
|
|
|
|
|
$self->ok( $test, $name ); |
685
|
|
|
|
|
|
|
$self->_is_diag( $got, 'eq', $expect ) unless $test; |
686
|
0
|
|
|
0
|
1
|
0
|
return $test; |
687
|
|
|
|
|
|
|
} |
688
|
|
|
|
|
|
|
|
689
|
0
|
0
|
|
|
|
0
|
return $self->cmp_ok( $got, 'eq', $expect, $name ); |
690
|
0
|
|
|
|
|
0
|
} |
691
|
|
|
|
|
|
|
|
692
|
|
|
|
|
|
|
sub is_num { |
693
|
0
|
|
|
|
|
0
|
my( $self, $got, $expect, $name ) = @_; |
694
|
|
|
|
|
|
|
local $Level = $Level + 1; |
695
|
|
|
|
|
|
|
|
696
|
0
|
0
|
|
|
|
0
|
if( !defined $got || !defined $expect ) { |
697
|
0
|
|
|
|
|
0
|
# undef only matches undef and nothing else |
|
0
|
|
|
|
|
0
|
|
698
|
0
|
|
|
|
|
0
|
my $test = !defined $got && !defined $expect; |
699
|
0
|
|
|
|
|
0
|
|
700
|
|
|
|
|
|
|
$self->ok( $test, $name ); |
701
|
|
|
|
|
|
|
$self->_is_diag( $got, '==', $expect ) unless $test; |
702
|
0
|
|
|
|
|
0
|
return $test; |
703
|
|
|
|
|
|
|
} |
704
|
0
|
0
|
0
|
|
|
0
|
|
705
|
0
|
|
|
|
|
0
|
return $self->cmp_ok( $got, '==', $expect, $name ); |
|
0
|
|
|
|
|
0
|
|
706
|
|
|
|
|
|
|
} |
707
|
|
|
|
|
|
|
|
708
|
|
|
|
|
|
|
sub _diag_fmt { |
709
|
0
|
|
|
|
|
0
|
my( $self, $type, $val ) = @_; |
710
|
|
|
|
|
|
|
|
711
|
|
|
|
|
|
|
if( defined $$val ) { |
712
|
0
|
0
|
|
|
|
0
|
if( $type eq 'eq' or $type eq 'ne' ) { |
713
|
|
|
|
|
|
|
# quote and force string context |
714
|
0
|
|
|
|
|
0
|
$$val = "'$$val'"; |
715
|
|
|
|
|
|
|
} |
716
|
|
|
|
|
|
|
else { |
717
|
0
|
0
|
|
|
|
0
|
# force numeric context |
718
|
|
|
|
|
|
|
$self->_unoverload_num($val); |
719
|
|
|
|
|
|
|
} |
720
|
0
|
0
|
|
|
|
0
|
} |
721
|
|
|
|
|
|
|
else { |
722
|
0
|
|
|
|
|
0
|
$$val = 'undef'; |
723
|
|
|
|
|
|
|
} |
724
|
|
|
|
|
|
|
|
725
|
|
|
|
|
|
|
return; |
726
|
|
|
|
|
|
|
} |
727
|
|
|
|
|
|
|
|
728
|
|
|
|
|
|
|
sub _is_diag { |
729
|
|
|
|
|
|
|
my( $self, $got, $type, $expect ) = @_; |
730
|
|
|
|
|
|
|
|
731
|
|
|
|
|
|
|
$self->_diag_fmt( $type, $_ ) for \$got, \$expect; |
732
|
|
|
|
|
|
|
|
733
|
|
|
|
|
|
|
local $Level = $Level + 1; |
734
|
|
|
|
|
|
|
return $self->diag(<<"DIAGNOSTIC"); |
735
|
|
|
|
|
|
|
got: $got |
736
|
|
|
|
|
|
|
expected: $expect |
737
|
0
|
|
|
0
|
1
|
0
|
DIAGNOSTIC |
738
|
|
|
|
|
|
|
|
739
|
0
|
0
|
|
|
|
0
|
} |
740
|
0
|
0
|
|
|
|
0
|
|
741
|
0
|
|
|
|
|
0
|
sub _isnt_diag { |
742
|
|
|
|
|
|
|
my( $self, $got, $type ) = @_; |
743
|
|
|
|
|
|
|
|
744
|
|
|
|
|
|
|
$self->_diag_fmt( $type, \$got ); |
745
|
|
|
|
|
|
|
|
746
|
|
|
|
|
|
|
local $Level = $Level + 1; |
747
|
|
|
|
|
|
|
return $self->diag(<<"DIAGNOSTIC"); |
748
|
|
|
|
|
|
|
got: $got |
749
|
|
|
|
|
|
|
expected: anything else |
750
|
|
|
|
|
|
|
DIAGNOSTIC |
751
|
|
|
|
|
|
|
} |
752
|
|
|
|
|
|
|
|
753
|
|
|
|
|
|
|
#line 1078 |
754
|
0
|
|
|
0
|
1
|
0
|
|
755
|
|
|
|
|
|
|
sub isnt_eq { |
756
|
0
|
0
|
|
|
|
0
|
my( $self, $got, $dont_expect, $name ) = @_; |
757
|
|
|
|
|
|
|
local $Level = $Level + 1; |
758
|
0
|
0
|
|
|
|
0
|
|
759
|
0
|
0
|
|
|
|
0
|
if( !defined $got || !defined $dont_expect ) { |
760
|
0
|
|
|
|
|
0
|
# undef only matches undef and nothing else |
761
|
|
|
|
|
|
|
my $test = defined $got || defined $dont_expect; |
762
|
0
|
|
|
|
|
0
|
|
763
|
|
|
|
|
|
|
$self->ok( $test, $name ); |
764
|
|
|
|
|
|
|
$self->_isnt_diag( $got, 'ne' ) unless $test; |
765
|
|
|
|
|
|
|
return $test; |
766
|
|
|
|
|
|
|
} |
767
|
|
|
|
|
|
|
|
768
|
|
|
|
|
|
|
return $self->cmp_ok( $got, 'ne', $dont_expect, $name ); |
769
|
|
|
|
|
|
|
} |
770
|
|
|
|
|
|
|
|
771
|
|
|
|
|
|
|
sub isnt_num { |
772
|
|
|
|
|
|
|
my( $self, $got, $dont_expect, $name ) = @_; |
773
|
|
|
|
|
|
|
local $Level = $Level + 1; |
774
|
|
|
|
|
|
|
|
775
|
|
|
|
|
|
|
if( !defined $got || !defined $dont_expect ) { |
776
|
|
|
|
|
|
|
# undef only matches undef and nothing else |
777
|
|
|
|
|
|
|
my $test = defined $got || defined $dont_expect; |
778
|
|
|
|
|
|
|
|
779
|
1
|
|
|
1
|
1
|
2
|
$self->ok( $test, $name ); |
780
|
|
|
|
|
|
|
$self->_isnt_diag( $got, '!=' ) unless $test; |
781
|
1
|
50
|
|
|
|
2
|
return $test; |
782
|
1
|
|
|
|
|
2
|
} |
783
|
|
|
|
|
|
|
|
784
|
1
|
|
|
|
|
1
|
return $self->cmp_ok( $got, '!=', $dont_expect, $name ); |
785
|
|
|
|
|
|
|
} |
786
|
|
|
|
|
|
|
|
787
|
|
|
|
|
|
|
#line 1127 |
788
|
|
|
|
|
|
|
|
789
|
|
|
|
|
|
|
sub like { |
790
|
|
|
|
|
|
|
my( $self, $thing, $regex, $name ) = @_; |
791
|
|
|
|
|
|
|
|
792
|
|
|
|
|
|
|
local $Level = $Level + 1; |
793
|
|
|
|
|
|
|
return $self->_regex_ok( $thing, $regex, '=~', $name ); |
794
|
|
|
|
|
|
|
} |
795
|
|
|
|
|
|
|
|
796
|
|
|
|
|
|
|
sub unlike { |
797
|
|
|
|
|
|
|
my( $self, $thing, $regex, $name ) = @_; |
798
|
|
|
|
|
|
|
|
799
|
|
|
|
|
|
|
local $Level = $Level + 1; |
800
|
|
|
|
|
|
|
return $self->_regex_ok( $thing, $regex, '!~', $name ); |
801
|
|
|
|
|
|
|
} |
802
|
|
|
|
|
|
|
|
803
|
|
|
|
|
|
|
#line 1151 |
804
|
|
|
|
|
|
|
|
805
|
|
|
|
|
|
|
my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" ); |
806
|
|
|
|
|
|
|
|
807
|
|
|
|
|
|
|
# Bad, these are not comparison operators. Should we include more? |
808
|
|
|
|
|
|
|
my %cmp_ok_bl = map { ( $_, 1 ) } ( "=", "+=", ".=", "x=", "^=", "|=", "||=", "&&=", "..."); |
809
|
1
|
|
|
1
|
1
|
1
|
|
810
|
|
|
|
|
|
|
sub cmp_ok { |
811
|
1
|
50
|
33
|
|
|
5
|
my( $self, $got, $type, $expect, $name ) = @_; |
812
|
0
|
0
|
|
|
|
0
|
|
813
|
0
|
|
|
|
|
0
|
if ($cmp_ok_bl{$type}) { |
814
|
0
|
|
|
|
|
0
|
$self->croak("$type is not a valid comparison operator in cmp_ok()"); |
815
|
|
|
|
|
|
|
} |
816
|
|
|
|
|
|
|
|
817
|
|
|
|
|
|
|
my ($test, $succ); |
818
|
1
|
50
|
|
|
|
3
|
my $error; |
819
|
|
|
|
|
|
|
{ |
820
|
1
|
|
|
|
|
4
|
## no critic (BuiltinFunctions::ProhibitStringyEval) |
821
|
1
|
|
|
|
|
1
|
|
822
|
|
|
|
|
|
|
local( $@, $!, $SIG{__DIE__} ); # isolate eval |
823
|
|
|
|
|
|
|
|
824
|
1
|
|
|
|
|
3
|
my($pack, $file, $line) = $self->caller(); |
825
|
|
|
|
|
|
|
|
826
|
0
|
0
|
0
|
|
|
0
|
# This is so that warnings come out at the caller's level |
827
|
|
|
|
|
|
|
$succ = eval qq[ |
828
|
|
|
|
|
|
|
#line $line "(eval in cmp_ok) $file" |
829
|
|
|
|
|
|
|
\$test = (\$got $type \$expect); |
830
|
|
|
|
|
|
|
1; |
831
|
|
|
|
|
|
|
]; |
832
|
|
|
|
|
|
|
$error = $@; |
833
|
0
|
|
|
|
|
0
|
} |
834
|
0
|
|
|
|
|
0
|
local $Level = $Level + 1; |
835
|
0
|
0
|
|
|
|
0
|
my $ok = $self->ok( $test, $name ); |
836
|
|
|
|
|
|
|
|
837
|
0
|
|
|
|
|
0
|
# Treat overloaded objects as numbers if we're asked to do a |
838
|
|
|
|
|
|
|
# numeric comparison. |
839
|
0
|
|
|
|
|
0
|
my $unoverload |
840
|
0
|
|
|
|
|
0
|
= $numeric_cmps{$type} |
841
|
|
|
|
|
|
|
? '_unoverload_num' |
842
|
0
|
0
|
|
|
|
0
|
: '_unoverload_str'; |
843
|
0
|
|
|
|
|
0
|
|
844
|
0
|
0
|
|
|
|
0
|
$self->diag(<<"END") unless $succ; |
845
|
|
|
|
|
|
|
An error occurred while using $type: |
846
|
|
|
|
|
|
|
------------------------------------ |
847
|
0
|
|
|
|
|
0
|
$error |
848
|
|
|
|
|
|
|
------------------------------------ |
849
|
|
|
|
|
|
|
END |
850
|
0
|
|
|
|
|
0
|
|
851
|
0
|
0
|
|
|
|
0
|
unless($ok) { |
852
|
|
|
|
|
|
|
$self->$unoverload( \$got, \$expect ); |
853
|
0
|
0
|
|
|
|
0
|
|
854
|
0
|
|
|
|
|
0
|
if( $type =~ /^(eq|==)$/ ) { |
855
|
0
|
|
|
|
|
0
|
$self->_is_diag( $got, $type, $expect ); |
856
|
0
|
|
|
|
|
0
|
} |
857
|
|
|
|
|
|
|
elsif( $type =~ /^(ne|!=)$/ ) { |
858
|
|
|
|
|
|
|
$self->_isnt_diag( $got, $type ); |
859
|
0
|
|
|
|
|
0
|
} |
860
|
|
|
|
|
|
|
else { |
861
|
|
|
|
|
|
|
$self->_cmp_diag( $got, $type, $expect ); |
862
|
0
|
0
|
|
|
|
0
|
} |
863
|
0
|
|
|
|
|
0
|
} |
864
|
0
|
|
|
|
|
0
|
return $ok; |
865
|
0
|
|
|
|
|
0
|
} |
866
|
|
|
|
|
|
|
|
867
|
|
|
|
|
|
|
sub _cmp_diag { |
868
|
0
|
|
|
|
|
0
|
my( $self, $got, $type, $expect ) = @_; |
869
|
0
|
|
|
|
|
0
|
|
870
|
|
|
|
|
|
|
$got = defined $got ? "'$got'" : 'undef'; |
871
|
|
|
|
|
|
|
$expect = defined $expect ? "'$expect'" : 'undef'; |
872
|
0
|
|
|
|
|
0
|
|
873
|
0
|
|
|
|
|
0
|
local $Level = $Level + 1; |
874
|
|
|
|
|
|
|
return $self->diag(<<"DIAGNOSTIC"); |
875
|
0
|
|
|
|
|
0
|
$got |
876
|
|
|
|
|
|
|
$type |
877
|
0
|
0
|
|
|
|
0
|
$expect |
878
|
0
|
0
|
|
|
|
0
|
DIAGNOSTIC |
879
|
0
|
0
|
|
|
|
0
|
} |
880
|
|
|
|
|
|
|
|
881
|
0
|
|
|
|
|
0
|
sub _caller_context { |
882
|
0
|
0
|
|
|
|
0
|
my $self = shift; |
883
|
0
|
|
|
|
|
0
|
|
884
|
0
|
|
|
|
|
0
|
my( $pack, $file, $line ) = $self->caller(1); |
885
|
|
|
|
|
|
|
|
886
|
|
|
|
|
|
|
my $code = ''; |
887
|
0
|
|
|
|
|
0
|
$code .= "#line $line $file\n" if defined $file and defined $line; |
888
|
|
|
|
|
|
|
|
889
|
|
|
|
|
|
|
return $code; |
890
|
|
|
|
|
|
|
} |
891
|
0
|
0
|
0
|
|
|
0
|
|
892
|
|
|
|
|
|
|
#line 1259 |
893
|
|
|
|
|
|
|
|
894
|
0
|
|
|
|
|
0
|
sub BAIL_OUT { |
895
|
|
|
|
|
|
|
my( $self, $reason ) = @_; |
896
|
0
|
0
|
|
|
|
0
|
|
897
|
|
|
|
|
|
|
$self->{Bailed_Out} = 1; |
898
|
|
|
|
|
|
|
|
899
|
|
|
|
|
|
|
if ($self->parent) { |
900
|
|
|
|
|
|
|
$self->{Bailed_Out_Reason} = $reason; |
901
|
|
|
|
|
|
|
$self->no_ending(1); |
902
|
|
|
|
|
|
|
die bless {} => 'Test::Builder::Exception'; |
903
|
0
|
|
|
0
|
|
0
|
} |
904
|
|
|
|
|
|
|
|
905
|
0
|
|
|
|
|
0
|
$self->_print("Bail out! $reason"); |
906
|
0
|
0
|
|
|
|
0
|
exit 255; |
907
|
0
|
0
|
|
|
|
0
|
} |
908
|
0
|
0
|
|
|
|
0
|
|
909
|
|
|
|
|
|
|
#line 1279 |
910
|
|
|
|
|
|
|
|
911
|
|
|
|
|
|
|
{ |
912
|
|
|
|
|
|
|
no warnings 'once'; |
913
|
1
|
|
|
1
|
|
1
|
*BAILOUT = \&BAIL_OUT; |
914
|
1
|
|
|
|
|
1
|
} |
915
|
|
|
|
|
|
|
|
916
|
1
|
|
|
1
|
|
4
|
#line 1293 |
|
1
|
|
|
|
|
6
|
|
917
|
|
|
|
|
|
|
|
918
|
1
|
|
|
|
|
3
|
sub skip { |
919
|
1
|
50
|
|
|
|
3
|
my( $self, $why, $name ) = @_; |
920
|
1
|
0
|
|
|
|
4
|
$why ||= ''; |
921
|
0
|
|
|
|
|
0
|
$name = '' unless defined $name; |
922
|
|
|
|
|
|
|
$self->_unoverload_str( \$why ); |
923
|
|
|
|
|
|
|
|
924
|
|
|
|
|
|
|
lock( $self->{Curr_Test} ); |
925
|
|
|
|
|
|
|
$self->{Curr_Test}++; |
926
|
0
|
|
|
|
|
0
|
|
927
|
|
|
|
|
|
|
$self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share( |
928
|
|
|
|
|
|
|
{ |
929
|
|
|
|
|
|
|
'ok' => 1, |
930
|
1
|
|
|
1
|
|
1
|
actual_ok => 1, |
931
|
|
|
|
|
|
|
name => $name, |
932
|
1
|
50
|
|
1
|
|
4
|
type => 'skip', |
|
1
|
50
|
|
|
|
64
|
|
933
|
|
|
|
|
|
|
reason => $why, |
934
|
|
|
|
|
|
|
} |
935
|
|
|
|
|
|
|
); |
936
|
1
|
|
|
1
|
|
2
|
|
937
|
|
|
|
|
|
|
my $out = "ok"; |
938
|
1
|
|
|
|
|
3
|
$out .= " $self->{Curr_Test}" if $self->use_numbers; |
939
|
|
|
|
|
|
|
$out .= " # skip"; |
940
|
|
|
|
|
|
|
$out .= " $why" if length $why; |
941
|
|
|
|
|
|
|
$out .= "\n"; |
942
|
0
|
|
|
0
|
|
0
|
|
943
|
|
|
|
|
|
|
$self->_print($out); |
944
|
0
|
|
|
|
|
0
|
|
945
|
|
|
|
|
|
|
return 1; |
946
|
0
|
|
|
|
|
0
|
} |
947
|
0
|
0
|
|
|
|
0
|
|
948
|
0
|
|
|
|
|
0
|
#line 1335 |
949
|
|
|
|
|
|
|
|
950
|
|
|
|
|
|
|
sub todo_skip { |
951
|
0
|
|
|
|
|
0
|
my( $self, $why ) = @_; |
952
|
|
|
|
|
|
|
$why ||= ''; |
953
|
|
|
|
|
|
|
|
954
|
|
|
|
|
|
|
lock( $self->{Curr_Test} ); |
955
|
|
|
|
|
|
|
$self->{Curr_Test}++; |
956
|
0
|
|
|
0
|
|
0
|
|
957
|
|
|
|
|
|
|
$self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share( |
958
|
|
|
|
|
|
|
{ |
959
|
0
|
0
|
|
|
|
0
|
'ok' => 1, |
960
|
|
|
|
|
|
|
actual_ok => 0, |
961
|
1
|
|
|
1
|
|
4
|
name => '', |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
913
|
|
962
|
0
|
|
|
|
|
0
|
type => 'todo_skip', |
963
|
0
|
|
0
|
|
|
0
|
reason => $why, |
964
|
|
|
|
|
|
|
} |
965
|
|
|
|
|
|
|
); |
966
|
|
|
|
|
|
|
|
967
|
|
|
|
|
|
|
my $out = "not ok"; |
968
|
|
|
|
|
|
|
$out .= " $self->{Curr_Test}" if $self->use_numbers; |
969
|
|
|
|
|
|
|
$out .= " # TODO & SKIP $why\n"; |
970
|
|
|
|
|
|
|
|
971
|
|
|
|
|
|
|
$self->_print($out); |
972
|
|
|
|
|
|
|
|
973
|
|
|
|
|
|
|
return 1; |
974
|
|
|
|
|
|
|
} |
975
|
|
|
|
|
|
|
|
976
|
|
|
|
|
|
|
#line 1415 |
977
|
|
|
|
|
|
|
|
978
|
|
|
|
|
|
|
sub maybe_regex { |
979
|
|
|
|
|
|
|
my( $self, $regex ) = @_; |
980
|
|
|
|
|
|
|
my $usable_regex = undef; |
981
|
|
|
|
|
|
|
|
982
|
|
|
|
|
|
|
return $usable_regex unless defined $regex; |
983
|
|
|
|
|
|
|
|
984
|
|
|
|
|
|
|
my( $re, $opts ); |
985
|
|
|
|
|
|
|
|
986
|
|
|
|
|
|
|
# Check for qr/foo/ |
987
|
1
|
|
|
1
|
1
|
2
|
if( _is_qr($regex) ) { |
988
|
1
|
|
|
|
|
1
|
$usable_regex = $regex; |
989
|
|
|
|
|
|
|
} |
990
|
1
|
50
|
33
|
|
|
9
|
# Check for '/foo/' or 'm,foo,' |
991
|
|
|
|
|
|
|
elsif(( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or |
992
|
0
|
|
0
|
|
|
0
|
( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx |
993
|
|
|
|
|
|
|
) |
994
|
0
|
|
|
|
|
0
|
{ |
995
|
0
|
0
|
|
|
|
0
|
$usable_regex = length $opts ? "(?$opts)$re" : $re; |
996
|
0
|
|
|
|
|
0
|
} |
997
|
|
|
|
|
|
|
|
998
|
|
|
|
|
|
|
return $usable_regex; |
999
|
1
|
|
|
|
|
4
|
} |
1000
|
|
|
|
|
|
|
|
1001
|
|
|
|
|
|
|
sub _is_qr { |
1002
|
|
|
|
|
|
|
my $regex = shift; |
1003
|
0
|
|
|
0
|
1
|
0
|
|
1004
|
0
|
|
|
|
|
0
|
# is_regexp() checks for regexes in a robust manner, say if they're |
1005
|
|
|
|
|
|
|
# blessed. |
1006
|
0
|
0
|
0
|
|
|
0
|
return re::is_regexp($regex) if defined &re::is_regexp; |
1007
|
|
|
|
|
|
|
return ref $regex eq 'Regexp'; |
1008
|
0
|
|
0
|
|
|
0
|
} |
1009
|
|
|
|
|
|
|
|
1010
|
0
|
|
|
|
|
0
|
sub _regex_ok { |
1011
|
0
|
0
|
|
|
|
0
|
my( $self, $thing, $regex, $cmp, $name ) = @_; |
1012
|
0
|
|
|
|
|
0
|
|
1013
|
|
|
|
|
|
|
my $ok = 0; |
1014
|
|
|
|
|
|
|
my $usable_regex = $self->maybe_regex($regex); |
1015
|
0
|
|
|
|
|
0
|
unless( defined $usable_regex ) { |
1016
|
|
|
|
|
|
|
local $Level = $Level + 1; |
1017
|
|
|
|
|
|
|
$ok = $self->ok( 0, $name ); |
1018
|
|
|
|
|
|
|
$self->diag(" '$regex' doesn't look much like a regex to me."); |
1019
|
0
|
|
|
0
|
|
0
|
return $ok; |
1020
|
|
|
|
|
|
|
} |
1021
|
0
|
0
|
|
|
|
0
|
|
1022
|
0
|
0
|
0
|
|
|
0
|
{ |
1023
|
|
|
|
|
|
|
my $test; |
1024
|
0
|
|
|
|
|
0
|
my $context = $self->_caller_context; |
1025
|
|
|
|
|
|
|
|
1026
|
|
|
|
|
|
|
{ |
1027
|
|
|
|
|
|
|
## no critic (BuiltinFunctions::ProhibitStringyEval) |
1028
|
0
|
|
|
|
|
0
|
|
1029
|
|
|
|
|
|
|
local( $@, $!, $SIG{__DIE__} ); # isolate eval |
1030
|
|
|
|
|
|
|
|
1031
|
|
|
|
|
|
|
# No point in issuing an uninit warning, they'll see it in the diagnostics |
1032
|
0
|
|
|
|
|
0
|
no warnings 'uninitialized'; |
1033
|
|
|
|
|
|
|
|
1034
|
|
|
|
|
|
|
$test = eval $context . q{$test = $thing =~ /$usable_regex/ ? 1 : 0}; |
1035
|
0
|
|
|
|
|
0
|
} |
1036
|
|
|
|
|
|
|
|
1037
|
|
|
|
|
|
|
$test = !$test if $cmp eq '!~'; |
1038
|
|
|
|
|
|
|
|
1039
|
0
|
|
|
0
|
|
0
|
local $Level = $Level + 1; |
1040
|
|
|
|
|
|
|
$ok = $self->ok( $test, $name ); |
1041
|
0
|
|
|
|
|
0
|
} |
1042
|
|
|
|
|
|
|
|
1043
|
0
|
|
|
|
|
0
|
unless($ok) { |
1044
|
0
|
|
|
|
|
0
|
$thing = defined $thing ? "'$thing'" : 'undef'; |
1045
|
|
|
|
|
|
|
my $match = $cmp eq '=~' ? "doesn't match" : "matches"; |
1046
|
|
|
|
|
|
|
|
1047
|
|
|
|
|
|
|
local $Level = $Level + 1; |
1048
|
|
|
|
|
|
|
$self->diag( sprintf <<'DIAGNOSTIC', $thing, $match, $regex ); |
1049
|
|
|
|
|
|
|
%s |
1050
|
|
|
|
|
|
|
%13s '%s' |
1051
|
|
|
|
|
|
|
DIAGNOSTIC |
1052
|
0
|
|
|
0
|
|
0
|
|
1053
|
|
|
|
|
|
|
} |
1054
|
0
|
|
|
|
|
0
|
|
1055
|
|
|
|
|
|
|
return $ok; |
1056
|
0
|
|
|
|
|
0
|
} |
1057
|
0
|
|
|
|
|
0
|
|
1058
|
|
|
|
|
|
|
# I'm not ready to publish this. It doesn't deal with array return |
1059
|
|
|
|
|
|
|
# values from the code or context. |
1060
|
|
|
|
|
|
|
|
1061
|
|
|
|
|
|
|
#line 1516 |
1062
|
|
|
|
|
|
|
|
1063
|
|
|
|
|
|
|
sub _try { |
1064
|
|
|
|
|
|
|
my( $self, $code, %opts ) = @_; |
1065
|
|
|
|
|
|
|
|
1066
|
|
|
|
|
|
|
my $error; |
1067
|
|
|
|
|
|
|
my $return; |
1068
|
|
|
|
|
|
|
{ |
1069
|
|
|
|
|
|
|
local $!; # eval can mess up $! |
1070
|
|
|
|
|
|
|
local $@; # don't set $@ in the test |
1071
|
|
|
|
|
|
|
local $SIG{__DIE__}; # don't trip an outside DIE handler. |
1072
|
|
|
|
|
|
|
$return = eval { $code->() }; |
1073
|
|
|
|
|
|
|
$error = $@; |
1074
|
|
|
|
|
|
|
} |
1075
|
|
|
|
|
|
|
|
1076
|
|
|
|
|
|
|
die $error if $error and $opts{die_on_fail}; |
1077
|
|
|
|
|
|
|
|
1078
|
|
|
|
|
|
|
return wantarray ? ( $return, $error ) : $return; |
1079
|
|
|
|
|
|
|
} |
1080
|
0
|
|
|
0
|
1
|
0
|
|
1081
|
0
|
|
|
|
|
0
|
#line 1545 |
1082
|
|
|
|
|
|
|
|
1083
|
0
|
0
|
0
|
|
|
0
|
sub is_fh { |
1084
|
|
|
|
|
|
|
my $self = shift; |
1085
|
0
|
|
0
|
|
|
0
|
my $maybe_fh = shift; |
1086
|
|
|
|
|
|
|
return 0 unless defined $maybe_fh; |
1087
|
0
|
|
|
|
|
0
|
|
1088
|
0
|
0
|
|
|
|
0
|
return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref |
1089
|
0
|
|
|
|
|
0
|
return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob |
1090
|
|
|
|
|
|
|
|
1091
|
|
|
|
|
|
|
return eval { $maybe_fh->isa("IO::Handle") } || |
1092
|
0
|
|
|
|
|
0
|
eval { tied($maybe_fh)->can('TIEHANDLE') }; |
1093
|
|
|
|
|
|
|
} |
1094
|
|
|
|
|
|
|
|
1095
|
|
|
|
|
|
|
#line 1588 |
1096
|
0
|
|
|
0
|
1
|
0
|
|
1097
|
0
|
|
|
|
|
0
|
sub level { |
1098
|
|
|
|
|
|
|
my( $self, $level ) = @_; |
1099
|
0
|
0
|
0
|
|
|
0
|
|
1100
|
|
|
|
|
|
|
if( defined $level ) { |
1101
|
0
|
|
0
|
|
|
0
|
$Level = $level; |
1102
|
|
|
|
|
|
|
} |
1103
|
0
|
|
|
|
|
0
|
return $Level; |
1104
|
0
|
0
|
|
|
|
0
|
} |
1105
|
0
|
|
|
|
|
0
|
|
1106
|
|
|
|
|
|
|
#line 1620 |
1107
|
|
|
|
|
|
|
|
1108
|
0
|
|
|
|
|
0
|
sub use_numbers { |
1109
|
|
|
|
|
|
|
my( $self, $use_nums ) = @_; |
1110
|
|
|
|
|
|
|
|
1111
|
|
|
|
|
|
|
if( defined $use_nums ) { |
1112
|
|
|
|
|
|
|
$self->{Use_Nums} = $use_nums; |
1113
|
|
|
|
|
|
|
} |
1114
|
|
|
|
|
|
|
return $self->{Use_Nums}; |
1115
|
|
|
|
|
|
|
} |
1116
|
|
|
|
|
|
|
|
1117
|
|
|
|
|
|
|
#line 1653 |
1118
|
|
|
|
|
|
|
|
1119
|
|
|
|
|
|
|
foreach my $attribute (qw(No_Header No_Ending No_Diag)) { |
1120
|
|
|
|
|
|
|
my $method = lc $attribute; |
1121
|
|
|
|
|
|
|
|
1122
|
|
|
|
|
|
|
my $code = sub { |
1123
|
|
|
|
|
|
|
my( $self, $no ) = @_; |
1124
|
|
|
|
|
|
|
|
1125
|
|
|
|
|
|
|
if( defined $no ) { |
1126
|
|
|
|
|
|
|
$self->{$attribute} = $no; |
1127
|
|
|
|
|
|
|
} |
1128
|
|
|
|
|
|
|
return $self->{$attribute}; |
1129
|
0
|
|
|
0
|
1
|
0
|
}; |
1130
|
|
|
|
|
|
|
|
1131
|
0
|
|
|
|
|
0
|
no strict 'refs'; ## no critic |
1132
|
0
|
|
|
|
|
0
|
*{ __PACKAGE__ . '::' . $method } = $code; |
1133
|
|
|
|
|
|
|
} |
1134
|
|
|
|
|
|
|
|
1135
|
|
|
|
|
|
|
#line 1706 |
1136
|
0
|
|
|
0
|
1
|
0
|
|
1137
|
|
|
|
|
|
|
sub diag { |
1138
|
0
|
|
|
|
|
0
|
my $self = shift; |
1139
|
0
|
|
|
|
|
0
|
|
1140
|
|
|
|
|
|
|
$self->_print_comment( $self->_diag_fh, @_ ); |
1141
|
|
|
|
|
|
|
} |
1142
|
|
|
|
|
|
|
|
1143
|
|
|
|
|
|
|
#line 1721 |
1144
|
|
|
|
|
|
|
|
1145
|
|
|
|
|
|
|
sub note { |
1146
|
|
|
|
|
|
|
my $self = shift; |
1147
|
|
|
|
|
|
|
|
1148
|
|
|
|
|
|
|
$self->_print_comment( $self->output, @_ ); |
1149
|
|
|
|
|
|
|
} |
1150
|
|
|
|
|
|
|
|
1151
|
|
|
|
|
|
|
sub _diag_fh { |
1152
|
|
|
|
|
|
|
my $self = shift; |
1153
|
|
|
|
|
|
|
|
1154
|
|
|
|
|
|
|
local $Level = $Level + 1; |
1155
|
|
|
|
|
|
|
return $self->in_todo ? $self->todo_output : $self->failure_output; |
1156
|
|
|
|
|
|
|
} |
1157
|
|
|
|
|
|
|
|
1158
|
1
|
|
|
1
|
1
|
2
|
sub _print_comment { |
1159
|
|
|
|
|
|
|
my( $self, $fh, @msgs ) = @_; |
1160
|
1
|
50
|
|
|
|
3
|
|
1161
|
0
|
|
|
|
|
0
|
return if $self->no_diag; |
1162
|
|
|
|
|
|
|
return unless @msgs; |
1163
|
|
|
|
|
|
|
|
1164
|
1
|
|
|
|
|
1
|
# Prevent printing headers when compiling (i.e. -c) |
1165
|
0
|
|
|
|
|
0
|
return if $^C; |
1166
|
|
|
|
|
|
|
|
1167
|
|
|
|
|
|
|
# Smash args together like print does. |
1168
|
|
|
|
|
|
|
# Convert undef to 'undef' so its readable. |
1169
|
1
|
|
|
|
|
1
|
my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs; |
|
1
|
|
|
|
|
10
|
|
1170
|
|
|
|
|
|
|
|
1171
|
1
|
|
|
|
|
3
|
# Escape the beginning, _print will take care of the rest. |
1172
|
|
|
|
|
|
|
$msg =~ s/^/# /; |
1173
|
|
|
|
|
|
|
|
1174
|
1
|
|
|
|
|
49
|
local $Level = $Level + 1; |
1175
|
|
|
|
|
|
|
$self->_print_to_fh( $fh, $msg ); |
1176
|
|
|
|
|
|
|
|
1177
|
|
|
|
|
|
|
return 0; |
1178
|
|
|
|
|
|
|
} |
1179
|
1
|
|
|
|
|
12
|
|
1180
|
|
|
|
|
|
|
#line 1771 |
1181
|
1
|
|
|
|
|
2
|
|
1182
|
1
|
|
|
|
|
4
|
sub explain { |
1183
|
|
|
|
|
|
|
my $self = shift; |
1184
|
|
|
|
|
|
|
|
1185
|
|
|
|
|
|
|
return map { |
1186
|
|
|
|
|
|
|
ref $_ |
1187
|
0
|
0
|
|
|
|
0
|
? do { |
1188
|
|
|
|
|
|
|
$self->_try(sub { require Data::Dumper }, die_on_fail => 1); |
1189
|
|
|
|
|
|
|
|
1190
|
|
|
|
|
|
|
my $dumper = Data::Dumper->new( [$_] ); |
1191
|
0
|
0
|
|
|
|
0
|
$dumper->Indent(1)->Terse(1); |
1192
|
|
|
|
|
|
|
$dumper->Sortkeys(1) if $dumper->can("Sortkeys"); |
1193
|
|
|
|
|
|
|
$dumper->Dump; |
1194
|
|
|
|
|
|
|
} |
1195
|
|
|
|
|
|
|
: $_ |
1196
|
|
|
|
|
|
|
} @_; |
1197
|
|
|
|
|
|
|
} |
1198
|
0
|
0
|
|
|
|
0
|
|
1199
|
0
|
|
|
|
|
0
|
#line 1800 |
1200
|
|
|
|
|
|
|
|
1201
|
0
|
0
|
|
|
|
0
|
sub _print { |
|
|
0
|
|
|
|
|
|
1202
|
0
|
|
|
|
|
0
|
my $self = shift; |
1203
|
|
|
|
|
|
|
return $self->_print_to_fh( $self->output, @_ ); |
1204
|
|
|
|
|
|
|
} |
1205
|
0
|
|
|
|
|
0
|
|
1206
|
|
|
|
|
|
|
sub _print_to_fh { |
1207
|
|
|
|
|
|
|
my( $self, $fh, @msgs ) = @_; |
1208
|
0
|
|
|
|
|
0
|
|
1209
|
|
|
|
|
|
|
# Prevent printing headers when only compiling. Mostly for when |
1210
|
|
|
|
|
|
|
# tests are deparsed with B::Deparse |
1211
|
0
|
|
|
|
|
0
|
return if $^C; |
1212
|
|
|
|
|
|
|
|
1213
|
|
|
|
|
|
|
my $msg = join '', @msgs; |
1214
|
|
|
|
|
|
|
my $indent = $self->_indent; |
1215
|
0
|
|
|
0
|
|
0
|
|
1216
|
|
|
|
|
|
|
local( $\, $", $, ) = ( undef, ' ', '' ); |
1217
|
0
|
0
|
|
|
|
0
|
|
1218
|
0
|
0
|
|
|
|
0
|
# Escape each line after the first with a # so we don't |
1219
|
|
|
|
|
|
|
# confuse Test::Harness. |
1220
|
0
|
|
|
|
|
0
|
$msg =~ s{\n(?!\z)}{\n$indent# }sg; |
1221
|
0
|
|
|
|
|
0
|
|
1222
|
|
|
|
|
|
|
# Stick a newline on the end if it needs it. |
1223
|
|
|
|
|
|
|
$msg .= "\n" unless $msg =~ /\n\z/; |
1224
|
|
|
|
|
|
|
|
1225
|
|
|
|
|
|
|
return print $fh $indent, $msg; |
1226
|
|
|
|
|
|
|
} |
1227
|
|
|
|
|
|
|
|
1228
|
|
|
|
|
|
|
#line 1860 |
1229
|
0
|
|
|
0
|
|
0
|
|
1230
|
|
|
|
|
|
|
sub output { |
1231
|
0
|
|
|
|
|
0
|
my( $self, $fh ) = @_; |
1232
|
|
|
|
|
|
|
|
1233
|
0
|
|
|
|
|
0
|
if( defined $fh ) { |
1234
|
0
|
0
|
0
|
|
|
0
|
$self->{Out_FH} = $self->_new_fh($fh); |
1235
|
|
|
|
|
|
|
} |
1236
|
0
|
|
|
|
|
0
|
return $self->{Out_FH}; |
1237
|
|
|
|
|
|
|
} |
1238
|
|
|
|
|
|
|
|
1239
|
|
|
|
|
|
|
sub failure_output { |
1240
|
|
|
|
|
|
|
my( $self, $fh ) = @_; |
1241
|
|
|
|
|
|
|
|
1242
|
|
|
|
|
|
|
if( defined $fh ) { |
1243
|
|
|
|
|
|
|
$self->{Fail_FH} = $self->_new_fh($fh); |
1244
|
|
|
|
|
|
|
} |
1245
|
|
|
|
|
|
|
return $self->{Fail_FH}; |
1246
|
|
|
|
|
|
|
} |
1247
|
|
|
|
|
|
|
|
1248
|
|
|
|
|
|
|
sub todo_output { |
1249
|
|
|
|
|
|
|
my( $self, $fh ) = @_; |
1250
|
|
|
|
|
|
|
|
1251
|
|
|
|
|
|
|
if( defined $fh ) { |
1252
|
|
|
|
|
|
|
$self->{Todo_FH} = $self->_new_fh($fh); |
1253
|
|
|
|
|
|
|
} |
1254
|
|
|
|
|
|
|
return $self->{Todo_FH}; |
1255
|
|
|
|
|
|
|
} |
1256
|
|
|
|
|
|
|
|
1257
|
|
|
|
|
|
|
sub _new_fh { |
1258
|
|
|
|
|
|
|
my $self = shift; |
1259
|
|
|
|
|
|
|
my($file_or_fh) = shift; |
1260
|
|
|
|
|
|
|
|
1261
|
0
|
|
|
0
|
1
|
0
|
my $fh; |
1262
|
|
|
|
|
|
|
if( $self->is_fh($file_or_fh) ) { |
1263
|
0
|
|
|
|
|
0
|
$fh = $file_or_fh; |
1264
|
|
|
|
|
|
|
} |
1265
|
0
|
0
|
|
|
|
0
|
elsif( ref $file_or_fh eq 'SCALAR' ) { |
1266
|
0
|
|
|
|
|
0
|
# Scalar refs as filehandles was added in 5.8. |
1267
|
0
|
|
|
|
|
0
|
if( $] >= 5.008 ) { |
1268
|
0
|
|
|
|
|
0
|
open $fh, ">>", $file_or_fh |
1269
|
|
|
|
|
|
|
or $self->croak("Can't open scalar ref $file_or_fh: $!"); |
1270
|
|
|
|
|
|
|
} |
1271
|
0
|
|
|
|
|
0
|
# Emulate scalar ref filehandles with a tie. |
1272
|
0
|
|
|
|
|
0
|
else { |
1273
|
|
|
|
|
|
|
$fh = Test::Builder::IO::Scalar->new($file_or_fh) |
1274
|
|
|
|
|
|
|
or $self->croak("Can't tie scalar ref $file_or_fh"); |
1275
|
|
|
|
|
|
|
} |
1276
|
|
|
|
|
|
|
} |
1277
|
|
|
|
|
|
|
else { |
1278
|
|
|
|
|
|
|
open $fh, ">", $file_or_fh |
1279
|
|
|
|
|
|
|
or $self->croak("Can't open test output log $file_or_fh: $!"); |
1280
|
|
|
|
|
|
|
_autoflush($fh); |
1281
|
1
|
|
|
1
|
|
4
|
} |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
459
|
|
1282
|
|
|
|
|
|
|
|
1283
|
|
|
|
|
|
|
return $fh; |
1284
|
|
|
|
|
|
|
} |
1285
|
|
|
|
|
|
|
|
1286
|
|
|
|
|
|
|
sub _autoflush { |
1287
|
|
|
|
|
|
|
my($fh) = shift; |
1288
|
|
|
|
|
|
|
my $old_fh = select $fh; |
1289
|
|
|
|
|
|
|
$| = 1; |
1290
|
|
|
|
|
|
|
select $old_fh; |
1291
|
|
|
|
|
|
|
|
1292
|
|
|
|
|
|
|
return; |
1293
|
|
|
|
|
|
|
} |
1294
|
|
|
|
|
|
|
|
1295
|
0
|
|
|
0
|
1
|
0
|
my( $Testout, $Testerr ); |
1296
|
0
|
|
0
|
|
|
0
|
|
1297
|
0
|
0
|
|
|
|
0
|
sub _dup_stdhandles { |
1298
|
0
|
|
|
|
|
0
|
my $self = shift; |
1299
|
|
|
|
|
|
|
|
1300
|
0
|
|
|
|
|
0
|
$self->_open_testhandles; |
1301
|
0
|
|
|
|
|
0
|
|
1302
|
|
|
|
|
|
|
# Set everything to unbuffered else plain prints to STDOUT will |
1303
|
0
|
|
|
|
|
0
|
# come out in the wrong order from our own prints. |
1304
|
|
|
|
|
|
|
_autoflush($Testout); |
1305
|
|
|
|
|
|
|
_autoflush( \*STDOUT ); |
1306
|
|
|
|
|
|
|
_autoflush($Testerr); |
1307
|
|
|
|
|
|
|
_autoflush( \*STDERR ); |
1308
|
|
|
|
|
|
|
|
1309
|
|
|
|
|
|
|
$self->reset_outputs; |
1310
|
|
|
|
|
|
|
|
1311
|
|
|
|
|
|
|
return; |
1312
|
|
|
|
|
|
|
} |
1313
|
0
|
|
|
|
|
0
|
|
1314
|
0
|
0
|
|
|
|
0
|
sub _open_testhandles { |
1315
|
0
|
|
|
|
|
0
|
my $self = shift; |
1316
|
0
|
0
|
|
|
|
0
|
|
1317
|
0
|
|
|
|
|
0
|
return if $self->{Opened_Testhandles}; |
1318
|
|
|
|
|
|
|
|
1319
|
0
|
|
|
|
|
0
|
# We dup STDOUT and STDERR so people can change them in their |
1320
|
|
|
|
|
|
|
# test suites while still getting normal test output. |
1321
|
0
|
|
|
|
|
0
|
open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT: $!"; |
1322
|
|
|
|
|
|
|
open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR: $!"; |
1323
|
|
|
|
|
|
|
|
1324
|
|
|
|
|
|
|
$self->_copy_io_layers( \*STDOUT, $Testout ); |
1325
|
|
|
|
|
|
|
$self->_copy_io_layers( \*STDERR, $Testerr ); |
1326
|
|
|
|
|
|
|
|
1327
|
|
|
|
|
|
|
$self->{Opened_Testhandles} = 1; |
1328
|
|
|
|
|
|
|
|
1329
|
|
|
|
|
|
|
return; |
1330
|
|
|
|
|
|
|
} |
1331
|
|
|
|
|
|
|
|
1332
|
|
|
|
|
|
|
sub _copy_io_layers { |
1333
|
|
|
|
|
|
|
my( $self, $src, $dst ) = @_; |
1334
|
|
|
|
|
|
|
|
1335
|
|
|
|
|
|
|
$self->_try( |
1336
|
|
|
|
|
|
|
sub { |
1337
|
0
|
|
|
0
|
1
|
0
|
require PerlIO; |
1338
|
0
|
|
0
|
|
|
0
|
my @src_layers = PerlIO::get_layers($src); |
1339
|
|
|
|
|
|
|
|
1340
|
0
|
|
|
|
|
0
|
_apply_layers($dst, @src_layers) if @src_layers; |
1341
|
0
|
|
|
|
|
0
|
} |
1342
|
|
|
|
|
|
|
); |
1343
|
0
|
|
|
|
|
0
|
|
1344
|
|
|
|
|
|
|
return; |
1345
|
|
|
|
|
|
|
} |
1346
|
|
|
|
|
|
|
|
1347
|
|
|
|
|
|
|
sub _apply_layers { |
1348
|
|
|
|
|
|
|
my ($fh, @layers) = @_; |
1349
|
|
|
|
|
|
|
my %seen; |
1350
|
|
|
|
|
|
|
my @unique = grep { $_ ne 'unix' and !$seen{$_}++ } @layers; |
1351
|
|
|
|
|
|
|
binmode($fh, join(":", "", "raw", @unique)); |
1352
|
|
|
|
|
|
|
} |
1353
|
0
|
|
|
|
|
0
|
|
1354
|
0
|
0
|
|
|
|
0
|
|
1355
|
0
|
|
|
|
|
0
|
#line 1993 |
1356
|
|
|
|
|
|
|
|
1357
|
0
|
|
|
|
|
0
|
sub reset_outputs { |
1358
|
|
|
|
|
|
|
my $self = shift; |
1359
|
0
|
|
|
|
|
0
|
|
1360
|
|
|
|
|
|
|
$self->output ($Testout); |
1361
|
|
|
|
|
|
|
$self->failure_output($Testerr); |
1362
|
|
|
|
|
|
|
$self->todo_output ($Testout); |
1363
|
|
|
|
|
|
|
|
1364
|
|
|
|
|
|
|
return; |
1365
|
|
|
|
|
|
|
} |
1366
|
|
|
|
|
|
|
|
1367
|
|
|
|
|
|
|
#line 2019 |
1368
|
|
|
|
|
|
|
|
1369
|
|
|
|
|
|
|
sub _message_at_caller { |
1370
|
|
|
|
|
|
|
my $self = shift; |
1371
|
|
|
|
|
|
|
|
1372
|
|
|
|
|
|
|
local $Level = $Level + 1; |
1373
|
|
|
|
|
|
|
my( $pack, $file, $line ) = $self->caller; |
1374
|
|
|
|
|
|
|
return join( "", @_ ) . " at $file line $line.\n"; |
1375
|
|
|
|
|
|
|
} |
1376
|
|
|
|
|
|
|
|
1377
|
|
|
|
|
|
|
sub carp { |
1378
|
|
|
|
|
|
|
my $self = shift; |
1379
|
|
|
|
|
|
|
return warn $self->_message_at_caller(@_); |
1380
|
|
|
|
|
|
|
} |
1381
|
|
|
|
|
|
|
|
1382
|
|
|
|
|
|
|
sub croak { |
1383
|
|
|
|
|
|
|
my $self = shift; |
1384
|
|
|
|
|
|
|
return die $self->_message_at_caller(@_); |
1385
|
|
|
|
|
|
|
} |
1386
|
|
|
|
|
|
|
|
1387
|
|
|
|
|
|
|
|
1388
|
|
|
|
|
|
|
#line 2059 |
1389
|
|
|
|
|
|
|
|
1390
|
|
|
|
|
|
|
sub current_test { |
1391
|
|
|
|
|
|
|
my( $self, $num ) = @_; |
1392
|
|
|
|
|
|
|
|
1393
|
|
|
|
|
|
|
lock( $self->{Curr_Test} ); |
1394
|
|
|
|
|
|
|
if( defined $num ) { |
1395
|
|
|
|
|
|
|
$self->{Curr_Test} = $num; |
1396
|
|
|
|
|
|
|
|
1397
|
|
|
|
|
|
|
# If the test counter is being pushed forward fill in the details. |
1398
|
|
|
|
|
|
|
my $test_results = $self->{Test_Results}; |
1399
|
|
|
|
|
|
|
if( $num > @$test_results ) { |
1400
|
|
|
|
|
|
|
my $start = @$test_results ? @$test_results : 0; |
1401
|
|
|
|
|
|
|
for( $start .. $num - 1 ) { |
1402
|
|
|
|
|
|
|
$test_results->[$_] = &share( |
1403
|
|
|
|
|
|
|
{ |
1404
|
|
|
|
|
|
|
'ok' => 1, |
1405
|
|
|
|
|
|
|
actual_ok => undef, |
1406
|
|
|
|
|
|
|
reason => 'incrementing test number', |
1407
|
|
|
|
|
|
|
type => 'unknown', |
1408
|
|
|
|
|
|
|
name => undef |
1409
|
|
|
|
|
|
|
} |
1410
|
|
|
|
|
|
|
); |
1411
|
|
|
|
|
|
|
} |
1412
|
|
|
|
|
|
|
} |
1413
|
|
|
|
|
|
|
# If backward, wipe history. Its their funeral. |
1414
|
|
|
|
|
|
|
elsif( $num < @$test_results ) { |
1415
|
|
|
|
|
|
|
$#{$test_results} = $num - 1; |
1416
|
|
|
|
|
|
|
} |
1417
|
0
|
|
|
0
|
1
|
0
|
} |
1418
|
0
|
|
|
|
|
0
|
return $self->{Curr_Test}; |
1419
|
|
|
|
|
|
|
} |
1420
|
0
|
0
|
|
|
|
0
|
|
1421
|
|
|
|
|
|
|
#line 2107 |
1422
|
0
|
|
|
|
|
0
|
|
1423
|
|
|
|
|
|
|
sub is_passing { |
1424
|
|
|
|
|
|
|
my $self = shift; |
1425
|
0
|
0
|
0
|
|
|
0
|
|
|
|
0
|
|
|
|
|
|
1426
|
0
|
|
|
|
|
0
|
if( @_ ) { |
1427
|
|
|
|
|
|
|
$self->{Is_Passing} = shift; |
1428
|
|
|
|
|
|
|
} |
1429
|
|
|
|
|
|
|
|
1430
|
|
|
|
|
|
|
return $self->{Is_Passing}; |
1431
|
|
|
|
|
|
|
} |
1432
|
|
|
|
|
|
|
|
1433
|
0
|
0
|
|
|
|
0
|
|
1434
|
|
|
|
|
|
|
#line 2129 |
1435
|
|
|
|
|
|
|
|
1436
|
0
|
|
|
|
|
0
|
sub summary { |
1437
|
|
|
|
|
|
|
my($self) = shift; |
1438
|
|
|
|
|
|
|
|
1439
|
|
|
|
|
|
|
return map { $_->{'ok'} } @{ $self->{Test_Results} }; |
1440
|
0
|
|
|
0
|
|
0
|
} |
1441
|
|
|
|
|
|
|
|
1442
|
|
|
|
|
|
|
#line 2184 |
1443
|
|
|
|
|
|
|
|
1444
|
0
|
0
|
|
|
|
0
|
sub details { |
1445
|
0
|
|
|
|
|
0
|
my $self = shift; |
1446
|
|
|
|
|
|
|
return @{ $self->{Test_Results} }; |
1447
|
|
|
|
|
|
|
} |
1448
|
|
|
|
|
|
|
|
1449
|
0
|
|
|
0
|
|
0
|
#line 2213 |
1450
|
|
|
|
|
|
|
|
1451
|
0
|
|
|
|
|
0
|
sub todo { |
1452
|
0
|
|
|
|
|
0
|
my( $self, $pack ) = @_; |
1453
|
0
|
0
|
|
|
|
0
|
|
1454
|
0
|
|
|
|
|
0
|
return $self->{Todo} if defined $self->{Todo}; |
1455
|
0
|
|
|
|
|
0
|
|
1456
|
0
|
|
|
|
|
0
|
local $Level = $Level + 1; |
1457
|
0
|
|
|
|
|
0
|
my $todo = $self->find_TODO($pack); |
1458
|
|
|
|
|
|
|
return $todo if defined $todo; |
1459
|
|
|
|
|
|
|
|
1460
|
|
|
|
|
|
|
return ''; |
1461
|
0
|
|
|
|
|
0
|
} |
|
0
|
|
|
|
|
0
|
|
1462
|
0
|
|
|
|
|
0
|
|
1463
|
|
|
|
|
|
|
#line 2240 |
1464
|
|
|
|
|
|
|
|
1465
|
|
|
|
|
|
|
sub find_TODO { |
1466
|
|
|
|
|
|
|
my( $self, $pack, $set, $new_value ) = @_; |
1467
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
1468
|
|
|
|
|
|
|
$pack = $pack || $self->caller(1) || $self->exported_to; |
1469
|
|
|
|
|
|
|
return unless $pack; |
1470
|
1
|
|
|
1
|
|
4
|
|
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
348
|
|
1471
|
|
|
|
|
|
|
no strict 'refs'; ## no critic |
1472
|
0
|
|
|
|
|
0
|
my $old_value = ${ $pack . '::TODO' }; |
1473
|
|
|
|
|
|
|
$set and ${ $pack . '::TODO' } = $new_value; |
1474
|
|
|
|
|
|
|
return $old_value; |
1475
|
0
|
0
|
|
|
|
0
|
} |
1476
|
|
|
|
|
|
|
|
1477
|
0
|
|
|
|
|
0
|
#line 2260 |
1478
|
0
|
|
|
|
|
0
|
|
1479
|
|
|
|
|
|
|
sub in_todo { |
1480
|
|
|
|
|
|
|
my $self = shift; |
1481
|
0
|
0
|
|
|
|
0
|
|
1482
|
0
|
0
|
|
|
|
0
|
local $Level = $Level + 1; |
1483
|
0
|
0
|
|
|
|
0
|
return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0; |
1484
|
|
|
|
|
|
|
} |
1485
|
0
|
|
|
|
|
0
|
|
1486
|
0
|
|
|
|
|
0
|
#line 2310 |
1487
|
|
|
|
|
|
|
|
1488
|
|
|
|
|
|
|
sub todo_start { |
1489
|
|
|
|
|
|
|
my $self = shift; |
1490
|
|
|
|
|
|
|
my $message = @_ ? shift : ''; |
1491
|
|
|
|
|
|
|
|
1492
|
|
|
|
|
|
|
$self->{Start_Todo}++; |
1493
|
0
|
|
|
|
|
0
|
if( $self->in_todo ) { |
1494
|
|
|
|
|
|
|
push @{ $self->{Todo_Stack} } => $self->todo; |
1495
|
|
|
|
|
|
|
} |
1496
|
|
|
|
|
|
|
$self->{Todo} = $message; |
1497
|
|
|
|
|
|
|
|
1498
|
|
|
|
|
|
|
return; |
1499
|
|
|
|
|
|
|
} |
1500
|
|
|
|
|
|
|
|
1501
|
|
|
|
|
|
|
#line 2332 |
1502
|
|
|
|
|
|
|
|
1503
|
|
|
|
|
|
|
sub todo_end { |
1504
|
|
|
|
|
|
|
my $self = shift; |
1505
|
|
|
|
|
|
|
|
1506
|
|
|
|
|
|
|
if( !$self->{Start_Todo} ) { |
1507
|
|
|
|
|
|
|
$self->croak('todo_end() called without todo_start()'); |
1508
|
|
|
|
|
|
|
} |
1509
|
|
|
|
|
|
|
|
1510
|
|
|
|
|
|
|
$self->{Start_Todo}--; |
1511
|
|
|
|
|
|
|
|
1512
|
|
|
|
|
|
|
if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) { |
1513
|
|
|
|
|
|
|
$self->{Todo} = pop @{ $self->{Todo_Stack} }; |
1514
|
|
|
|
|
|
|
} |
1515
|
|
|
|
|
|
|
else { |
1516
|
|
|
|
|
|
|
delete $self->{Todo}; |
1517
|
|
|
|
|
|
|
} |
1518
|
4
|
|
|
4
|
|
6
|
|
1519
|
|
|
|
|
|
|
return; |
1520
|
4
|
|
|
|
|
3
|
} |
1521
|
|
|
|
|
|
|
|
1522
|
|
|
|
|
|
|
#line 2365 |
1523
|
4
|
|
|
|
|
3
|
|
|
4
|
|
|
|
|
30
|
|
1524
|
4
|
|
|
|
|
4
|
sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms) |
1525
|
4
|
|
|
|
|
9
|
my( $self, $height ) = @_; |
1526
|
4
|
|
|
|
|
4
|
$height ||= 0; |
|
4
|
|
|
|
|
5
|
|
1527
|
4
|
|
|
|
|
13
|
|
1528
|
|
|
|
|
|
|
my $level = $self->level + $height + 1; |
1529
|
|
|
|
|
|
|
my @caller; |
1530
|
4
|
0
|
33
|
|
|
7
|
do { |
1531
|
|
|
|
|
|
|
@caller = CORE::caller( $level ); |
1532
|
4
|
50
|
|
|
|
11
|
$level--; |
1533
|
|
|
|
|
|
|
} until @caller; |
1534
|
|
|
|
|
|
|
return wantarray ? @caller : $caller[0]; |
1535
|
|
|
|
|
|
|
} |
1536
|
|
|
|
|
|
|
|
1537
|
|
|
|
|
|
|
#line 2382 |
1538
|
|
|
|
|
|
|
|
1539
|
|
|
|
|
|
|
#line 2396 |
1540
|
|
|
|
|
|
|
|
1541
|
|
|
|
|
|
|
#'# |
1542
|
|
|
|
|
|
|
sub _sanity_check { |
1543
|
|
|
|
|
|
|
my $self = shift; |
1544
|
|
|
|
|
|
|
|
1545
|
|
|
|
|
|
|
$self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' ); |
1546
|
|
|
|
|
|
|
$self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} }, |
1547
|
3
|
|
|
3
|
1
|
2
|
'Somehow you got a different number of results than tests ran!' ); |
1548
|
3
|
|
|
|
|
3
|
|
1549
|
3
|
50
|
|
|
|
4
|
return; |
1550
|
|
|
|
|
|
|
} |
1551
|
3
|
50
|
|
|
|
7
|
|
1552
|
0
|
0
|
|
|
|
0
|
#line 2417 |
1553
|
|
|
|
|
|
|
|
1554
|
|
|
|
|
|
|
sub _whoa { |
1555
|
0
|
|
0
|
|
|
0
|
my( $self, $check, $desc ) = @_; |
1556
|
|
|
|
|
|
|
if($check) { |
1557
|
|
|
|
|
|
|
local $Level = $Level + 1; |
1558
|
|
|
|
|
|
|
$self->croak(<<"WHOA"); |
1559
|
|
|
|
|
|
|
WHOA! $desc |
1560
|
|
|
|
|
|
|
This should never happen! Please contact the author immediately! |
1561
|
|
|
|
|
|
|
WHOA |
1562
|
|
|
|
|
|
|
} |
1563
|
|
|
|
|
|
|
|
1564
|
|
|
|
|
|
|
return; |
1565
|
|
|
|
|
|
|
} |
1566
|
|
|
|
|
|
|
|
1567
|
|
|
|
|
|
|
#line 2441 |
1568
|
|
|
|
|
|
|
|
1569
|
|
|
|
|
|
|
sub _my_exit { |
1570
|
|
|
|
|
|
|
$? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars) |
1571
|
|
|
|
|
|
|
|
1572
|
|
|
|
|
|
|
return 1; |
1573
|
|
|
|
|
|
|
} |
1574
|
|
|
|
|
|
|
|
1575
|
|
|
|
|
|
|
#line 2453 |
1576
|
|
|
|
|
|
|
|
1577
|
|
|
|
|
|
|
sub _ending { |
1578
|
|
|
|
|
|
|
my $self = shift; |
1579
|
|
|
|
|
|
|
return if $self->no_ending; |
1580
|
|
|
|
|
|
|
return if $self->{Ending}++; |
1581
|
|
|
|
|
|
|
|
1582
|
|
|
|
|
|
|
my $real_exit_code = $?; |
1583
|
|
|
|
|
|
|
|
1584
|
|
|
|
|
|
|
# Don't bother with an ending if this is a forked copy. Only the parent |
1585
|
|
|
|
|
|
|
# should do the ending. |
1586
|
|
|
|
|
|
|
if( $self->{Original_Pid} != $$ ) { |
1587
|
|
|
|
|
|
|
return; |
1588
|
|
|
|
|
|
|
} |
1589
|
|
|
|
|
|
|
|
1590
|
2
|
|
|
2
|
1
|
2
|
# Ran tests but never declared a plan or hit done_testing |
1591
|
|
|
|
|
|
|
if( !$self->{Have_Plan} and $self->{Curr_Test} ) { |
1592
|
2
|
50
|
|
|
|
3
|
$self->is_passing(0); |
1593
|
0
|
|
|
|
|
0
|
$self->diag("Tests were run but no plan was declared and done_testing() was not seen."); |
1594
|
|
|
|
|
|
|
|
1595
|
2
|
|
|
|
|
4
|
if($real_exit_code) { |
1596
|
|
|
|
|
|
|
$self->diag(<<"FAIL"); |
1597
|
|
|
|
|
|
|
Looks like your test exited with $real_exit_code just after $self->{Curr_Test}. |
1598
|
|
|
|
|
|
|
FAIL |
1599
|
|
|
|
|
|
|
$self->is_passing(0); |
1600
|
|
|
|
|
|
|
_my_exit($real_exit_code) && return; |
1601
|
|
|
|
|
|
|
} |
1602
|
|
|
|
|
|
|
|
1603
|
|
|
|
|
|
|
# But if the tests ran, handle exit code. |
1604
|
|
|
|
|
|
|
my $test_results = $self->{Test_Results}; |
1605
|
|
|
|
|
|
|
if(@$test_results) { |
1606
|
|
|
|
|
|
|
my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ]; |
1607
|
|
|
|
|
|
|
if ($num_failed > 0) { |
1608
|
|
|
|
|
|
|
|
1609
|
|
|
|
|
|
|
my $exit_code = $num_failed <= 254 ? $num_failed : 254; |
1610
|
|
|
|
|
|
|
_my_exit($exit_code) && return; |
1611
|
|
|
|
|
|
|
} |
1612
|
|
|
|
|
|
|
} |
1613
|
|
|
|
|
|
|
_my_exit(254) && return; |
1614
|
|
|
|
|
|
|
} |
1615
|
|
|
|
|
|
|
|
1616
|
|
|
|
|
|
|
# Exit if plan() was never called. This is so "require Test::Simple" |
1617
|
|
|
|
|
|
|
# doesn't puke. |
1618
|
|
|
|
|
|
|
if( !$self->{Have_Plan} ) { |
1619
|
|
|
|
|
|
|
return; |
1620
|
|
|
|
|
|
|
} |
1621
|
|
|
|
|
|
|
|
1622
|
0
|
|
|
0
|
1
|
0
|
# Don't do an ending if we bailed out. |
1623
|
|
|
|
|
|
|
if( $self->{Bailed_Out} ) { |
1624
|
0
|
0
|
|
|
|
0
|
$self->is_passing(0); |
1625
|
0
|
|
|
|
|
0
|
return; |
1626
|
|
|
|
|
|
|
} |
1627
|
0
|
|
|
|
|
0
|
# Figure out if we passed or failed and print helpful messages. |
1628
|
|
|
|
|
|
|
my $test_results = $self->{Test_Results}; |
1629
|
|
|
|
|
|
|
if(@$test_results) { |
1630
|
|
|
|
|
|
|
# The plan? We have no plan. |
1631
|
|
|
|
|
|
|
if( $self->{No_Plan} ) { |
1632
|
|
|
|
|
|
|
$self->_output_plan($self->{Curr_Test}) unless $self->no_header; |
1633
|
|
|
|
|
|
|
$self->{Expected_Tests} = $self->{Curr_Test}; |
1634
|
|
|
|
|
|
|
} |
1635
|
|
|
|
|
|
|
|
1636
|
|
|
|
|
|
|
# Auto-extended arrays and elements which aren't explicitly |
1637
|
|
|
|
|
|
|
# filled in with a shared reference will puke under 5.8.0 |
1638
|
|
|
|
|
|
|
# ithreads. So we have to fill them in by hand. :( |
1639
|
|
|
|
|
|
|
my $empty_result = &share( {} ); |
1640
|
|
|
|
|
|
|
for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) { |
1641
|
|
|
|
|
|
|
$test_results->[$idx] = $empty_result |
1642
|
|
|
|
|
|
|
unless defined $test_results->[$idx]; |
1643
|
|
|
|
|
|
|
} |
1644
|
|
|
|
|
|
|
|
1645
|
|
|
|
|
|
|
my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ]; |
1646
|
|
|
|
|
|
|
|
1647
|
|
|
|
|
|
|
my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests}; |
1648
|
|
|
|
|
|
|
|
1649
|
|
|
|
|
|
|
if( $num_extra != 0 ) { |
1650
|
|
|
|
|
|
|
my $s = $self->{Expected_Tests} == 1 ? '' : 's'; |
1651
|
|
|
|
|
|
|
$self->diag(<<"FAIL"); |
1652
|
|
|
|
|
|
|
Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}. |
1653
|
|
|
|
|
|
|
FAIL |
1654
|
|
|
|
|
|
|
$self->is_passing(0); |
1655
|
|
|
|
|
|
|
} |
1656
|
|
|
|
|
|
|
|
1657
|
|
|
|
|
|
|
if($num_failed) { |
1658
|
3
|
|
|
3
|
|
4
|
my $num_tests = $self->{Curr_Test}; |
1659
|
|
|
|
|
|
|
my $s = $num_failed == 1 ? '' : 's'; |
1660
|
3
|
50
|
|
|
|
7
|
|
1661
|
0
|
|
|
|
|
0
|
my $qualifier = $num_extra == 0 ? '' : ' run'; |
1662
|
|
|
|
|
|
|
|
1663
|
3
|
|
|
|
|
12
|
$self->diag(<<"FAIL"); |
1664
|
|
|
|
|
|
|
Looks like you failed $num_failed test$s of $num_tests$qualifier. |
1665
|
|
|
|
|
|
|
FAIL |
1666
|
1
|
|
|
1
|
|
3
|
$self->is_passing(0); |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
1221
|
|
1667
|
|
|
|
|
|
|
} |
1668
|
|
|
|
|
|
|
|
1669
|
|
|
|
|
|
|
if($real_exit_code) { |
1670
|
|
|
|
|
|
|
$self->diag(<<"FAIL"); |
1671
|
|
|
|
|
|
|
Looks like your test exited with $real_exit_code just after $self->{Curr_Test}. |
1672
|
|
|
|
|
|
|
FAIL |
1673
|
|
|
|
|
|
|
$self->is_passing(0); |
1674
|
|
|
|
|
|
|
_my_exit($real_exit_code) && return; |
1675
|
|
|
|
|
|
|
} |
1676
|
|
|
|
|
|
|
|
1677
|
|
|
|
|
|
|
my $exit_code; |
1678
|
|
|
|
|
|
|
if($num_failed) { |
1679
|
|
|
|
|
|
|
$exit_code = $num_failed <= 254 ? $num_failed : 254; |
1680
|
|
|
|
|
|
|
} |
1681
|
|
|
|
|
|
|
elsif( $num_extra != 0 ) { |
1682
|
|
|
|
|
|
|
$exit_code = 255; |
1683
|
|
|
|
|
|
|
} |
1684
|
|
|
|
|
|
|
else { |
1685
|
|
|
|
|
|
|
$exit_code = 0; |
1686
|
|
|
|
|
|
|
} |
1687
|
|
|
|
|
|
|
|
1688
|
|
|
|
|
|
|
_my_exit($exit_code) && return; |
1689
|
|
|
|
|
|
|
} |
1690
|
|
|
|
|
|
|
elsif( $self->{Skip_All} ) { |
1691
|
|
|
|
|
|
|
_my_exit(0) && return; |
1692
|
|
|
|
|
|
|
} |
1693
|
|
|
|
|
|
|
elsif($real_exit_code) { |
1694
|
|
|
|
|
|
|
$self->diag(<<"FAIL"); |
1695
|
|
|
|
|
|
|
Looks like your test exited with $real_exit_code before it could output anything. |
1696
|
|
|
|
|
|
|
FAIL |
1697
|
|
|
|
|
|
|
$self->is_passing(0); |
1698
|
|
|
|
|
|
|
_my_exit($real_exit_code) && return; |
1699
|
|
|
|
|
|
|
} |
1700
|
|
|
|
|
|
|
else { |
1701
|
|
|
|
|
|
|
$self->diag("No tests run!\n"); |
1702
|
|
|
|
|
|
|
$self->is_passing(0); |
1703
|
|
|
|
|
|
|
_my_exit(255) && return; |
1704
|
|
|
|
|
|
|
} |
1705
|
|
|
|
|
|
|
|
1706
|
|
|
|
|
|
|
$self->is_passing(0); |
1707
|
|
|
|
|
|
|
$self->_whoa( 1, "We fell off the end of _ending()" ); |
1708
|
1
|
|
|
1
|
1
|
1
|
} |
1709
|
|
|
|
|
|
|
|
1710
|
1
|
|
|
|
|
3
|
END { |
1711
|
|
|
|
|
|
|
$Test->_ending if defined $Test; |
1712
|
|
|
|
|
|
|
} |
1713
|
|
|
|
|
|
|
|
1714
|
|
|
|
|
|
|
#line 2669 |
1715
|
|
|
|
|
|
|
|
1716
|
|
|
|
|
|
|
1; |
1717
|
|
|
|
|
|
|
|