line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
#line 1 |
2
|
|
|
|
|
|
|
package Test::Builder; |
3
|
2
|
|
|
2
|
|
33
|
|
|
2
|
|
|
|
|
8
|
|
|
2
|
|
|
|
|
102
|
|
4
|
|
|
|
|
|
|
use 5.004; |
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
# $^C was only introduced in 5.005-ish. We do this to prevent |
7
|
|
|
|
|
|
|
# use of uninitialized value warnings in older perls. |
8
|
|
|
|
|
|
|
$^C ||= 0; |
9
|
2
|
|
|
2
|
|
10
|
|
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
68
|
|
10
|
2
|
|
|
2
|
|
9
|
use strict; |
|
2
|
|
|
|
|
8
|
|
|
2
|
|
|
|
|
172
|
|
11
|
|
|
|
|
|
|
use vars qw($VERSION); |
12
|
|
|
|
|
|
|
$VERSION = '0.33'; |
13
|
|
|
|
|
|
|
$VERSION = eval $VERSION; # make the alpha version come out as a number |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
# Make Test::Builder thread-safe for ithreads. |
16
|
2
|
|
|
2
|
|
11
|
BEGIN { |
|
2
|
|
|
|
|
45
|
|
|
2
|
|
|
|
|
706
|
|
17
|
|
|
|
|
|
|
use Config; |
18
|
2
|
50
|
33
|
2
|
|
53
|
# Load threads::shared when threads are turned on |
|
|
|
33
|
|
|
|
|
19
|
0
|
|
|
|
|
0
|
if( $] >= 5.008 && $Config{useithreads} && $INC{'threads.pm'}) { |
20
|
|
|
|
|
|
|
require threads::shared; |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
# Hack around YET ANOTHER threads::shared bug. It would |
23
|
|
|
|
|
|
|
# occassionally forget the contents of the variable when sharing it. |
24
|
|
|
|
|
|
|
# So we first copy the data, then share, then put our copy back. |
25
|
0
|
|
|
|
|
0
|
*share = sub (\[$@%]) { |
26
|
0
|
|
|
|
|
0
|
my $type = ref $_[0]; |
27
|
|
|
|
|
|
|
my $data; |
28
|
0
|
0
|
|
|
|
0
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
29
|
0
|
|
|
|
|
0
|
if( $type eq 'HASH' ) { |
|
0
|
|
|
|
|
0
|
|
30
|
|
|
|
|
|
|
%$data = %{$_[0]}; |
31
|
|
|
|
|
|
|
} |
32
|
0
|
|
|
|
|
0
|
elsif( $type eq 'ARRAY' ) { |
|
0
|
|
|
|
|
0
|
|
33
|
|
|
|
|
|
|
@$data = @{$_[0]}; |
34
|
|
|
|
|
|
|
} |
35
|
0
|
|
|
|
|
0
|
elsif( $type eq 'SCALAR' ) { |
|
0
|
|
|
|
|
0
|
|
36
|
|
|
|
|
|
|
$$data = ${$_[0]}; |
37
|
|
|
|
|
|
|
} |
38
|
0
|
|
|
|
|
0
|
else { |
39
|
|
|
|
|
|
|
die "Unknown type: ".$type; |
40
|
|
|
|
|
|
|
} |
41
|
0
|
|
|
|
|
0
|
|
42
|
|
|
|
|
|
|
$_[0] = &threads::shared::share($_[0]); |
43
|
0
|
0
|
|
|
|
0
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
44
|
0
|
|
|
|
|
0
|
if( $type eq 'HASH' ) { |
|
0
|
|
|
|
|
0
|
|
45
|
|
|
|
|
|
|
%{$_[0]} = %$data; |
46
|
|
|
|
|
|
|
} |
47
|
0
|
|
|
|
|
0
|
elsif( $type eq 'ARRAY' ) { |
|
0
|
|
|
|
|
0
|
|
48
|
|
|
|
|
|
|
@{$_[0]} = @$data; |
49
|
|
|
|
|
|
|
} |
50
|
0
|
|
|
|
|
0
|
elsif( $type eq 'SCALAR' ) { |
|
0
|
|
|
|
|
0
|
|
51
|
|
|
|
|
|
|
${$_[0]} = $$data; |
52
|
|
|
|
|
|
|
} |
53
|
0
|
|
|
|
|
0
|
else { |
54
|
|
|
|
|
|
|
die "Unknown type: ".$type; |
55
|
|
|
|
|
|
|
} |
56
|
0
|
|
|
|
|
0
|
|
57
|
0
|
|
|
|
|
0
|
return $_[0]; |
58
|
|
|
|
|
|
|
}; |
59
|
|
|
|
|
|
|
} |
60
|
|
|
|
|
|
|
# 5.8.0's threads::shared is busted when threads are off. |
61
|
|
|
|
|
|
|
# We emulate it here. |
62
|
2
|
|
|
6
|
|
23
|
else { |
|
6
|
|
|
|
|
15
|
|
63
|
2
|
|
|
1
|
|
240
|
*share = sub { return $_[0] }; |
|
1
|
|
|
|
|
2
|
|
64
|
|
|
|
|
|
|
*lock = sub { 0 }; |
65
|
|
|
|
|
|
|
} |
66
|
|
|
|
|
|
|
} |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
#line 127 |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
my $Test = Test::Builder->new; |
72
|
|
|
|
|
|
|
sub new { |
73
|
|
|
|
|
|
|
my($class) = shift; |
74
|
|
|
|
|
|
|
$Test ||= $class->create; |
75
|
|
|
|
|
|
|
return $Test; |
76
|
|
|
|
|
|
|
} |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
#line 149 |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
sub create { |
82
|
|
|
|
|
|
|
my $class = shift; |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
my $self = bless {}, $class; |
85
|
|
|
|
|
|
|
$self->reset; |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
return $self; |
88
|
|
|
|
|
|
|
} |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
#line 168 |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
use vars qw($Level); |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
sub reset { |
95
|
|
|
|
|
|
|
my ($self) = @_; |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
# We leave this a global because it has to be localized and localizing |
98
|
|
|
|
|
|
|
# hash keys is just asking for pain. Also, it was documented. |
99
|
|
|
|
|
|
|
$Level = 1; |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
$self->{Test_Died} = 0; |
102
|
|
|
|
|
|
|
$self->{Have_Plan} = 0; |
103
|
|
|
|
|
|
|
$self->{No_Plan} = 0; |
104
|
|
|
|
|
|
|
$self->{Original_Pid} = $$; |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
share($self->{Curr_Test}); |
107
|
|
|
|
|
|
|
$self->{Curr_Test} = 0; |
108
|
|
|
|
|
|
|
$self->{Test_Results} = &share([]); |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
$self->{Exported_To} = undef; |
111
|
|
|
|
|
|
|
$self->{Expected_Tests} = 0; |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
$self->{Skip_All} = 0; |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
$self->{Use_Nums} = 1; |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
$self->{No_Header} = 0; |
118
|
|
|
|
|
|
|
$self->{No_Ending} = 0; |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
$self->_dup_stdhandles unless $^C; |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
return undef; |
123
|
|
|
|
|
|
|
} |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
#line 220 |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
sub exported_to { |
128
|
|
|
|
|
|
|
my($self, $pack) = @_; |
129
|
|
|
|
|
|
|
|
130
|
8
|
|
|
8
|
1
|
24
|
if( defined $pack ) { |
131
|
8
|
|
66
|
|
|
58
|
$self->{Exported_To} = $pack; |
132
|
8
|
|
|
|
|
28
|
} |
133
|
|
|
|
|
|
|
return $self->{Exported_To}; |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
#line 242 |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
sub plan { |
139
|
|
|
|
|
|
|
my($self, $cmd, $arg) = @_; |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
return unless $cmd; |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
if( $self->{Have_Plan} ) { |
144
|
|
|
|
|
|
|
die sprintf "You tried to plan twice! Second plan at %s line %d\n", |
145
|
|
|
|
|
|
|
($self->caller)[1,2]; |
146
|
|
|
|
|
|
|
} |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
if( $cmd eq 'no_plan' ) { |
149
|
|
|
|
|
|
|
$self->no_plan; |
150
|
|
|
|
|
|
|
} |
151
|
2
|
|
|
2
|
1
|
7
|
elsif( $cmd eq 'skip_all' ) { |
152
|
|
|
|
|
|
|
return $self->skip_all($arg); |
153
|
2
|
|
|
|
|
7
|
} |
154
|
2
|
|
|
|
|
7
|
elsif( $cmd eq 'tests' ) { |
155
|
|
|
|
|
|
|
if( $arg ) { |
156
|
2
|
|
|
|
|
7
|
return $self->expected_tests($arg); |
157
|
|
|
|
|
|
|
} |
158
|
|
|
|
|
|
|
elsif( !defined $arg ) { |
159
|
|
|
|
|
|
|
die "Got an undefined number of tests. Looks like you tried to ". |
160
|
|
|
|
|
|
|
"say how many tests you plan to run but made a mistake.\n"; |
161
|
|
|
|
|
|
|
} |
162
|
|
|
|
|
|
|
elsif( !$arg ) { |
163
|
|
|
|
|
|
|
die "You said to run 0 tests! You've got to run something.\n"; |
164
|
|
|
|
|
|
|
} |
165
|
|
|
|
|
|
|
} |
166
|
|
|
|
|
|
|
else { |
167
|
|
|
|
|
|
|
require Carp; |
168
|
|
|
|
|
|
|
my @args = grep { defined } ($cmd, $arg); |
169
|
2
|
|
|
2
|
|
10
|
Carp::croak("plan() doesn't understand @args"); |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
8200
|
|
170
|
|
|
|
|
|
|
} |
171
|
|
|
|
|
|
|
|
172
|
2
|
|
|
2
|
1
|
4
|
return 1; |
173
|
|
|
|
|
|
|
} |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
#line 289 |
176
|
2
|
|
|
|
|
4
|
|
177
|
|
|
|
|
|
|
sub expected_tests { |
178
|
2
|
|
|
|
|
15
|
my $self = shift; |
179
|
2
|
|
|
|
|
5
|
my($max) = @_; |
180
|
2
|
|
|
|
|
4
|
|
181
|
2
|
|
|
|
|
24
|
if( @_ ) { |
182
|
|
|
|
|
|
|
die "Number of tests must be a postive integer. You gave it '$max'.\n" |
183
|
2
|
|
|
|
|
9
|
unless $max =~ /^\+?\d+$/ and $max > 0; |
184
|
2
|
|
|
|
|
4
|
|
185
|
2
|
|
|
|
|
6
|
$self->{Expected_Tests} = $max; |
186
|
|
|
|
|
|
|
$self->{Have_Plan} = 1; |
187
|
2
|
|
|
|
|
8
|
|
188
|
2
|
|
|
|
|
4
|
$self->_print("1..$max\n") unless $self->no_header; |
189
|
|
|
|
|
|
|
} |
190
|
2
|
|
|
|
|
6
|
return $self->{Expected_Tests}; |
191
|
|
|
|
|
|
|
} |
192
|
2
|
|
|
|
|
3
|
|
193
|
|
|
|
|
|
|
|
194
|
2
|
|
|
|
|
4
|
#line 314 |
195
|
2
|
|
|
|
|
4
|
|
196
|
|
|
|
|
|
|
sub no_plan { |
197
|
2
|
50
|
|
|
|
11
|
my $self = shift; |
198
|
|
|
|
|
|
|
|
199
|
2
|
|
|
|
|
3
|
$self->{No_Plan} = 1; |
200
|
|
|
|
|
|
|
$self->{Have_Plan} = 1; |
201
|
|
|
|
|
|
|
} |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
#line 329 |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
sub has_plan { |
206
|
|
|
|
|
|
|
my $self = shift; |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
return($self->{Expected_Tests}) if $self->{Expected_Tests}; |
209
|
|
|
|
|
|
|
return('no_plan') if $self->{No_Plan}; |
210
|
|
|
|
|
|
|
return(undef); |
211
|
|
|
|
|
|
|
}; |
212
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
#line 347 |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
sub skip_all { |
217
|
|
|
|
|
|
|
my($self, $reason) = @_; |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
my $out = "1..0"; |
220
|
|
|
|
|
|
|
$out .= " # Skip $reason" if $reason; |
221
|
|
|
|
|
|
|
$out .= "\n"; |
222
|
4
|
|
|
4
|
1
|
13
|
|
223
|
|
|
|
|
|
|
$self->{Skip_All} = 1; |
224
|
4
|
50
|
|
|
|
20
|
|
225
|
4
|
|
|
|
|
14
|
$self->_print($out) unless $self->no_header; |
226
|
|
|
|
|
|
|
exit(0); |
227
|
4
|
|
|
|
|
15
|
} |
228
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
#line 380 |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
sub ok { |
232
|
|
|
|
|
|
|
my($self, $test, $name) = @_; |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
# $test might contain an object which we don't want to accidentally |
235
|
|
|
|
|
|
|
# store, so we turn it into a boolean. |
236
|
|
|
|
|
|
|
$test = $test ? 1 : 0; |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
unless( $self->{Have_Plan} ) { |
239
|
|
|
|
|
|
|
require Carp; |
240
|
|
|
|
|
|
|
Carp::croak("You tried to run a test without a plan! Gotta have a plan."); |
241
|
|
|
|
|
|
|
} |
242
|
|
|
|
|
|
|
|
243
|
|
|
|
|
|
|
lock $self->{Curr_Test}; |
244
|
2
|
|
|
2
|
1
|
5
|
$self->{Curr_Test}++; |
245
|
|
|
|
|
|
|
|
246
|
2
|
100
|
|
|
|
7
|
# In case $name is a string overloaded object, force it to stringify. |
247
|
|
|
|
|
|
|
$self->_unoverload_str(\$name); |
248
|
1
|
50
|
|
|
|
5
|
|
249
|
0
|
|
|
|
|
0
|
$self->diag(<
|
250
|
|
|
|
|
|
|
You named your test '$name'. You shouldn't use numbers for your test names. |
251
|
|
|
|
|
|
|
Very confusing. |
252
|
|
|
|
|
|
|
ERR |
253
|
1
|
50
|
|
|
|
8
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
254
|
0
|
|
|
|
|
0
|
my($pack, $file, $line) = $self->caller; |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
my $todo = $self->todo($pack); |
257
|
0
|
|
|
|
|
0
|
$self->_unoverload_str(\$todo); |
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
my $out; |
260
|
1
|
50
|
|
|
|
4
|
my $result = &share({}); |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
261
|
1
|
|
|
|
|
5
|
|
262
|
|
|
|
|
|
|
unless( $test ) { |
263
|
|
|
|
|
|
|
$out .= "not "; |
264
|
0
|
|
|
|
|
0
|
@$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 ); |
265
|
|
|
|
|
|
|
} |
266
|
|
|
|
|
|
|
else { |
267
|
|
|
|
|
|
|
@$result{ 'ok', 'actual_ok' } = ( 1, $test ); |
268
|
0
|
|
|
|
|
0
|
} |
269
|
|
|
|
|
|
|
|
270
|
|
|
|
|
|
|
$out .= "ok"; |
271
|
|
|
|
|
|
|
$out .= " $self->{Curr_Test}" if $self->use_numbers; |
272
|
0
|
|
|
|
|
0
|
|
273
|
0
|
|
|
|
|
0
|
if( defined $name ) { |
|
0
|
|
|
|
|
0
|
|
274
|
0
|
|
|
|
|
0
|
$name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. |
275
|
|
|
|
|
|
|
$out .= " - $name"; |
276
|
|
|
|
|
|
|
$result->{name} = $name; |
277
|
0
|
|
|
|
|
0
|
} |
278
|
|
|
|
|
|
|
else { |
279
|
|
|
|
|
|
|
$result->{name} = ''; |
280
|
|
|
|
|
|
|
} |
281
|
|
|
|
|
|
|
|
282
|
|
|
|
|
|
|
if( $todo ) { |
283
|
|
|
|
|
|
|
$out .= " # TODO $todo"; |
284
|
|
|
|
|
|
|
$result->{reason} = $todo; |
285
|
|
|
|
|
|
|
$result->{type} = 'todo'; |
286
|
|
|
|
|
|
|
} |
287
|
|
|
|
|
|
|
else { |
288
|
|
|
|
|
|
|
$result->{reason} = ''; |
289
|
|
|
|
|
|
|
$result->{type} = ''; |
290
|
|
|
|
|
|
|
} |
291
|
1
|
|
|
1
|
1
|
2
|
|
292
|
1
|
|
|
|
|
3
|
$self->{Test_Results}[$self->{Curr_Test}-1] = $result; |
293
|
|
|
|
|
|
|
$out .= "\n"; |
294
|
1
|
50
|
|
|
|
4
|
|
295
|
1
|
50
|
33
|
|
|
14
|
$self->_print($out); |
296
|
|
|
|
|
|
|
|
297
|
|
|
|
|
|
|
unless( $test ) { |
298
|
1
|
|
|
|
|
3
|
my $msg = $todo ? "Failed (TODO)" : "Failed"; |
299
|
1
|
|
|
|
|
2
|
$self->_print_diag("\n") if $ENV{HARNESS_ACTIVE}; |
300
|
|
|
|
|
|
|
|
301
|
1
|
50
|
|
|
|
4
|
if( defined $name ) { |
302
|
|
|
|
|
|
|
$self->diag(qq[ $msg test '$name'\n]); |
303
|
1
|
|
|
|
|
5
|
$self->diag(qq[ in $file at line $line.\n]); |
304
|
|
|
|
|
|
|
} |
305
|
|
|
|
|
|
|
else { |
306
|
|
|
|
|
|
|
$self->diag(qq[ $msg test in $file at line $line.\n]); |
307
|
|
|
|
|
|
|
} |
308
|
|
|
|
|
|
|
} |
309
|
|
|
|
|
|
|
|
310
|
|
|
|
|
|
|
return $test ? 1 : 0; |
311
|
|
|
|
|
|
|
} |
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
|
314
|
|
|
|
|
|
|
sub _unoverload { |
315
|
|
|
|
|
|
|
my $self = shift; |
316
|
0
|
|
|
0
|
1
|
0
|
my $type = shift; |
317
|
|
|
|
|
|
|
|
318
|
0
|
|
|
|
|
0
|
local($@,$!); |
319
|
0
|
|
|
|
|
0
|
|
320
|
|
|
|
|
|
|
eval { require overload } || return; |
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
foreach my $thing (@_) { |
323
|
|
|
|
|
|
|
eval { |
324
|
|
|
|
|
|
|
if( _is_object($$thing) ) { |
325
|
|
|
|
|
|
|
if( my $string_meth = overload::Method($$thing, $type) ) { |
326
|
|
|
|
|
|
|
$$thing = $$thing->$string_meth(); |
327
|
|
|
|
|
|
|
} |
328
|
|
|
|
|
|
|
} |
329
|
|
|
|
|
|
|
}; |
330
|
|
|
|
|
|
|
} |
331
|
0
|
|
|
0
|
1
|
0
|
} |
332
|
|
|
|
|
|
|
|
333
|
0
|
0
|
|
|
|
0
|
|
334
|
0
|
0
|
|
|
|
0
|
sub _is_object { |
335
|
0
|
|
|
|
|
0
|
my $thing = shift; |
336
|
|
|
|
|
|
|
|
337
|
|
|
|
|
|
|
return eval { ref $thing && $thing->isa('UNIVERSAL') } ? 1 : 0; |
338
|
|
|
|
|
|
|
} |
339
|
|
|
|
|
|
|
|
340
|
|
|
|
|
|
|
|
341
|
|
|
|
|
|
|
sub _unoverload_str { |
342
|
|
|
|
|
|
|
my $self = shift; |
343
|
|
|
|
|
|
|
|
344
|
|
|
|
|
|
|
$self->_unoverload(q[""], @_); |
345
|
|
|
|
|
|
|
} |
346
|
|
|
|
|
|
|
|
347
|
|
|
|
|
|
|
sub _unoverload_num { |
348
|
|
|
|
|
|
|
my $self = shift; |
349
|
1
|
|
|
1
|
1
|
1
|
|
350
|
|
|
|
|
|
|
$self->_unoverload('0+', @_); |
351
|
1
|
|
|
|
|
2
|
|
352
|
1
|
50
|
|
|
|
3
|
for my $val (@_) { |
353
|
1
|
|
|
|
|
3
|
next unless $self->_is_dualvar($$val); |
354
|
|
|
|
|
|
|
$$val = $$val+0; |
355
|
1
|
|
|
|
|
2
|
} |
356
|
|
|
|
|
|
|
} |
357
|
1
|
50
|
|
|
|
3
|
|
358
|
1
|
|
|
|
|
1275
|
|
359
|
|
|
|
|
|
|
# This is a hack to detect a dualvar such as $! |
360
|
|
|
|
|
|
|
sub _is_dualvar { |
361
|
|
|
|
|
|
|
my($self, $val) = @_; |
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
local $^W = 0; |
364
|
|
|
|
|
|
|
my $numval = $val+0; |
365
|
|
|
|
|
|
|
return 1 if $numval != 0 and $numval ne $val; |
366
|
|
|
|
|
|
|
} |
367
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
|
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
#line 535 |
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
sub is_eq { |
373
|
|
|
|
|
|
|
my($self, $got, $expect, $name) = @_; |
374
|
|
|
|
|
|
|
local $Level = $Level + 1; |
375
|
|
|
|
|
|
|
|
376
|
|
|
|
|
|
|
$self->_unoverload_str(\$got, \$expect); |
377
|
|
|
|
|
|
|
|
378
|
|
|
|
|
|
|
if( !defined $got || !defined $expect ) { |
379
|
|
|
|
|
|
|
# undef only matches undef and nothing else |
380
|
|
|
|
|
|
|
my $test = !defined $got && !defined $expect; |
381
|
|
|
|
|
|
|
|
382
|
1
|
|
|
1
|
1
|
3
|
$self->ok($test, $name); |
383
|
|
|
|
|
|
|
$self->_is_diag($got, 'eq', $expect) unless $test; |
384
|
|
|
|
|
|
|
return $test; |
385
|
|
|
|
|
|
|
} |
386
|
1
|
50
|
|
|
|
5
|
|
387
|
|
|
|
|
|
|
return $self->cmp_ok($got, 'eq', $expect, $name); |
388
|
1
|
50
|
|
|
|
9
|
} |
389
|
0
|
|
|
|
|
0
|
|
390
|
0
|
|
|
|
|
0
|
sub is_num { |
391
|
|
|
|
|
|
|
my($self, $got, $expect, $name) = @_; |
392
|
|
|
|
|
|
|
local $Level = $Level + 1; |
393
|
1
|
|
|
|
|
6
|
|
394
|
1
|
|
|
|
|
3
|
$self->_unoverload_num(\$got, \$expect); |
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
if( !defined $got || !defined $expect ) { |
397
|
1
|
|
|
|
|
5
|
# undef only matches undef and nothing else |
398
|
|
|
|
|
|
|
my $test = !defined $got && !defined $expect; |
399
|
1
|
50
|
33
|
|
|
25
|
|
400
|
|
|
|
|
|
|
$self->ok($test, $name); |
401
|
|
|
|
|
|
|
$self->_is_diag($got, '==', $expect) unless $test; |
402
|
|
|
|
|
|
|
return $test; |
403
|
|
|
|
|
|
|
} |
404
|
1
|
|
|
|
|
8
|
|
405
|
|
|
|
|
|
|
return $self->cmp_ok($got, '==', $expect, $name); |
406
|
1
|
|
|
|
|
6
|
} |
407
|
1
|
|
|
|
|
4
|
|
408
|
|
|
|
|
|
|
sub _is_diag { |
409
|
1
|
|
|
|
|
2
|
my($self, $got, $type, $expect) = @_; |
410
|
1
|
|
|
|
|
4
|
|
411
|
|
|
|
|
|
|
foreach my $val (\$got, \$expect) { |
412
|
1
|
50
|
|
|
|
5
|
if( defined $$val ) { |
413
|
0
|
|
|
|
|
0
|
if( $type eq 'eq' ) { |
414
|
0
|
0
|
|
|
|
0
|
# quote and force string context |
415
|
|
|
|
|
|
|
$$val = "'$$val'" |
416
|
|
|
|
|
|
|
} |
417
|
1
|
|
|
|
|
5
|
else { |
418
|
|
|
|
|
|
|
# force numeric context |
419
|
|
|
|
|
|
|
$self->_unoverload_num($val); |
420
|
1
|
|
|
|
|
3
|
} |
421
|
1
|
50
|
|
|
|
4
|
} |
422
|
|
|
|
|
|
|
else { |
423
|
1
|
50
|
|
|
|
4
|
$$val = 'undef'; |
424
|
1
|
|
|
|
|
3
|
} |
425
|
1
|
|
|
|
|
3
|
} |
426
|
1
|
|
|
|
|
3
|
|
427
|
|
|
|
|
|
|
return $self->diag(sprintf <
|
428
|
|
|
|
|
|
|
got: %s |
429
|
0
|
|
|
|
|
0
|
expected: %s |
430
|
|
|
|
|
|
|
DIAGNOSTIC |
431
|
|
|
|
|
|
|
|
432
|
1
|
50
|
|
|
|
12
|
} |
433
|
0
|
|
|
|
|
0
|
|
434
|
0
|
|
|
|
|
0
|
#line 613 |
435
|
0
|
|
|
|
|
0
|
|
436
|
|
|
|
|
|
|
sub isnt_eq { |
437
|
|
|
|
|
|
|
my($self, $got, $dont_expect, $name) = @_; |
438
|
1
|
|
|
|
|
3
|
local $Level = $Level + 1; |
439
|
1
|
|
|
|
|
3
|
|
440
|
|
|
|
|
|
|
if( !defined $got || !defined $dont_expect ) { |
441
|
|
|
|
|
|
|
# undef only matches undef and nothing else |
442
|
1
|
|
|
|
|
4
|
my $test = defined $got || defined $dont_expect; |
443
|
1
|
|
|
|
|
3
|
|
444
|
|
|
|
|
|
|
$self->ok($test, $name); |
445
|
1
|
|
|
|
|
5
|
$self->_cmp_diag($got, 'ne', $dont_expect) unless $test; |
446
|
|
|
|
|
|
|
return $test; |
447
|
1
|
50
|
|
|
|
4
|
} |
448
|
0
|
0
|
|
|
|
0
|
|
449
|
0
|
0
|
|
|
|
0
|
return $self->cmp_ok($got, 'ne', $dont_expect, $name); |
450
|
|
|
|
|
|
|
} |
451
|
0
|
0
|
|
|
|
0
|
|
452
|
0
|
|
|
|
|
0
|
sub isnt_num { |
453
|
0
|
|
|
|
|
0
|
my($self, $got, $dont_expect, $name) = @_; |
454
|
|
|
|
|
|
|
local $Level = $Level + 1; |
455
|
|
|
|
|
|
|
|
456
|
0
|
|
|
|
|
0
|
if( !defined $got || !defined $dont_expect ) { |
457
|
|
|
|
|
|
|
# undef only matches undef and nothing else |
458
|
|
|
|
|
|
|
my $test = defined $got || defined $dont_expect; |
459
|
|
|
|
|
|
|
|
460
|
1
|
50
|
|
|
|
6
|
$self->ok($test, $name); |
461
|
|
|
|
|
|
|
$self->_cmp_diag($got, '!=', $dont_expect) unless $test; |
462
|
|
|
|
|
|
|
return $test; |
463
|
|
|
|
|
|
|
} |
464
|
|
|
|
|
|
|
|
465
|
2
|
|
|
2
|
|
3
|
return $self->cmp_ok($got, '!=', $dont_expect, $name); |
466
|
2
|
|
|
|
|
4
|
} |
467
|
|
|
|
|
|
|
|
468
|
2
|
|
|
|
|
38
|
|
469
|
|
|
|
|
|
|
#line 665 |
470
|
2
|
50
|
|
|
|
4
|
|
|
2
|
|
|
|
|
1988
|
|
471
|
|
|
|
|
|
|
sub like { |
472
|
2
|
|
|
|
|
1396
|
my($self, $this, $regex, $name) = @_; |
473
|
2
|
|
|
|
|
5
|
|
474
|
2
|
50
|
|
|
|
7
|
local $Level = $Level + 1; |
475
|
0
|
0
|
|
|
|
0
|
$self->_regex_ok($this, $regex, '=~', $name); |
476
|
0
|
|
|
|
|
0
|
} |
477
|
|
|
|
|
|
|
|
478
|
|
|
|
|
|
|
sub unlike { |
479
|
|
|
|
|
|
|
my($self, $this, $regex, $name) = @_; |
480
|
|
|
|
|
|
|
|
481
|
|
|
|
|
|
|
local $Level = $Level + 1; |
482
|
|
|
|
|
|
|
$self->_regex_ok($this, $regex, '!~', $name); |
483
|
|
|
|
|
|
|
} |
484
|
|
|
|
|
|
|
|
485
|
2
|
|
|
2
|
|
3
|
#line 706 |
486
|
|
|
|
|
|
|
|
487
|
2
|
50
|
|
|
|
4
|
|
|
2
|
50
|
|
|
|
24
|
|
488
|
|
|
|
|
|
|
sub maybe_regex { |
489
|
|
|
|
|
|
|
my ($self, $regex) = @_; |
490
|
|
|
|
|
|
|
my $usable_regex = undef; |
491
|
|
|
|
|
|
|
|
492
|
2
|
|
|
2
|
|
4
|
return $usable_regex unless defined $regex; |
493
|
|
|
|
|
|
|
|
494
|
2
|
|
|
|
|
9
|
my($re, $opts); |
495
|
|
|
|
|
|
|
|
496
|
|
|
|
|
|
|
# Check for qr/foo/ |
497
|
|
|
|
|
|
|
if( ref $regex eq 'Regexp' ) { |
498
|
0
|
|
|
0
|
|
0
|
$usable_regex = $regex; |
499
|
|
|
|
|
|
|
} |
500
|
0
|
|
|
|
|
0
|
# Check for '/foo/' or 'm,foo,' |
501
|
|
|
|
|
|
|
elsif( ($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or |
502
|
0
|
|
|
|
|
0
|
(undef, $re, $opts) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx |
503
|
0
|
0
|
|
|
|
0
|
) |
504
|
0
|
|
|
|
|
0
|
{ |
505
|
|
|
|
|
|
|
$usable_regex = length $opts ? "(?$opts)$re" : $re; |
506
|
|
|
|
|
|
|
} |
507
|
|
|
|
|
|
|
|
508
|
|
|
|
|
|
|
return $usable_regex; |
509
|
|
|
|
|
|
|
}; |
510
|
|
|
|
|
|
|
|
511
|
0
|
|
|
0
|
|
0
|
sub _regex_ok { |
512
|
|
|
|
|
|
|
my($self, $this, $regex, $cmp, $name) = @_; |
513
|
0
|
|
|
|
|
0
|
|
514
|
0
|
|
|
|
|
0
|
my $ok = 0; |
515
|
0
|
0
|
0
|
|
|
0
|
my $usable_regex = $self->maybe_regex($regex); |
516
|
|
|
|
|
|
|
unless (defined $usable_regex) { |
517
|
|
|
|
|
|
|
$ok = $self->ok( 0, $name ); |
518
|
|
|
|
|
|
|
$self->diag(" '$regex' doesn't look much like a regex to me."); |
519
|
|
|
|
|
|
|
return $ok; |
520
|
|
|
|
|
|
|
} |
521
|
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
{ |
523
|
|
|
|
|
|
|
my $test; |
524
|
|
|
|
|
|
|
my $code = $self->_caller_context; |
525
|
|
|
|
|
|
|
|
526
|
|
|
|
|
|
|
local($@, $!); |
527
|
|
|
|
|
|
|
|
528
|
|
|
|
|
|
|
# Yes, it has to look like this or 5.4.5 won't see the #line directive. |
529
|
|
|
|
|
|
|
# Don't ask me, man, I just work here. |
530
|
|
|
|
|
|
|
$test = eval " |
531
|
|
|
|
|
|
|
$code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0}; |
532
|
|
|
|
|
|
|
|
533
|
|
|
|
|
|
|
$test = !$test if $cmp eq '!~'; |
534
|
|
|
|
|
|
|
|
535
|
|
|
|
|
|
|
local $Level = $Level + 1; |
536
|
|
|
|
|
|
|
$ok = $self->ok( $test, $name ); |
537
|
0
|
|
|
0
|
1
|
0
|
} |
538
|
0
|
|
|
|
|
0
|
|
539
|
|
|
|
|
|
|
unless( $ok ) { |
540
|
0
|
|
|
|
|
0
|
$this = defined $this ? "'$this'" : 'undef'; |
541
|
|
|
|
|
|
|
my $match = $cmp eq '=~' ? "doesn't match" : "matches"; |
542
|
0
|
0
|
0
|
|
|
0
|
$self->diag(sprintf <
|
543
|
|
|
|
|
|
|
%s |
544
|
0
|
|
0
|
|
|
0
|
%13s '%s' |
545
|
|
|
|
|
|
|
DIAGNOSTIC |
546
|
0
|
|
|
|
|
0
|
|
547
|
0
|
0
|
|
|
|
0
|
} |
548
|
0
|
|
|
|
|
0
|
|
549
|
|
|
|
|
|
|
return $ok; |
550
|
|
|
|
|
|
|
} |
551
|
0
|
|
|
|
|
0
|
|
552
|
|
|
|
|
|
|
#line 781 |
553
|
|
|
|
|
|
|
|
554
|
|
|
|
|
|
|
|
555
|
0
|
|
|
0
|
1
|
0
|
my %numeric_cmps = map { ($_, 1) } |
556
|
0
|
|
|
|
|
0
|
("<", "<=", ">", ">=", "==", "!=", "<=>"); |
557
|
|
|
|
|
|
|
|
558
|
0
|
|
|
|
|
0
|
sub cmp_ok { |
559
|
|
|
|
|
|
|
my($self, $got, $type, $expect, $name) = @_; |
560
|
0
|
0
|
0
|
|
|
0
|
|
561
|
|
|
|
|
|
|
# Treat overloaded objects as numbers if we're asked to do a |
562
|
0
|
|
0
|
|
|
0
|
# numeric comparison. |
563
|
|
|
|
|
|
|
my $unoverload = $numeric_cmps{$type} ? '_unoverload_num' |
564
|
0
|
|
|
|
|
0
|
: '_unoverload_str'; |
565
|
0
|
0
|
|
|
|
0
|
|
566
|
0
|
|
|
|
|
0
|
$self->$unoverload(\$got, \$expect); |
567
|
|
|
|
|
|
|
|
568
|
|
|
|
|
|
|
|
569
|
0
|
|
|
|
|
0
|
my $test; |
570
|
|
|
|
|
|
|
{ |
571
|
|
|
|
|
|
|
local($@,$!); # don't interfere with $@ |
572
|
|
|
|
|
|
|
# eval() sometimes resets $! |
573
|
0
|
|
|
0
|
|
0
|
|
574
|
|
|
|
|
|
|
my $code = $self->_caller_context; |
575
|
0
|
|
|
|
|
0
|
|
576
|
0
|
0
|
|
|
|
0
|
# Yes, it has to look like this or 5.4.5 won't see the #line directive. |
577
|
0
|
0
|
|
|
|
0
|
# Don't ask me, man, I just work here. |
578
|
|
|
|
|
|
|
$test = eval " |
579
|
0
|
|
|
|
|
0
|
$code" . "\$got $type \$expect;"; |
580
|
|
|
|
|
|
|
|
581
|
|
|
|
|
|
|
} |
582
|
|
|
|
|
|
|
local $Level = $Level + 1; |
583
|
0
|
|
|
|
|
0
|
my $ok = $self->ok($test, $name); |
584
|
|
|
|
|
|
|
|
585
|
|
|
|
|
|
|
unless( $ok ) { |
586
|
|
|
|
|
|
|
if( $type =~ /^(eq|==)$/ ) { |
587
|
0
|
|
|
|
|
0
|
$self->_is_diag($got, $type, $expect); |
588
|
|
|
|
|
|
|
} |
589
|
|
|
|
|
|
|
else { |
590
|
|
|
|
|
|
|
$self->_cmp_diag($got, $type, $expect); |
591
|
0
|
|
|
|
|
0
|
} |
592
|
|
|
|
|
|
|
} |
593
|
|
|
|
|
|
|
return $ok; |
594
|
|
|
|
|
|
|
} |
595
|
|
|
|
|
|
|
|
596
|
|
|
|
|
|
|
sub _cmp_diag { |
597
|
|
|
|
|
|
|
my($self, $got, $type, $expect) = @_; |
598
|
|
|
|
|
|
|
|
599
|
|
|
|
|
|
|
$got = defined $got ? "'$got'" : 'undef'; |
600
|
|
|
|
|
|
|
$expect = defined $expect ? "'$expect'" : 'undef'; |
601
|
|
|
|
|
|
|
return $self->diag(sprintf <
|
602
|
|
|
|
|
|
|
%s |
603
|
|
|
|
|
|
|
%s |
604
|
|
|
|
|
|
|
%s |
605
|
|
|
|
|
|
|
DIAGNOSTIC |
606
|
|
|
|
|
|
|
} |
607
|
|
|
|
|
|
|
|
608
|
|
|
|
|
|
|
|
609
|
|
|
|
|
|
|
sub _caller_context { |
610
|
|
|
|
|
|
|
my $self = shift; |
611
|
|
|
|
|
|
|
|
612
|
|
|
|
|
|
|
my($pack, $file, $line) = $self->caller(1); |
613
|
|
|
|
|
|
|
|
614
|
|
|
|
|
|
|
my $code = ''; |
615
|
0
|
|
|
0
|
1
|
0
|
$code .= "#line $line $file\n" if defined $file and defined $line; |
616
|
0
|
|
|
|
|
0
|
|
617
|
|
|
|
|
|
|
return $code; |
618
|
0
|
0
|
0
|
|
|
0
|
} |
619
|
|
|
|
|
|
|
|
620
|
0
|
|
0
|
|
|
0
|
|
621
|
|
|
|
|
|
|
#line 860 |
622
|
0
|
|
|
|
|
0
|
|
623
|
0
|
0
|
|
|
|
0
|
sub BAIL_OUT { |
624
|
0
|
|
|
|
|
0
|
my($self, $reason) = @_; |
625
|
|
|
|
|
|
|
|
626
|
|
|
|
|
|
|
$self->{Bailed_Out} = 1; |
627
|
0
|
|
|
|
|
0
|
$self->_print("Bail out! $reason"); |
628
|
|
|
|
|
|
|
exit 255; |
629
|
|
|
|
|
|
|
} |
630
|
|
|
|
|
|
|
|
631
|
0
|
|
|
0
|
1
|
0
|
#line 873 |
632
|
0
|
|
|
|
|
0
|
|
633
|
|
|
|
|
|
|
*BAILOUT = \&BAIL_OUT; |
634
|
0
|
0
|
0
|
|
|
0
|
|
635
|
|
|
|
|
|
|
|
636
|
0
|
|
0
|
|
|
0
|
#line 885 |
637
|
|
|
|
|
|
|
|
638
|
0
|
|
|
|
|
0
|
sub skip { |
639
|
0
|
0
|
|
|
|
0
|
my($self, $why) = @_; |
640
|
0
|
|
|
|
|
0
|
$why ||= ''; |
641
|
|
|
|
|
|
|
$self->_unoverload_str(\$why); |
642
|
|
|
|
|
|
|
|
643
|
0
|
|
|
|
|
0
|
unless( $self->{Have_Plan} ) { |
644
|
|
|
|
|
|
|
require Carp; |
645
|
|
|
|
|
|
|
Carp::croak("You tried to run tests without a plan! Gotta have a plan."); |
646
|
|
|
|
|
|
|
} |
647
|
|
|
|
|
|
|
|
648
|
|
|
|
|
|
|
lock($self->{Curr_Test}); |
649
|
|
|
|
|
|
|
$self->{Curr_Test}++; |
650
|
|
|
|
|
|
|
|
651
|
|
|
|
|
|
|
$self->{Test_Results}[$self->{Curr_Test}-1] = &share({ |
652
|
|
|
|
|
|
|
'ok' => 1, |
653
|
|
|
|
|
|
|
actual_ok => 1, |
654
|
|
|
|
|
|
|
name => '', |
655
|
|
|
|
|
|
|
type => 'skip', |
656
|
|
|
|
|
|
|
reason => $why, |
657
|
|
|
|
|
|
|
}); |
658
|
|
|
|
|
|
|
|
659
|
|
|
|
|
|
|
my $out = "ok"; |
660
|
|
|
|
|
|
|
$out .= " $self->{Curr_Test}" if $self->use_numbers; |
661
|
|
|
|
|
|
|
$out .= " # skip"; |
662
|
|
|
|
|
|
|
$out .= " $why" if length $why; |
663
|
|
|
|
|
|
|
$out .= "\n"; |
664
|
|
|
|
|
|
|
|
665
|
|
|
|
|
|
|
$self->_print($out); |
666
|
|
|
|
|
|
|
|
667
|
0
|
|
|
0
|
1
|
0
|
return 1; |
668
|
|
|
|
|
|
|
} |
669
|
0
|
|
|
|
|
0
|
|
670
|
0
|
|
|
|
|
0
|
|
671
|
|
|
|
|
|
|
#line 930 |
672
|
|
|
|
|
|
|
|
673
|
|
|
|
|
|
|
sub todo_skip { |
674
|
0
|
|
|
0
|
1
|
0
|
my($self, $why) = @_; |
675
|
|
|
|
|
|
|
$why ||= ''; |
676
|
0
|
|
|
|
|
0
|
|
677
|
0
|
|
|
|
|
0
|
unless( $self->{Have_Plan} ) { |
678
|
|
|
|
|
|
|
require Carp; |
679
|
|
|
|
|
|
|
Carp::croak("You tried to run tests without a plan! Gotta have a plan."); |
680
|
|
|
|
|
|
|
} |
681
|
|
|
|
|
|
|
|
682
|
|
|
|
|
|
|
lock($self->{Curr_Test}); |
683
|
|
|
|
|
|
|
$self->{Curr_Test}++; |
684
|
|
|
|
|
|
|
|
685
|
|
|
|
|
|
|
$self->{Test_Results}[$self->{Curr_Test}-1] = &share({ |
686
|
|
|
|
|
|
|
'ok' => 1, |
687
|
|
|
|
|
|
|
actual_ok => 0, |
688
|
|
|
|
|
|
|
name => '', |
689
|
|
|
|
|
|
|
type => 'todo_skip', |
690
|
|
|
|
|
|
|
reason => $why, |
691
|
|
|
|
|
|
|
}); |
692
|
|
|
|
|
|
|
|
693
|
|
|
|
|
|
|
my $out = "not ok"; |
694
|
|
|
|
|
|
|
$out .= " $self->{Curr_Test}" if $self->use_numbers; |
695
|
|
|
|
|
|
|
$out .= " # TODO & SKIP $why\n"; |
696
|
|
|
|
|
|
|
|
697
|
|
|
|
|
|
|
$self->_print($out); |
698
|
|
|
|
|
|
|
|
699
|
|
|
|
|
|
|
return 1; |
700
|
|
|
|
|
|
|
} |
701
|
|
|
|
|
|
|
|
702
|
|
|
|
|
|
|
|
703
|
|
|
|
|
|
|
#line 1001 |
704
|
|
|
|
|
|
|
|
705
|
|
|
|
|
|
|
sub level { |
706
|
|
|
|
|
|
|
my($self, $level) = @_; |
707
|
|
|
|
|
|
|
|
708
|
|
|
|
|
|
|
if( defined $level ) { |
709
|
0
|
|
|
0
|
1
|
0
|
$Level = $level; |
710
|
0
|
|
|
|
|
0
|
} |
711
|
|
|
|
|
|
|
return $Level; |
712
|
0
|
0
|
|
|
|
0
|
} |
713
|
|
|
|
|
|
|
|
714
|
0
|
|
|
|
|
0
|
|
715
|
|
|
|
|
|
|
#line 1036 |
716
|
|
|
|
|
|
|
|
717
|
0
|
0
|
0
|
|
|
0
|
sub use_numbers { |
|
|
0
|
|
|
|
|
|
718
|
0
|
|
|
|
|
0
|
my($self, $use_nums) = @_; |
719
|
|
|
|
|
|
|
|
720
|
|
|
|
|
|
|
if( defined $use_nums ) { |
721
|
|
|
|
|
|
|
$self->{Use_Nums} = $use_nums; |
722
|
|
|
|
|
|
|
} |
723
|
|
|
|
|
|
|
return $self->{Use_Nums}; |
724
|
|
|
|
|
|
|
} |
725
|
0
|
0
|
|
|
|
0
|
|
726
|
|
|
|
|
|
|
|
727
|
|
|
|
|
|
|
#line 1070 |
728
|
0
|
|
|
|
|
0
|
|
729
|
|
|
|
|
|
|
foreach my $attribute (qw(No_Header No_Ending No_Diag)) { |
730
|
|
|
|
|
|
|
my $method = lc $attribute; |
731
|
|
|
|
|
|
|
|
732
|
0
|
|
|
0
|
|
0
|
my $code = sub { |
733
|
|
|
|
|
|
|
my($self, $no) = @_; |
734
|
0
|
|
|
|
|
0
|
|
735
|
0
|
|
|
|
|
0
|
if( defined $no ) { |
736
|
0
|
0
|
|
|
|
0
|
$self->{$attribute} = $no; |
737
|
0
|
|
|
|
|
0
|
} |
738
|
0
|
|
|
|
|
0
|
return $self->{$attribute}; |
739
|
0
|
|
|
|
|
0
|
}; |
740
|
|
|
|
|
|
|
|
741
|
|
|
|
|
|
|
no strict 'refs'; |
742
|
|
|
|
|
|
|
*{__PACKAGE__.'::'.$method} = $code; |
743
|
0
|
|
|
|
|
0
|
} |
|
0
|
|
|
|
|
0
|
|
744
|
0
|
|
|
|
|
0
|
|
745
|
|
|
|
|
|
|
|
746
|
0
|
|
|
|
|
0
|
#line 1124 |
747
|
|
|
|
|
|
|
|
748
|
|
|
|
|
|
|
sub diag { |
749
|
|
|
|
|
|
|
my($self, @msgs) = @_; |
750
|
0
|
|
|
|
|
0
|
|
751
|
|
|
|
|
|
|
return if $self->no_diag; |
752
|
|
|
|
|
|
|
return unless @msgs; |
753
|
0
|
0
|
|
|
|
0
|
|
754
|
|
|
|
|
|
|
# Prevent printing headers when compiling (i.e. -c) |
755
|
0
|
|
|
|
|
0
|
return if $^C; |
756
|
0
|
|
|
|
|
0
|
|
757
|
|
|
|
|
|
|
# Smash args together like print does. |
758
|
|
|
|
|
|
|
# Convert undef to 'undef' so its readable. |
759
|
0
|
0
|
|
|
|
0
|
my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs; |
760
|
0
|
0
|
|
|
|
0
|
|
761
|
0
|
0
|
|
|
|
0
|
# Escape each line with a #. |
762
|
0
|
|
|
|
|
0
|
$msg =~ s/^/# /gm; |
763
|
|
|
|
|
|
|
|
764
|
|
|
|
|
|
|
# Stick a newline on the end if it needs it. |
765
|
|
|
|
|
|
|
$msg .= "\n" unless $msg =~ /\n\Z/; |
766
|
|
|
|
|
|
|
|
767
|
|
|
|
|
|
|
local $Level = $Level + 1; |
768
|
|
|
|
|
|
|
$self->_print_diag($msg); |
769
|
0
|
|
|
|
|
0
|
|
770
|
|
|
|
|
|
|
return 0; |
771
|
|
|
|
|
|
|
} |
772
|
|
|
|
|
|
|
|
773
|
|
|
|
|
|
|
#line 1161 |
774
|
|
|
|
|
|
|
|
775
|
|
|
|
|
|
|
sub _print { |
776
|
|
|
|
|
|
|
my($self, @msgs) = @_; |
777
|
|
|
|
|
|
|
|
778
|
|
|
|
|
|
|
# Prevent printing headers when only compiling. Mostly for when |
779
|
|
|
|
|
|
|
# tests are deparsed with B::Deparse |
780
|
|
|
|
|
|
|
return if $^C; |
781
|
|
|
|
|
|
|
|
782
|
|
|
|
|
|
|
my $msg = join '', @msgs; |
783
|
|
|
|
|
|
|
|
784
|
|
|
|
|
|
|
local($\, $", $,) = (undef, ' ', ''); |
785
|
|
|
|
|
|
|
my $fh = $self->output; |
786
|
|
|
|
|
|
|
|
787
|
0
|
|
|
0
|
1
|
0
|
# Escape each line after the first with a # so we don't |
788
|
|
|
|
|
|
|
# confuse Test::Harness. |
789
|
|
|
|
|
|
|
$msg =~ s/\n(.)/\n# $1/sg; |
790
|
|
|
|
|
|
|
|
791
|
0
|
0
|
|
|
|
0
|
# Stick a newline on the end if it needs it. |
792
|
|
|
|
|
|
|
$msg .= "\n" unless $msg =~ /\n\Z/; |
793
|
|
|
|
|
|
|
|
794
|
0
|
|
|
|
|
0
|
print $fh $msg; |
795
|
|
|
|
|
|
|
} |
796
|
|
|
|
|
|
|
|
797
|
0
|
|
|
|
|
0
|
|
798
|
|
|
|
|
|
|
#line 1192 |
799
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
800
|
|
|
|
|
|
|
sub _print_diag { |
801
|
|
|
|
|
|
|
my $self = shift; |
802
|
0
|
|
|
|
|
0
|
|
803
|
|
|
|
|
|
|
local($\, $", $,) = (undef, ' ', ''); |
804
|
|
|
|
|
|
|
my $fh = $self->todo ? $self->todo_output : $self->failure_output; |
805
|
|
|
|
|
|
|
print $fh @_; |
806
|
0
|
|
|
|
|
0
|
} |
807
|
|
|
|
|
|
|
|
808
|
|
|
|
|
|
|
#line 1229 |
809
|
|
|
|
|
|
|
|
810
|
0
|
|
|
|
|
0
|
sub output { |
811
|
0
|
|
|
|
|
0
|
my($self, $fh) = @_; |
812
|
|
|
|
|
|
|
|
813
|
0
|
0
|
|
|
|
0
|
if( defined $fh ) { |
814
|
0
|
0
|
|
|
|
0
|
$self->{Out_FH} = _new_fh($fh); |
815
|
0
|
|
|
|
|
0
|
} |
816
|
|
|
|
|
|
|
return $self->{Out_FH}; |
817
|
|
|
|
|
|
|
} |
818
|
0
|
|
|
|
|
0
|
|
819
|
|
|
|
|
|
|
sub failure_output { |
820
|
|
|
|
|
|
|
my($self, $fh) = @_; |
821
|
0
|
|
|
|
|
0
|
|
822
|
|
|
|
|
|
|
if( defined $fh ) { |
823
|
|
|
|
|
|
|
$self->{Fail_FH} = _new_fh($fh); |
824
|
|
|
|
|
|
|
} |
825
|
0
|
|
|
0
|
|
0
|
return $self->{Fail_FH}; |
826
|
|
|
|
|
|
|
} |
827
|
0
|
0
|
|
|
|
0
|
|
828
|
0
|
0
|
|
|
|
0
|
sub todo_output { |
829
|
0
|
|
|
|
|
0
|
my($self, $fh) = @_; |
830
|
|
|
|
|
|
|
|
831
|
|
|
|
|
|
|
if( defined $fh ) { |
832
|
|
|
|
|
|
|
$self->{Todo_FH} = _new_fh($fh); |
833
|
|
|
|
|
|
|
} |
834
|
|
|
|
|
|
|
return $self->{Todo_FH}; |
835
|
|
|
|
|
|
|
} |
836
|
|
|
|
|
|
|
|
837
|
|
|
|
|
|
|
|
838
|
0
|
|
|
0
|
|
0
|
sub _new_fh { |
839
|
|
|
|
|
|
|
my($file_or_fh) = shift; |
840
|
0
|
|
|
|
|
0
|
|
841
|
|
|
|
|
|
|
my $fh; |
842
|
0
|
|
|
|
|
0
|
if( _is_fh($file_or_fh) ) { |
843
|
0
|
0
|
0
|
|
|
0
|
$fh = $file_or_fh; |
844
|
|
|
|
|
|
|
} |
845
|
0
|
|
|
|
|
0
|
else { |
846
|
|
|
|
|
|
|
$fh = do { local *FH }; |
847
|
|
|
|
|
|
|
open $fh, ">$file_or_fh" or |
848
|
|
|
|
|
|
|
die "Can't open test output log $file_or_fh: $!"; |
849
|
|
|
|
|
|
|
_autoflush($fh); |
850
|
|
|
|
|
|
|
} |
851
|
|
|
|
|
|
|
|
852
|
|
|
|
|
|
|
return $fh; |
853
|
|
|
|
|
|
|
} |
854
|
|
|
|
|
|
|
|
855
|
|
|
|
|
|
|
|
856
|
|
|
|
|
|
|
sub _is_fh { |
857
|
|
|
|
|
|
|
my $maybe_fh = shift; |
858
|
|
|
|
|
|
|
return 0 unless defined $maybe_fh; |
859
|
|
|
|
|
|
|
|
860
|
|
|
|
|
|
|
return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob |
861
|
|
|
|
|
|
|
|
862
|
0
|
|
|
0
|
1
|
0
|
return UNIVERSAL::isa($maybe_fh, 'GLOB') || |
863
|
|
|
|
|
|
|
UNIVERSAL::isa($maybe_fh, 'IO::Handle') || |
864
|
0
|
|
|
|
|
0
|
|
865
|
0
|
|
|
|
|
0
|
# 5.5.4's tied() and can() doesn't like getting undef |
866
|
0
|
|
|
|
|
0
|
UNIVERSAL::can((tied($maybe_fh) || ''), 'TIEHANDLE'); |
867
|
|
|
|
|
|
|
} |
868
|
|
|
|
|
|
|
|
869
|
|
|
|
|
|
|
|
870
|
|
|
|
|
|
|
sub _autoflush { |
871
|
|
|
|
|
|
|
my($fh) = shift; |
872
|
|
|
|
|
|
|
my $old_fh = select $fh; |
873
|
|
|
|
|
|
|
$| = 1; |
874
|
|
|
|
|
|
|
select $old_fh; |
875
|
|
|
|
|
|
|
} |
876
|
|
|
|
|
|
|
|
877
|
|
|
|
|
|
|
|
878
|
|
|
|
|
|
|
sub _dup_stdhandles { |
879
|
|
|
|
|
|
|
my $self = shift; |
880
|
|
|
|
|
|
|
|
881
|
|
|
|
|
|
|
$self->_open_testhandles; |
882
|
|
|
|
|
|
|
|
883
|
|
|
|
|
|
|
# Set everything to unbuffered else plain prints to STDOUT will |
884
|
|
|
|
|
|
|
# come out in the wrong order from our own prints. |
885
|
|
|
|
|
|
|
_autoflush(\*TESTOUT); |
886
|
|
|
|
|
|
|
_autoflush(\*STDOUT); |
887
|
0
|
|
|
0
|
1
|
0
|
_autoflush(\*TESTERR); |
888
|
0
|
|
0
|
|
|
0
|
_autoflush(\*STDERR); |
889
|
0
|
|
|
|
|
0
|
|
890
|
|
|
|
|
|
|
$self->output(\*TESTOUT); |
891
|
0
|
0
|
|
|
|
0
|
$self->failure_output(\*TESTERR); |
892
|
0
|
|
|
|
|
0
|
$self->todo_output(\*TESTOUT); |
893
|
0
|
|
|
|
|
0
|
} |
894
|
|
|
|
|
|
|
|
895
|
|
|
|
|
|
|
|
896
|
0
|
|
|
|
|
0
|
my $Opened_Testhandles = 0; |
897
|
0
|
|
|
|
|
0
|
sub _open_testhandles { |
898
|
|
|
|
|
|
|
return if $Opened_Testhandles; |
899
|
0
|
|
|
|
|
0
|
# We dup STDOUT and STDERR so people can change them in their |
900
|
|
|
|
|
|
|
# test suites while still getting normal test output. |
901
|
|
|
|
|
|
|
open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!"; |
902
|
|
|
|
|
|
|
open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!"; |
903
|
|
|
|
|
|
|
$Opened_Testhandles = 1; |
904
|
|
|
|
|
|
|
} |
905
|
|
|
|
|
|
|
|
906
|
|
|
|
|
|
|
|
907
|
0
|
|
|
|
|
0
|
#line 1347 |
908
|
0
|
0
|
|
|
|
0
|
|
909
|
0
|
|
|
|
|
0
|
sub current_test { |
910
|
0
|
0
|
|
|
|
0
|
my($self, $num) = @_; |
911
|
0
|
|
|
|
|
0
|
|
912
|
|
|
|
|
|
|
lock($self->{Curr_Test}); |
913
|
0
|
|
|
|
|
0
|
if( defined $num ) { |
914
|
|
|
|
|
|
|
unless( $self->{Have_Plan} ) { |
915
|
0
|
|
|
|
|
0
|
require Carp; |
916
|
|
|
|
|
|
|
Carp::croak("Can't change the current test number without a plan!"); |
917
|
|
|
|
|
|
|
} |
918
|
|
|
|
|
|
|
|
919
|
|
|
|
|
|
|
$self->{Curr_Test} = $num; |
920
|
|
|
|
|
|
|
|
921
|
|
|
|
|
|
|
# If the test counter is being pushed forward fill in the details. |
922
|
|
|
|
|
|
|
my $test_results = $self->{Test_Results}; |
923
|
|
|
|
|
|
|
if( $num > @$test_results ) { |
924
|
|
|
|
|
|
|
my $start = @$test_results ? @$test_results : 0; |
925
|
|
|
|
|
|
|
for ($start..$num-1) { |
926
|
|
|
|
|
|
|
$test_results->[$_] = &share({ |
927
|
|
|
|
|
|
|
'ok' => 1, |
928
|
|
|
|
|
|
|
actual_ok => undef, |
929
|
|
|
|
|
|
|
reason => 'incrementing test number', |
930
|
|
|
|
|
|
|
type => 'unknown', |
931
|
|
|
|
|
|
|
name => undef |
932
|
0
|
|
|
0
|
1
|
0
|
}); |
933
|
0
|
|
0
|
|
|
0
|
} |
934
|
|
|
|
|
|
|
} |
935
|
0
|
0
|
|
|
|
0
|
# If backward, wipe history. Its their funeral. |
936
|
0
|
|
|
|
|
0
|
elsif( $num < @$test_results ) { |
937
|
0
|
|
|
|
|
0
|
$#{$test_results} = $num - 1; |
938
|
|
|
|
|
|
|
} |
939
|
|
|
|
|
|
|
} |
940
|
0
|
|
|
|
|
0
|
return $self->{Curr_Test}; |
941
|
0
|
|
|
|
|
0
|
} |
942
|
|
|
|
|
|
|
|
943
|
0
|
|
|
|
|
0
|
|
944
|
|
|
|
|
|
|
#line 1393 |
945
|
|
|
|
|
|
|
|
946
|
|
|
|
|
|
|
sub summary { |
947
|
|
|
|
|
|
|
my($self) = shift; |
948
|
|
|
|
|
|
|
|
949
|
|
|
|
|
|
|
return map { $_->{'ok'} } @{ $self->{Test_Results} }; |
950
|
|
|
|
|
|
|
} |
951
|
0
|
|
|
|
|
0
|
|
952
|
0
|
0
|
|
|
|
0
|
#line 1448 |
953
|
0
|
|
|
|
|
0
|
|
954
|
|
|
|
|
|
|
sub details { |
955
|
0
|
|
|
|
|
0
|
my $self = shift; |
956
|
|
|
|
|
|
|
return @{ $self->{Test_Results} }; |
957
|
0
|
|
|
|
|
0
|
} |
958
|
|
|
|
|
|
|
|
959
|
|
|
|
|
|
|
#line 1473 |
960
|
|
|
|
|
|
|
|
961
|
|
|
|
|
|
|
sub todo { |
962
|
|
|
|
|
|
|
my($self, $pack) = @_; |
963
|
|
|
|
|
|
|
|
964
|
|
|
|
|
|
|
$pack = $pack || $self->exported_to || $self->caller($Level); |
965
|
|
|
|
|
|
|
return 0 unless $pack; |
966
|
|
|
|
|
|
|
|
967
|
|
|
|
|
|
|
no strict 'refs'; |
968
|
|
|
|
|
|
|
return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'} |
969
|
|
|
|
|
|
|
: 0; |
970
|
|
|
|
|
|
|
} |
971
|
|
|
|
|
|
|
|
972
|
|
|
|
|
|
|
#line 1494 |
973
|
|
|
|
|
|
|
|
974
|
|
|
|
|
|
|
sub caller { |
975
|
|
|
|
|
|
|
my($self, $height) = @_; |
976
|
|
|
|
|
|
|
$height ||= 0; |
977
|
|
|
|
|
|
|
|
978
|
|
|
|
|
|
|
my @caller = CORE::caller($self->level + $height + 1); |
979
|
|
|
|
|
|
|
return wantarray ? @caller : $caller[0]; |
980
|
|
|
|
|
|
|
} |
981
|
|
|
|
|
|
|
|
982
|
|
|
|
|
|
|
#line 1506 |
983
|
|
|
|
|
|
|
|
984
|
|
|
|
|
|
|
#line 1520 |
985
|
|
|
|
|
|
|
|
986
|
|
|
|
|
|
|
#'# |
987
|
|
|
|
|
|
|
sub _sanity_check { |
988
|
|
|
|
|
|
|
my $self = shift; |
989
|
|
|
|
|
|
|
|
990
|
|
|
|
|
|
|
_whoa($self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!'); |
991
|
|
|
|
|
|
|
_whoa(!$self->{Have_Plan} and $self->{Curr_Test}, |
992
|
|
|
|
|
|
|
'Somehow your tests ran without a plan!'); |
993
|
|
|
|
|
|
|
_whoa($self->{Curr_Test} != @{ $self->{Test_Results} }, |
994
|
|
|
|
|
|
|
'Somehow you got a different number of results than tests ran!'); |
995
|
|
|
|
|
|
|
} |
996
|
|
|
|
|
|
|
|
997
|
|
|
|
|
|
|
#line 1541 |
998
|
|
|
|
|
|
|
|
999
|
|
|
|
|
|
|
sub _whoa { |
1000
|
|
|
|
|
|
|
my($check, $desc) = @_; |
1001
|
|
|
|
|
|
|
if( $check ) { |
1002
|
|
|
|
|
|
|
die <
|
1003
|
1
|
|
|
1
|
1
|
3
|
WHOA! $desc |
1004
|
|
|
|
|
|
|
This should never happen! Please contact the author immediately! |
1005
|
1
|
50
|
|
|
|
5
|
WHOA |
1006
|
0
|
|
|
|
|
0
|
} |
1007
|
|
|
|
|
|
|
} |
1008
|
1
|
|
|
|
|
12
|
|
1009
|
|
|
|
|
|
|
#line 1562 |
1010
|
|
|
|
|
|
|
|
1011
|
|
|
|
|
|
|
sub _my_exit { |
1012
|
|
|
|
|
|
|
$? = $_[0]; |
1013
|
|
|
|
|
|
|
|
1014
|
|
|
|
|
|
|
return 1; |
1015
|
|
|
|
|
|
|
} |
1016
|
|
|
|
|
|
|
|
1017
|
|
|
|
|
|
|
|
1018
|
|
|
|
|
|
|
#line 1575 |
1019
|
|
|
|
|
|
|
|
1020
|
|
|
|
|
|
|
$SIG{__DIE__} = sub { |
1021
|
|
|
|
|
|
|
# We don't want to muck with death in an eval, but $^S isn't |
1022
|
|
|
|
|
|
|
# totally reliable. 5.005_03 and 5.6.1 both do the wrong thing |
1023
|
|
|
|
|
|
|
# with it. Instead, we use caller. This also means it runs under |
1024
|
|
|
|
|
|
|
# 5.004! |
1025
|
|
|
|
|
|
|
my $in_eval = 0; |
1026
|
|
|
|
|
|
|
for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) { |
1027
|
|
|
|
|
|
|
$in_eval = 1 if $sub =~ /^\(eval\)/; |
1028
|
|
|
|
|
|
|
} |
1029
|
|
|
|
|
|
|
$Test->{Test_Died} = 1 unless $in_eval; |
1030
|
|
|
|
|
|
|
}; |
1031
|
|
|
|
|
|
|
|
1032
|
|
|
|
|
|
|
sub _ending { |
1033
|
|
|
|
|
|
|
my $self = shift; |
1034
|
|
|
|
|
|
|
|
1035
|
|
|
|
|
|
|
$self->_sanity_check(); |
1036
|
|
|
|
|
|
|
|
1037
|
|
|
|
|
|
|
# Don't bother with an ending if this is a forked copy. Only the parent |
1038
|
1
|
|
|
1
|
1
|
2
|
# should do the ending. |
1039
|
|
|
|
|
|
|
# Exit if plan() was never called. This is so "require Test::Simple" |
1040
|
1
|
50
|
|
|
|
4
|
# doesn't puke. |
1041
|
0
|
|
|
|
|
0
|
# Don't do an ending if we bailed out. |
1042
|
|
|
|
|
|
|
if( ($self->{Original_Pid} != $$) or |
1043
|
1
|
|
|
|
|
7
|
(!$self->{Have_Plan} && !$self->{Test_Died}) or |
1044
|
|
|
|
|
|
|
$self->{Bailed_Out} |
1045
|
|
|
|
|
|
|
) |
1046
|
|
|
|
|
|
|
{ |
1047
|
|
|
|
|
|
|
_my_exit($?); |
1048
|
|
|
|
|
|
|
return; |
1049
|
|
|
|
|
|
|
} |
1050
|
|
|
|
|
|
|
|
1051
|
|
|
|
|
|
|
# Figure out if we passed or failed and print helpful messages. |
1052
|
|
|
|
|
|
|
my $test_results = $self->{Test_Results}; |
1053
|
|
|
|
|
|
|
if( @$test_results ) { |
1054
|
|
|
|
|
|
|
# The plan? We have no plan. |
1055
|
|
|
|
|
|
|
if( $self->{No_Plan} ) { |
1056
|
|
|
|
|
|
|
$self->_print("1..$self->{Curr_Test}\n") unless $self->no_header; |
1057
|
|
|
|
|
|
|
$self->{Expected_Tests} = $self->{Curr_Test}; |
1058
|
|
|
|
|
|
|
} |
1059
|
|
|
|
|
|
|
|
1060
|
|
|
|
|
|
|
# Auto-extended arrays and elements which aren't explicitly |
1061
|
|
|
|
|
|
|
# filled in with a shared reference will puke under 5.8.0 |
1062
|
|
|
|
|
|
|
# ithreads. So we have to fill them in by hand. :( |
1063
|
|
|
|
|
|
|
my $empty_result = &share({}); |
1064
|
|
|
|
|
|
|
for my $idx ( 0..$self->{Expected_Tests}-1 ) { |
1065
|
|
|
|
|
|
|
$test_results->[$idx] = $empty_result |
1066
|
|
|
|
|
|
|
unless defined $test_results->[$idx]; |
1067
|
|
|
|
|
|
|
} |
1068
|
|
|
|
|
|
|
|
1069
|
|
|
|
|
|
|
my $num_failed = grep !$_->{'ok'}, |
1070
|
|
|
|
|
|
|
@{$test_results}[0..$self->{Curr_Test}-1]; |
1071
|
|
|
|
|
|
|
|
1072
|
|
|
|
|
|
|
my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests}; |
1073
|
|
|
|
|
|
|
|
1074
|
|
|
|
|
|
|
if( $num_extra < 0 ) { |
1075
|
4
|
|
|
4
|
|
10
|
my $s = $self->{Expected_Tests} == 1 ? '' : 's'; |
1076
|
|
|
|
|
|
|
$self->diag(<<"FAIL"); |
1077
|
4
|
50
|
|
|
|
16
|
Looks like you planned $self->{Expected_Tests} test$s but only ran $self->{Curr_Test}. |
1078
|
0
|
|
|
|
|
0
|
FAIL |
1079
|
|
|
|
|
|
|
} |
1080
|
4
|
|
|
|
|
51
|
elsif( $num_extra > 0 ) { |
1081
|
|
|
|
|
|
|
my $s = $self->{Expected_Tests} == 1 ? '' : 's'; |
1082
|
|
|
|
|
|
|
$self->diag(<<"FAIL"); |
1083
|
2
|
|
|
2
|
|
17
|
Looks like you planned $self->{Expected_Tests} test$s but ran $num_extra extra. |
|
2
|
|
|
|
|
11
|
|
|
2
|
|
|
|
|
3087
|
|
1084
|
|
|
|
|
|
|
FAIL |
1085
|
|
|
|
|
|
|
} |
1086
|
|
|
|
|
|
|
|
1087
|
|
|
|
|
|
|
if ( $num_failed ) { |
1088
|
|
|
|
|
|
|
my $num_tests = $self->{Curr_Test}; |
1089
|
|
|
|
|
|
|
my $s = $num_failed == 1 ? '' : 's'; |
1090
|
|
|
|
|
|
|
|
1091
|
|
|
|
|
|
|
my $qualifier = $num_extra == 0 ? '' : ' run'; |
1092
|
|
|
|
|
|
|
|
1093
|
|
|
|
|
|
|
$self->diag(<<"FAIL"); |
1094
|
|
|
|
|
|
|
Looks like you failed $num_failed test$s of $num_tests$qualifier. |
1095
|
|
|
|
|
|
|
FAIL |
1096
|
|
|
|
|
|
|
} |
1097
|
|
|
|
|
|
|
|
1098
|
|
|
|
|
|
|
if( $self->{Test_Died} ) { |
1099
|
|
|
|
|
|
|
$self->diag(<<"FAIL"); |
1100
|
|
|
|
|
|
|
Looks like your test died just after $self->{Curr_Test}. |
1101
|
|
|
|
|
|
|
FAIL |
1102
|
|
|
|
|
|
|
|
1103
|
|
|
|
|
|
|
_my_exit( 255 ) && return; |
1104
|
|
|
|
|
|
|
} |
1105
|
|
|
|
|
|
|
|
1106
|
|
|
|
|
|
|
my $exit_code; |
1107
|
|
|
|
|
|
|
if( $num_failed ) { |
1108
|
|
|
|
|
|
|
$exit_code = $num_failed <= 254 ? $num_failed : 254; |
1109
|
|
|
|
|
|
|
} |
1110
|
|
|
|
|
|
|
elsif( $num_extra != 0 ) { |
1111
|
|
|
|
|
|
|
$exit_code = 255; |
1112
|
|
|
|
|
|
|
} |
1113
|
|
|
|
|
|
|
else { |
1114
|
|
|
|
|
|
|
$exit_code = 0; |
1115
|
|
|
|
|
|
|
} |
1116
|
|
|
|
|
|
|
|
1117
|
|
|
|
|
|
|
_my_exit( $exit_code ) && return; |
1118
|
|
|
|
|
|
|
} |
1119
|
|
|
|
|
|
|
elsif ( $self->{Skip_All} ) { |
1120
|
|
|
|
|
|
|
_my_exit( 0 ) && return; |
1121
|
|
|
|
|
|
|
} |
1122
|
|
|
|
|
|
|
elsif ( $self->{Test_Died} ) { |
1123
|
|
|
|
|
|
|
$self->diag(<<'FAIL'); |
1124
|
|
|
|
|
|
|
Looks like your test died before it could output anything. |
1125
|
|
|
|
|
|
|
FAIL |
1126
|
0
|
|
|
0
|
1
|
0
|
_my_exit( 255 ) && return; |
1127
|
|
|
|
|
|
|
} |
1128
|
0
|
0
|
|
|
|
0
|
else { |
1129
|
0
|
0
|
|
|
|
0
|
$self->diag("No tests run!\n"); |
1130
|
|
|
|
|
|
|
_my_exit( 255 ) && return; |
1131
|
|
|
|
|
|
|
} |
1132
|
0
|
0
|
|
|
|
0
|
} |
1133
|
|
|
|
|
|
|
|
1134
|
|
|
|
|
|
|
END { |
1135
|
|
|
|
|
|
|
$Test->_ending if defined $Test and !$Test->no_ending; |
1136
|
0
|
0
|
|
|
|
0
|
} |
|
0
|
|
|
|
|
0
|
|
1137
|
|
|
|
|
|
|
|
1138
|
|
|
|
|
|
|
#line 1747 |
1139
|
0
|
|
|
|
|
0
|
|
1140
|
|
|
|
|
|
|
1; |