Commit | Line | Data |
4679cf3f |
1 | #line 1 |
2 | package Test::More; |
3 | |
4 | use 5.004; |
5 | |
6 | use strict; |
7 | |
8 | |
9 | # Can't use Carp because it might cause use_ok() to accidentally succeed |
10 | # even though the module being used forgot to use Carp. Yes, this |
11 | # actually happened. |
12 | sub _carp { |
13 | my($file, $line) = (caller(1))[1,2]; |
14 | warn @_, " at $file line $line\n"; |
15 | } |
16 | |
17 | |
18 | |
19 | use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO); |
20 | $VERSION = '0.62'; |
21 | $VERSION = eval $VERSION; # make the alpha version come out as a number |
22 | |
23 | use Test::Builder::Module; |
24 | @ISA = qw(Test::Builder::Module); |
25 | @EXPORT = qw(ok use_ok require_ok |
26 | is isnt like unlike is_deeply |
27 | cmp_ok |
28 | skip todo todo_skip |
29 | pass fail |
30 | eq_array eq_hash eq_set |
31 | $TODO |
32 | plan |
33 | can_ok isa_ok |
34 | diag |
35 | BAIL_OUT |
36 | ); |
37 | |
38 | |
39 | #line 157 |
40 | |
41 | sub plan { |
42 | my $tb = Test::More->builder; |
43 | |
44 | $tb->plan(@_); |
45 | } |
46 | |
47 | |
48 | # This implements "use Test::More 'no_diag'" but the behavior is |
49 | # deprecated. |
50 | sub import_extra { |
51 | my $class = shift; |
52 | my $list = shift; |
53 | |
54 | my @other = (); |
55 | my $idx = 0; |
56 | while( $idx <= $#{$list} ) { |
57 | my $item = $list->[$idx]; |
58 | |
59 | if( defined $item and $item eq 'no_diag' ) { |
60 | $class->builder->no_diag(1); |
61 | } |
62 | else { |
63 | push @other, $item; |
64 | } |
65 | |
66 | $idx++; |
67 | } |
68 | |
69 | @$list = @other; |
70 | } |
71 | |
72 | |
73 | #line 257 |
74 | |
75 | sub ok ($;$) { |
76 | my($test, $name) = @_; |
77 | my $tb = Test::More->builder; |
78 | |
79 | $tb->ok($test, $name); |
80 | } |
81 | |
82 | #line 324 |
83 | |
84 | sub is ($$;$) { |
85 | my $tb = Test::More->builder; |
86 | |
87 | $tb->is_eq(@_); |
88 | } |
89 | |
90 | sub isnt ($$;$) { |
91 | my $tb = Test::More->builder; |
92 | |
93 | $tb->isnt_eq(@_); |
94 | } |
95 | |
96 | *isn't = \&isnt; |
97 | |
98 | |
99 | #line 369 |
100 | |
101 | sub like ($$;$) { |
102 | my $tb = Test::More->builder; |
103 | |
104 | $tb->like(@_); |
105 | } |
106 | |
107 | |
108 | #line 385 |
109 | |
110 | sub unlike ($$;$) { |
111 | my $tb = Test::More->builder; |
112 | |
113 | $tb->unlike(@_); |
114 | } |
115 | |
116 | |
117 | #line 425 |
118 | |
119 | sub cmp_ok($$$;$) { |
120 | my $tb = Test::More->builder; |
121 | |
122 | $tb->cmp_ok(@_); |
123 | } |
124 | |
125 | |
126 | #line 461 |
127 | |
128 | sub can_ok ($@) { |
129 | my($proto, @methods) = @_; |
130 | my $class = ref $proto || $proto; |
131 | my $tb = Test::More->builder; |
132 | |
133 | unless( @methods ) { |
134 | my $ok = $tb->ok( 0, "$class->can(...)" ); |
135 | $tb->diag(' can_ok() called with no methods'); |
136 | return $ok; |
137 | } |
138 | |
139 | my @nok = (); |
140 | foreach my $method (@methods) { |
141 | local($!, $@); # don't interfere with caller's $@ |
142 | # eval sometimes resets $! |
143 | eval { $proto->can($method) } || push @nok, $method; |
144 | } |
145 | |
146 | my $name; |
147 | $name = @methods == 1 ? "$class->can('$methods[0]')" |
148 | : "$class->can(...)"; |
149 | |
150 | my $ok = $tb->ok( !@nok, $name ); |
151 | |
152 | $tb->diag(map " $class->can('$_') failed\n", @nok); |
153 | |
154 | return $ok; |
155 | } |
156 | |
157 | #line 519 |
158 | |
159 | sub isa_ok ($$;$) { |
160 | my($object, $class, $obj_name) = @_; |
161 | my $tb = Test::More->builder; |
162 | |
163 | my $diag; |
164 | $obj_name = 'The object' unless defined $obj_name; |
165 | my $name = "$obj_name isa $class"; |
166 | if( !defined $object ) { |
167 | $diag = "$obj_name isn't defined"; |
168 | } |
169 | elsif( !ref $object ) { |
170 | $diag = "$obj_name isn't a reference"; |
171 | } |
172 | else { |
173 | # We can't use UNIVERSAL::isa because we want to honor isa() overrides |
174 | local($@, $!); # eval sometimes resets $! |
175 | my $rslt = eval { $object->isa($class) }; |
176 | if( $@ ) { |
177 | if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) { |
178 | if( !UNIVERSAL::isa($object, $class) ) { |
179 | my $ref = ref $object; |
180 | $diag = "$obj_name isn't a '$class' it's a '$ref'"; |
181 | } |
182 | } else { |
183 | die <<WHOA; |
184 | WHOA! I tried to call ->isa on your object and got some weird error. |
185 | This should never happen. Please contact the author immediately. |
186 | Here's the error. |
187 | $@ |
188 | WHOA |
189 | } |
190 | } |
191 | elsif( !$rslt ) { |
192 | my $ref = ref $object; |
193 | $diag = "$obj_name isn't a '$class' it's a '$ref'"; |
194 | } |
195 | } |
196 | |
197 | |
198 | |
199 | my $ok; |
200 | if( $diag ) { |
201 | $ok = $tb->ok( 0, $name ); |
202 | $tb->diag(" $diag\n"); |
203 | } |
204 | else { |
205 | $ok = $tb->ok( 1, $name ); |
206 | } |
207 | |
208 | return $ok; |
209 | } |
210 | |
211 | |
212 | #line 589 |
213 | |
214 | sub pass (;$) { |
215 | my $tb = Test::More->builder; |
216 | $tb->ok(1, @_); |
217 | } |
218 | |
219 | sub fail (;$) { |
220 | my $tb = Test::More->builder; |
221 | $tb->ok(0, @_); |
222 | } |
223 | |
224 | #line 650 |
225 | |
226 | sub use_ok ($;@) { |
227 | my($module, @imports) = @_; |
228 | @imports = () unless @imports; |
229 | my $tb = Test::More->builder; |
230 | |
231 | my($pack,$filename,$line) = caller; |
232 | |
233 | local($@,$!); # eval sometimes interferes with $! |
234 | |
235 | if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) { |
236 | # probably a version check. Perl needs to see the bare number |
237 | # for it to work with non-Exporter based modules. |
238 | eval <<USE; |
239 | package $pack; |
240 | use $module $imports[0]; |
241 | USE |
242 | } |
243 | else { |
244 | eval <<USE; |
245 | package $pack; |
246 | use $module \@imports; |
247 | USE |
248 | } |
249 | |
250 | my $ok = $tb->ok( !$@, "use $module;" ); |
251 | |
252 | unless( $ok ) { |
253 | chomp $@; |
254 | $@ =~ s{^BEGIN failed--compilation aborted at .*$} |
255 | {BEGIN failed--compilation aborted at $filename line $line.}m; |
256 | $tb->diag(<<DIAGNOSTIC); |
257 | Tried to use '$module'. |
258 | Error: $@ |
259 | DIAGNOSTIC |
260 | |
261 | } |
262 | |
263 | return $ok; |
264 | } |
265 | |
266 | #line 699 |
267 | |
268 | sub require_ok ($) { |
269 | my($module) = shift; |
270 | my $tb = Test::More->builder; |
271 | |
272 | my $pack = caller; |
273 | |
274 | # Try to deterine if we've been given a module name or file. |
275 | # Module names must be barewords, files not. |
276 | $module = qq['$module'] unless _is_module_name($module); |
277 | |
278 | local($!, $@); # eval sometimes interferes with $! |
279 | eval <<REQUIRE; |
280 | package $pack; |
281 | require $module; |
282 | REQUIRE |
283 | |
284 | my $ok = $tb->ok( !$@, "require $module;" ); |
285 | |
286 | unless( $ok ) { |
287 | chomp $@; |
288 | $tb->diag(<<DIAGNOSTIC); |
289 | Tried to require '$module'. |
290 | Error: $@ |
291 | DIAGNOSTIC |
292 | |
293 | } |
294 | |
295 | return $ok; |
296 | } |
297 | |
298 | |
299 | sub _is_module_name { |
300 | my $module = shift; |
301 | |
302 | # Module names start with a letter. |
303 | # End with an alphanumeric. |
304 | # The rest is an alphanumeric or :: |
305 | $module =~ s/\b::\b//g; |
306 | $module =~ /^[a-zA-Z]\w*$/; |
307 | } |
308 | |
309 | #line 775 |
310 | |
311 | use vars qw(@Data_Stack %Refs_Seen); |
312 | my $DNE = bless [], 'Does::Not::Exist'; |
313 | sub is_deeply { |
314 | my $tb = Test::More->builder; |
315 | |
316 | unless( @_ == 2 or @_ == 3 ) { |
317 | my $msg = <<WARNING; |
318 | is_deeply() takes two or three args, you gave %d. |
319 | This usually means you passed an array or hash instead |
320 | of a reference to it |
321 | WARNING |
322 | chop $msg; # clip off newline so carp() will put in line/file |
323 | |
324 | _carp sprintf $msg, scalar @_; |
325 | |
326 | return $tb->ok(0); |
327 | } |
328 | |
329 | my($this, $that, $name) = @_; |
330 | |
331 | $tb->_unoverload_str(\$that, \$this); |
332 | |
333 | my $ok; |
334 | if( !ref $this and !ref $that ) { # neither is a reference |
335 | $ok = $tb->is_eq($this, $that, $name); |
336 | } |
337 | elsif( !ref $this xor !ref $that ) { # one's a reference, one isn't |
338 | $ok = $tb->ok(0, $name); |
339 | $tb->diag( _format_stack({ vals => [ $this, $that ] }) ); |
340 | } |
341 | else { # both references |
342 | local @Data_Stack = (); |
343 | if( _deep_check($this, $that) ) { |
344 | $ok = $tb->ok(1, $name); |
345 | } |
346 | else { |
347 | $ok = $tb->ok(0, $name); |
348 | $tb->diag(_format_stack(@Data_Stack)); |
349 | } |
350 | } |
351 | |
352 | return $ok; |
353 | } |
354 | |
355 | sub _format_stack { |
356 | my(@Stack) = @_; |
357 | |
358 | my $var = '$FOO'; |
359 | my $did_arrow = 0; |
360 | foreach my $entry (@Stack) { |
361 | my $type = $entry->{type} || ''; |
362 | my $idx = $entry->{'idx'}; |
363 | if( $type eq 'HASH' ) { |
364 | $var .= "->" unless $did_arrow++; |
365 | $var .= "{$idx}"; |
366 | } |
367 | elsif( $type eq 'ARRAY' ) { |
368 | $var .= "->" unless $did_arrow++; |
369 | $var .= "[$idx]"; |
370 | } |
371 | elsif( $type eq 'REF' ) { |
372 | $var = "\${$var}"; |
373 | } |
374 | } |
375 | |
376 | my @vals = @{$Stack[-1]{vals}}[0,1]; |
377 | my @vars = (); |
378 | ($vars[0] = $var) =~ s/\$FOO/ \$got/; |
379 | ($vars[1] = $var) =~ s/\$FOO/\$expected/; |
380 | |
381 | my $out = "Structures begin differing at:\n"; |
382 | foreach my $idx (0..$#vals) { |
383 | my $val = $vals[$idx]; |
384 | $vals[$idx] = !defined $val ? 'undef' : |
385 | $val eq $DNE ? "Does not exist" : |
386 | ref $val ? "$val" : |
387 | "'$val'"; |
388 | } |
389 | |
390 | $out .= "$vars[0] = $vals[0]\n"; |
391 | $out .= "$vars[1] = $vals[1]\n"; |
392 | |
393 | $out =~ s/^/ /msg; |
394 | return $out; |
395 | } |
396 | |
397 | |
398 | sub _type { |
399 | my $thing = shift; |
400 | |
401 | return '' if !ref $thing; |
402 | |
403 | for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) { |
404 | return $type if UNIVERSAL::isa($thing, $type); |
405 | } |
406 | |
407 | return ''; |
408 | } |
409 | |
410 | #line 915 |
411 | |
412 | sub diag { |
413 | my $tb = Test::More->builder; |
414 | |
415 | $tb->diag(@_); |
416 | } |
417 | |
418 | |
419 | #line 984 |
420 | |
421 | #'# |
422 | sub skip { |
423 | my($why, $how_many) = @_; |
424 | my $tb = Test::More->builder; |
425 | |
426 | unless( defined $how_many ) { |
427 | # $how_many can only be avoided when no_plan is in use. |
428 | _carp "skip() needs to know \$how_many tests are in the block" |
429 | unless $tb->has_plan eq 'no_plan'; |
430 | $how_many = 1; |
431 | } |
432 | |
433 | for( 1..$how_many ) { |
434 | $tb->skip($why); |
435 | } |
436 | |
437 | local $^W = 0; |
438 | last SKIP; |
439 | } |
440 | |
441 | |
442 | #line 1066 |
443 | |
444 | sub todo_skip { |
445 | my($why, $how_many) = @_; |
446 | my $tb = Test::More->builder; |
447 | |
448 | unless( defined $how_many ) { |
449 | # $how_many can only be avoided when no_plan is in use. |
450 | _carp "todo_skip() needs to know \$how_many tests are in the block" |
451 | unless $tb->has_plan eq 'no_plan'; |
452 | $how_many = 1; |
453 | } |
454 | |
455 | for( 1..$how_many ) { |
456 | $tb->todo_skip($why); |
457 | } |
458 | |
459 | local $^W = 0; |
460 | last TODO; |
461 | } |
462 | |
463 | #line 1119 |
464 | |
465 | sub BAIL_OUT { |
466 | my $reason = shift; |
467 | my $tb = Test::More->builder; |
468 | |
469 | $tb->BAIL_OUT($reason); |
470 | } |
471 | |
472 | #line 1158 |
473 | |
474 | #'# |
475 | sub eq_array { |
476 | local @Data_Stack; |
477 | _deep_check(@_); |
478 | } |
479 | |
480 | sub _eq_array { |
481 | my($a1, $a2) = @_; |
482 | |
483 | if( grep !_type($_) eq 'ARRAY', $a1, $a2 ) { |
484 | warn "eq_array passed a non-array ref"; |
485 | return 0; |
486 | } |
487 | |
488 | return 1 if $a1 eq $a2; |
489 | |
490 | my $ok = 1; |
491 | my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; |
492 | for (0..$max) { |
493 | my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; |
494 | my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; |
495 | |
496 | push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] }; |
497 | $ok = _deep_check($e1,$e2); |
498 | pop @Data_Stack if $ok; |
499 | |
500 | last unless $ok; |
501 | } |
502 | |
503 | return $ok; |
504 | } |
505 | |
506 | sub _deep_check { |
507 | my($e1, $e2) = @_; |
508 | my $tb = Test::More->builder; |
509 | |
510 | my $ok = 0; |
511 | |
512 | # Effectively turn %Refs_Seen into a stack. This avoids picking up |
513 | # the same referenced used twice (such as [\$a, \$a]) to be considered |
514 | # circular. |
515 | local %Refs_Seen = %Refs_Seen; |
516 | |
517 | { |
518 | # Quiet uninitialized value warnings when comparing undefs. |
519 | local $^W = 0; |
520 | |
521 | $tb->_unoverload_str(\$e1, \$e2); |
522 | |
523 | # Either they're both references or both not. |
524 | my $same_ref = !(!ref $e1 xor !ref $e2); |
525 | my $not_ref = (!ref $e1 and !ref $e2); |
526 | |
527 | if( defined $e1 xor defined $e2 ) { |
528 | $ok = 0; |
529 | } |
530 | elsif ( $e1 == $DNE xor $e2 == $DNE ) { |
531 | $ok = 0; |
532 | } |
533 | elsif ( $same_ref and ($e1 eq $e2) ) { |
534 | $ok = 1; |
535 | } |
536 | elsif ( $not_ref ) { |
537 | push @Data_Stack, { type => '', vals => [$e1, $e2] }; |
538 | $ok = 0; |
539 | } |
540 | else { |
541 | if( $Refs_Seen{$e1} ) { |
542 | return $Refs_Seen{$e1} eq $e2; |
543 | } |
544 | else { |
545 | $Refs_Seen{$e1} = "$e2"; |
546 | } |
547 | |
548 | my $type = _type($e1); |
549 | $type = 'DIFFERENT' unless _type($e2) eq $type; |
550 | |
551 | if( $type eq 'DIFFERENT' ) { |
552 | push @Data_Stack, { type => $type, vals => [$e1, $e2] }; |
553 | $ok = 0; |
554 | } |
555 | elsif( $type eq 'ARRAY' ) { |
556 | $ok = _eq_array($e1, $e2); |
557 | } |
558 | elsif( $type eq 'HASH' ) { |
559 | $ok = _eq_hash($e1, $e2); |
560 | } |
561 | elsif( $type eq 'REF' ) { |
562 | push @Data_Stack, { type => $type, vals => [$e1, $e2] }; |
563 | $ok = _deep_check($$e1, $$e2); |
564 | pop @Data_Stack if $ok; |
565 | } |
566 | elsif( $type eq 'SCALAR' ) { |
567 | push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; |
568 | $ok = _deep_check($$e1, $$e2); |
569 | pop @Data_Stack if $ok; |
570 | } |
571 | elsif( $type ) { |
572 | push @Data_Stack, { type => $type, vals => [$e1, $e2] }; |
573 | $ok = 0; |
574 | } |
575 | else { |
576 | _whoa(1, "No type in _deep_check"); |
577 | } |
578 | } |
579 | } |
580 | |
581 | return $ok; |
582 | } |
583 | |
584 | |
585 | sub _whoa { |
586 | my($check, $desc) = @_; |
587 | if( $check ) { |
588 | die <<WHOA; |
589 | WHOA! $desc |
590 | This should never happen! Please contact the author immediately! |
591 | WHOA |
592 | } |
593 | } |
594 | |
595 | |
596 | #line 1289 |
597 | |
598 | sub eq_hash { |
599 | local @Data_Stack; |
600 | return _deep_check(@_); |
601 | } |
602 | |
603 | sub _eq_hash { |
604 | my($a1, $a2) = @_; |
605 | |
606 | if( grep !_type($_) eq 'HASH', $a1, $a2 ) { |
607 | warn "eq_hash passed a non-hash ref"; |
608 | return 0; |
609 | } |
610 | |
611 | return 1 if $a1 eq $a2; |
612 | |
613 | my $ok = 1; |
614 | my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; |
615 | foreach my $k (keys %$bigger) { |
616 | my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; |
617 | my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; |
618 | |
619 | push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] }; |
620 | $ok = _deep_check($e1, $e2); |
621 | pop @Data_Stack if $ok; |
622 | |
623 | last unless $ok; |
624 | } |
625 | |
626 | return $ok; |
627 | } |
628 | |
629 | #line 1346 |
630 | |
631 | sub eq_set { |
632 | my($a1, $a2) = @_; |
633 | return 0 unless @$a1 == @$a2; |
634 | |
635 | # There's faster ways to do this, but this is easiest. |
636 | local $^W = 0; |
637 | |
638 | # It really doesn't matter how we sort them, as long as both arrays are |
639 | # sorted with the same algorithm. |
640 | # |
641 | # Ensure that references are not accidentally treated the same as a |
642 | # string containing the reference. |
643 | # |
644 | # Have to inline the sort routine due to a threading/sort bug. |
645 | # See [rt.cpan.org 6782] |
646 | # |
647 | # I don't know how references would be sorted so we just don't sort |
648 | # them. This means eq_set doesn't really work with refs. |
649 | return eq_array( |
650 | [grep(ref, @$a1), sort( grep(!ref, @$a1) )], |
651 | [grep(ref, @$a2), sort( grep(!ref, @$a2) )], |
652 | ); |
653 | } |
654 | |
655 | #line 1534 |
656 | |
657 | 1; |