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