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