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