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
13 my($file, $line) = (caller(1))[1,2];
14 warn @_, " at $file line $line\n";
19 use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
21 $VERSION = eval $VERSION; # make the alpha version come out as a number
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
30 eq_array eq_hash eq_set
42 my $tb = Test::More->builder;
48 # This implements "use Test::More 'no_diag'" but the behavior is
56 while( $idx <= $#{$list} ) {
57 my $item = $list->[$idx];
59 if( defined $item and $item eq 'no_diag' ) {
60 $class->builder->no_diag(1);
76 my($test, $name) = @_;
77 my $tb = Test::More->builder;
79 $tb->ok($test, $name);
85 my $tb = Test::More->builder;
91 my $tb = Test::More->builder;
102 my $tb = Test::More->builder;
111 my $tb = Test::More->builder;
120 my $tb = Test::More->builder;
129 my($proto, @methods) = @_;
130 my $class = ref $proto || $proto;
131 my $tb = Test::More->builder;
134 my $ok = $tb->ok( 0, "$class->can(...)" );
135 $tb->diag(' can_ok() called with no methods');
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;
147 $name = @methods == 1 ? "$class->can('$methods[0]')"
148 : "$class->can(...)";
150 my $ok = $tb->ok( !@nok, $name );
152 $tb->diag(map " $class->can('$_') failed\n", @nok);
160 my($object, $class, $obj_name) = @_;
161 my $tb = Test::More->builder;
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";
169 elsif( !ref $object ) {
170 $diag = "$obj_name isn't a reference";
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) };
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'";
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.
192 my $ref = ref $object;
193 $diag = "$obj_name isn't a '$class' it's a '$ref'";
201 $ok = $tb->ok( 0, $name );
202 $tb->diag(" $diag\n");
205 $ok = $tb->ok( 1, $name );
215 my $tb = Test::More->builder;
220 my $tb = Test::More->builder;
227 my($module, @imports) = @_;
228 @imports = () unless @imports;
229 my $tb = Test::More->builder;
231 my($pack,$filename,$line) = caller;
233 local($@,$!); # eval sometimes interferes with $!
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.
240 use $module $imports[0];
246 use $module \@imports;
250 my $ok = $tb->ok( !$@, "use $module;" );
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'.
270 my $tb = Test::More->builder;
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);
278 local($!, $@); # eval sometimes interferes with $!
284 my $ok = $tb->ok( !$@, "require $module;" );
288 $tb->diag(<<DIAGNOSTIC);
289 Tried to require '$module'.
299 sub _is_module_name {
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*$/;
311 use vars qw(@Data_Stack %Refs_Seen);
312 my $DNE = bless [], 'Does::Not::Exist';
314 my $tb = Test::More->builder;
316 unless( @_ == 2 or @_ == 3 ) {
318 is_deeply() takes two or three args, you gave %d.
319 This usually means you passed an array or hash instead
322 chop $msg; # clip off newline so carp() will put in line/file
324 _carp sprintf $msg, scalar @_;
329 my($this, $that, $name) = @_;
331 $tb->_unoverload_str(\$that, \$this);
334 if( !ref $this and !ref $that ) { # neither is a reference
335 $ok = $tb->is_eq($this, $that, $name);
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 ] }) );
341 else { # both references
342 local @Data_Stack = ();
343 if( _deep_check($this, $that) ) {
344 $ok = $tb->ok(1, $name);
347 $ok = $tb->ok(0, $name);
348 $tb->diag(_format_stack(@Data_Stack));
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++;
367 elsif( $type eq 'ARRAY' ) {
368 $var .= "->" unless $did_arrow++;
371 elsif( $type eq 'REF' ) {
376 my @vals = @{$Stack[-1]{vals}}[0,1];
378 ($vars[0] = $var) =~ s/\$FOO/ \$got/;
379 ($vars[1] = $var) =~ s/\$FOO/\$expected/;
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" :
390 $out .= "$vars[0] = $vals[0]\n";
391 $out .= "$vars[1] = $vals[1]\n";
401 return '' if !ref $thing;
403 for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) {
404 return $type if UNIVERSAL::isa($thing, $type);
413 my $tb = Test::More->builder;
423 my($why, $how_many) = @_;
424 my $tb = Test::More->builder;
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';
433 for( 1..$how_many ) {
445 my($why, $how_many) = @_;
446 my $tb = Test::More->builder;
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';
455 for( 1..$how_many ) {
456 $tb->todo_skip($why);
467 my $tb = Test::More->builder;
469 $tb->BAIL_OUT($reason);
483 if( grep !_type($_) eq 'ARRAY', $a1, $a2 ) {
484 warn "eq_array passed a non-array ref";
488 return 1 if $a1 eq $a2;
491 my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
493 my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
494 my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
496 push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] };
497 $ok = _deep_check($e1,$e2);
498 pop @Data_Stack if $ok;
508 my $tb = Test::More->builder;
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
515 local %Refs_Seen = %Refs_Seen;
518 # Quiet uninitialized value warnings when comparing undefs.
521 $tb->_unoverload_str(\$e1, \$e2);
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);
527 if( defined $e1 xor defined $e2 ) {
530 elsif ( $e1 == $DNE xor $e2 == $DNE ) {
533 elsif ( $same_ref and ($e1 eq $e2) ) {
537 push @Data_Stack, { type => '', vals => [$e1, $e2] };
541 if( $Refs_Seen{$e1} ) {
542 return $Refs_Seen{$e1} eq $e2;
545 $Refs_Seen{$e1} = "$e2";
548 my $type = _type($e1);
549 $type = 'DIFFERENT' unless _type($e2) eq $type;
551 if( $type eq 'DIFFERENT' ) {
552 push @Data_Stack, { type => $type, vals => [$e1, $e2] };
555 elsif( $type eq 'ARRAY' ) {
556 $ok = _eq_array($e1, $e2);
558 elsif( $type eq 'HASH' ) {
559 $ok = _eq_hash($e1, $e2);
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;
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;
572 push @Data_Stack, { type => $type, vals => [$e1, $e2] };
576 _whoa(1, "No type in _deep_check");
586 my($check, $desc) = @_;
590 This should never happen! Please contact the author immediately!
600 return _deep_check(@_);
606 if( grep !_type($_) eq 'HASH', $a1, $a2 ) {
607 warn "eq_hash passed a non-hash ref";
611 return 1 if $a1 eq $a2;
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;
619 push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] };
620 $ok = _deep_check($e1, $e2);
621 pop @Data_Stack if $ok;
633 return 0 unless @$a1 == @$a2;
635 # There's faster ways to do this, but this is easiest.
638 # It really doesn't matter how we sort them, as long as both arrays are
639 # sorted with the same algorithm.
641 # Ensure that references are not accidentally treated the same as a
642 # string containing the reference.
644 # Have to inline the sort routine due to a threading/sort bug.
645 # See [rt.cpan.org 6782]
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.
650 [grep(ref, @$a1), sort( grep(!ref, @$a1) )],
651 [grep(ref, @$a2), sort( grep(!ref, @$a2) )],