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