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