1package Test::More; 2 3use 5.006; 4use strict; 5use warnings; 6 7#---- perlcritic exemptions. ----# 8 9# We use a lot of subroutine prototypes 10## no critic (Subroutines::ProhibitSubroutinePrototypes) 11 12# Can't use Carp because it might cause C<use_ok()> to accidentally succeed 13# even though the module being used forgot to use Carp. Yes, this 14# actually happened. 15sub _carp { 16 my( $file, $line ) = ( caller(1) )[ 1, 2 ]; 17 return warn @_, " at $file line $line\n"; 18} 19 20our $VERSION = '1.302133'; 21 22use Test::Builder::Module; 23our @ISA = qw(Test::Builder::Module); 24our @EXPORT = qw(ok use_ok require_ok 25 is isnt like unlike is_deeply 26 cmp_ok 27 skip todo todo_skip 28 pass fail 29 eq_array eq_hash eq_set 30 $TODO 31 plan 32 done_testing 33 can_ok isa_ok new_ok 34 diag note explain 35 subtest 36 BAIL_OUT 37); 38 39=head1 NAME 40 41Test::More - yet another framework for writing test scripts 42 43=head1 SYNOPSIS 44 45 use Test::More tests => 23; 46 # or 47 use Test::More skip_all => $reason; 48 # or 49 use Test::More; # see done_testing() 50 51 require_ok( 'Some::Module' ); 52 53 # Various ways to say "ok" 54 ok($got eq $expected, $test_name); 55 56 is ($got, $expected, $test_name); 57 isnt($got, $expected, $test_name); 58 59 # Rather than print STDERR "# here's what went wrong\n" 60 diag("here's what went wrong"); 61 62 like ($got, qr/expected/, $test_name); 63 unlike($got, qr/expected/, $test_name); 64 65 cmp_ok($got, '==', $expected, $test_name); 66 67 is_deeply($got_complex_structure, $expected_complex_structure, $test_name); 68 69 SKIP: { 70 skip $why, $how_many unless $have_some_feature; 71 72 ok( foo(), $test_name ); 73 is( foo(42), 23, $test_name ); 74 }; 75 76 TODO: { 77 local $TODO = $why; 78 79 ok( foo(), $test_name ); 80 is( foo(42), 23, $test_name ); 81 }; 82 83 can_ok($module, @methods); 84 isa_ok($object, $class); 85 86 pass($test_name); 87 fail($test_name); 88 89 BAIL_OUT($why); 90 91 # UNIMPLEMENTED!!! 92 my @status = Test::More::status; 93 94 95=head1 DESCRIPTION 96 97B<STOP!> If you're just getting started writing tests, have a look at 98L<Test::Simple> first. This is a drop in replacement for Test::Simple 99which you can switch to once you get the hang of basic testing. 100 101The purpose of this module is to provide a wide range of testing 102utilities. Various ways to say "ok" with better diagnostics, 103facilities to skip tests, test future features and compare complicated 104data structures. While you can do almost anything with a simple 105C<ok()> function, it doesn't provide good diagnostic output. 106 107 108=head2 I love it when a plan comes together 109 110Before anything else, you need a testing plan. This basically declares 111how many tests your script is going to run to protect against premature 112failure. 113 114The preferred way to do this is to declare a plan when you C<use Test::More>. 115 116 use Test::More tests => 23; 117 118There are cases when you will not know beforehand how many tests your 119script is going to run. In this case, you can declare your tests at 120the end. 121 122 use Test::More; 123 124 ... run your tests ... 125 126 done_testing( $number_of_tests_run ); 127 128B<NOTE> C<done_testing()> should never be called in an C<END { ... }> block. 129 130Sometimes you really don't know how many tests were run, or it's too 131difficult to calculate. In which case you can leave off 132$number_of_tests_run. 133 134In some cases, you'll want to completely skip an entire testing script. 135 136 use Test::More skip_all => $skip_reason; 137 138Your script will declare a skip with the reason why you skipped and 139exit immediately with a zero (success). See L<Test::Harness> for 140details. 141 142If you want to control what functions Test::More will export, you 143have to use the 'import' option. For example, to import everything 144but 'fail', you'd do: 145 146 use Test::More tests => 23, import => ['!fail']; 147 148Alternatively, you can use the C<plan()> function. Useful for when you 149have to calculate the number of tests. 150 151 use Test::More; 152 plan tests => keys %Stuff * 3; 153 154or for deciding between running the tests at all: 155 156 use Test::More; 157 if( $^O eq 'MacOS' ) { 158 plan skip_all => 'Test irrelevant on MacOS'; 159 } 160 else { 161 plan tests => 42; 162 } 163 164=cut 165 166sub plan { 167 my $tb = Test::More->builder; 168 169 return $tb->plan(@_); 170} 171 172# This implements "use Test::More 'no_diag'" but the behavior is 173# deprecated. 174sub import_extra { 175 my $class = shift; 176 my $list = shift; 177 178 my @other = (); 179 my $idx = 0; 180 my $import; 181 while( $idx <= $#{$list} ) { 182 my $item = $list->[$idx]; 183 184 if( defined $item and $item eq 'no_diag' ) { 185 $class->builder->no_diag(1); 186 } 187 elsif( defined $item and $item eq 'import' ) { 188 if ($import) { 189 push @$import, @{$list->[ ++$idx ]}; 190 } 191 else { 192 $import = $list->[ ++$idx ]; 193 push @other, $item, $import; 194 } 195 } 196 else { 197 push @other, $item; 198 } 199 200 $idx++; 201 } 202 203 @$list = @other; 204 205 if ($class eq __PACKAGE__ && (!$import || grep $_ eq '$TODO', @$import)) { 206 my $to = $class->builder->exported_to; 207 no strict 'refs'; 208 *{"$to\::TODO"} = \our $TODO; 209 if ($import) { 210 @$import = grep $_ ne '$TODO', @$import; 211 } 212 else { 213 push @$list, import => [grep $_ ne '$TODO', @EXPORT]; 214 } 215 } 216 217 return; 218} 219 220=over 4 221 222=item B<done_testing> 223 224 done_testing(); 225 done_testing($number_of_tests); 226 227If you don't know how many tests you're going to run, you can issue 228the plan when you're done running tests. 229 230$number_of_tests is the same as C<plan()>, it's the number of tests you 231expected to run. You can omit this, in which case the number of tests 232you ran doesn't matter, just the fact that your tests ran to 233conclusion. 234 235This is safer than and replaces the "no_plan" plan. 236 237B<Note:> You must never put C<done_testing()> inside an C<END { ... }> block. 238The plan is there to ensure your test does not exit before testing has 239completed. If you use an END block you completely bypass this protection. 240 241=back 242 243=cut 244 245sub done_testing { 246 my $tb = Test::More->builder; 247 $tb->done_testing(@_); 248} 249 250=head2 Test names 251 252By convention, each test is assigned a number in order. This is 253largely done automatically for you. However, it's often very useful to 254assign a name to each test. Which would you rather see: 255 256 ok 4 257 not ok 5 258 ok 6 259 260or 261 262 ok 4 - basic multi-variable 263 not ok 5 - simple exponential 264 ok 6 - force == mass * acceleration 265 266The later gives you some idea of what failed. It also makes it easier 267to find the test in your script, simply search for "simple 268exponential". 269 270All test functions take a name argument. It's optional, but highly 271suggested that you use it. 272 273=head2 I'm ok, you're not ok. 274 275The basic purpose of this module is to print out either "ok #" or "not 276ok #" depending on if a given test succeeded or failed. Everything 277else is just gravy. 278 279All of the following print "ok" or "not ok" depending on if the test 280succeeded or failed. They all also return true or false, 281respectively. 282 283=over 4 284 285=item B<ok> 286 287 ok($got eq $expected, $test_name); 288 289This simply evaluates any expression (C<$got eq $expected> is just a 290simple example) and uses that to determine if the test succeeded or 291failed. A true expression passes, a false one fails. Very simple. 292 293For example: 294 295 ok( $exp{9} == 81, 'simple exponential' ); 296 ok( Film->can('db_Main'), 'set_db()' ); 297 ok( $p->tests == 4, 'saw tests' ); 298 ok( !grep(!defined $_, @items), 'all items defined' ); 299 300(Mnemonic: "This is ok.") 301 302$test_name is a very short description of the test that will be printed 303out. It makes it very easy to find a test in your script when it fails 304and gives others an idea of your intentions. $test_name is optional, 305but we B<very> strongly encourage its use. 306 307Should an C<ok()> fail, it will produce some diagnostics: 308 309 not ok 18 - sufficient mucus 310 # Failed test 'sufficient mucus' 311 # in foo.t at line 42. 312 313This is the same as L<Test::Simple>'s C<ok()> routine. 314 315=cut 316 317sub ok ($;$) { 318 my( $test, $name ) = @_; 319 my $tb = Test::More->builder; 320 321 return $tb->ok( $test, $name ); 322} 323 324=item B<is> 325 326=item B<isnt> 327 328 is ( $got, $expected, $test_name ); 329 isnt( $got, $expected, $test_name ); 330 331Similar to C<ok()>, C<is()> and C<isnt()> compare their two arguments 332with C<eq> and C<ne> respectively and use the result of that to 333determine if the test succeeded or failed. So these: 334 335 # Is the ultimate answer 42? 336 is( ultimate_answer(), 42, "Meaning of Life" ); 337 338 # $foo isn't empty 339 isnt( $foo, '', "Got some foo" ); 340 341are similar to these: 342 343 ok( ultimate_answer() eq 42, "Meaning of Life" ); 344 ok( $foo ne '', "Got some foo" ); 345 346C<undef> will only ever match C<undef>. So you can test a value 347against C<undef> like this: 348 349 is($not_defined, undef, "undefined as expected"); 350 351(Mnemonic: "This is that." "This isn't that.") 352 353So why use these? They produce better diagnostics on failure. C<ok()> 354cannot know what you are testing for (beyond the name), but C<is()> and 355C<isnt()> know what the test was and why it failed. For example this 356test: 357 358 my $foo = 'waffle'; my $bar = 'yarblokos'; 359 is( $foo, $bar, 'Is foo the same as bar?' ); 360 361Will produce something like this: 362 363 not ok 17 - Is foo the same as bar? 364 # Failed test 'Is foo the same as bar?' 365 # in foo.t at line 139. 366 # got: 'waffle' 367 # expected: 'yarblokos' 368 369So you can figure out what went wrong without rerunning the test. 370 371You are encouraged to use C<is()> and C<isnt()> over C<ok()> where possible, 372however do not be tempted to use them to find out if something is 373true or false! 374 375 # XXX BAD! 376 is( exists $brooklyn{tree}, 1, 'A tree grows in Brooklyn' ); 377 378This does not check if C<exists $brooklyn{tree}> is true, it checks if 379it returns 1. Very different. Similar caveats exist for false and 0. 380In these cases, use C<ok()>. 381 382 ok( exists $brooklyn{tree}, 'A tree grows in Brooklyn' ); 383 384A simple call to C<isnt()> usually does not provide a strong test but there 385are cases when you cannot say much more about a value than that it is 386different from some other value: 387 388 new_ok $obj, "Foo"; 389 390 my $clone = $obj->clone; 391 isa_ok $obj, "Foo", "Foo->clone"; 392 393 isnt $obj, $clone, "clone() produces a different object"; 394 395For those grammatical pedants out there, there's an C<isn't()> 396function which is an alias of C<isnt()>. 397 398=cut 399 400sub is ($$;$) { 401 my $tb = Test::More->builder; 402 403 return $tb->is_eq(@_); 404} 405 406sub isnt ($$;$) { 407 my $tb = Test::More->builder; 408 409 return $tb->isnt_eq(@_); 410} 411 412*isn't = \&isnt; 413# ' to unconfuse syntax higlighters 414 415=item B<like> 416 417 like( $got, qr/expected/, $test_name ); 418 419Similar to C<ok()>, C<like()> matches $got against the regex C<qr/expected/>. 420 421So this: 422 423 like($got, qr/expected/, 'this is like that'); 424 425is similar to: 426 427 ok( $got =~ m/expected/, 'this is like that'); 428 429(Mnemonic "This is like that".) 430 431The second argument is a regular expression. It may be given as a 432regex reference (i.e. C<qr//>) or (for better compatibility with older 433perls) as a string that looks like a regex (alternative delimiters are 434currently not supported): 435 436 like( $got, '/expected/', 'this is like that' ); 437 438Regex options may be placed on the end (C<'/expected/i'>). 439 440Its advantages over C<ok()> are similar to that of C<is()> and C<isnt()>. Better 441diagnostics on failure. 442 443=cut 444 445sub like ($$;$) { 446 my $tb = Test::More->builder; 447 448 return $tb->like(@_); 449} 450 451=item B<unlike> 452 453 unlike( $got, qr/expected/, $test_name ); 454 455Works exactly as C<like()>, only it checks if $got B<does not> match the 456given pattern. 457 458=cut 459 460sub unlike ($$;$) { 461 my $tb = Test::More->builder; 462 463 return $tb->unlike(@_); 464} 465 466=item B<cmp_ok> 467 468 cmp_ok( $got, $op, $expected, $test_name ); 469 470Halfway between C<ok()> and C<is()> lies C<cmp_ok()>. This allows you 471to compare two arguments using any binary perl operator. The test 472passes if the comparison is true and fails otherwise. 473 474 # ok( $got eq $expected ); 475 cmp_ok( $got, 'eq', $expected, 'this eq that' ); 476 477 # ok( $got == $expected ); 478 cmp_ok( $got, '==', $expected, 'this == that' ); 479 480 # ok( $got && $expected ); 481 cmp_ok( $got, '&&', $expected, 'this && that' ); 482 ...etc... 483 484Its advantage over C<ok()> is when the test fails you'll know what $got 485and $expected were: 486 487 not ok 1 488 # Failed test in foo.t at line 12. 489 # '23' 490 # && 491 # undef 492 493It's also useful in those cases where you are comparing numbers and 494C<is()>'s use of C<eq> will interfere: 495 496 cmp_ok( $big_hairy_number, '==', $another_big_hairy_number ); 497 498It's especially useful when comparing greater-than or smaller-than 499relation between values: 500 501 cmp_ok( $some_value, '<=', $upper_limit ); 502 503 504=cut 505 506sub cmp_ok($$$;$) { 507 my $tb = Test::More->builder; 508 509 return $tb->cmp_ok(@_); 510} 511 512=item B<can_ok> 513 514 can_ok($module, @methods); 515 can_ok($object, @methods); 516 517Checks to make sure the $module or $object can do these @methods 518(works with functions, too). 519 520 can_ok('Foo', qw(this that whatever)); 521 522is almost exactly like saying: 523 524 ok( Foo->can('this') && 525 Foo->can('that') && 526 Foo->can('whatever') 527 ); 528 529only without all the typing and with a better interface. Handy for 530quickly testing an interface. 531 532No matter how many @methods you check, a single C<can_ok()> call counts 533as one test. If you desire otherwise, use: 534 535 foreach my $meth (@methods) { 536 can_ok('Foo', $meth); 537 } 538 539=cut 540 541sub can_ok ($@) { 542 my( $proto, @methods ) = @_; 543 my $class = ref $proto || $proto; 544 my $tb = Test::More->builder; 545 546 unless($class) { 547 my $ok = $tb->ok( 0, "->can(...)" ); 548 $tb->diag(' can_ok() called with empty class or reference'); 549 return $ok; 550 } 551 552 unless(@methods) { 553 my $ok = $tb->ok( 0, "$class->can(...)" ); 554 $tb->diag(' can_ok() called with no methods'); 555 return $ok; 556 } 557 558 my @nok = (); 559 foreach my $method (@methods) { 560 $tb->_try( sub { $proto->can($method) } ) or push @nok, $method; 561 } 562 563 my $name = (@methods == 1) ? "$class->can('$methods[0]')" : 564 "$class->can(...)" ; 565 566 my $ok = $tb->ok( !@nok, $name ); 567 568 $tb->diag( map " $class->can('$_') failed\n", @nok ); 569 570 return $ok; 571} 572 573=item B<isa_ok> 574 575 isa_ok($object, $class, $object_name); 576 isa_ok($subclass, $class, $object_name); 577 isa_ok($ref, $type, $ref_name); 578 579Checks to see if the given C<< $object->isa($class) >>. Also checks to make 580sure the object was defined in the first place. Handy for this sort 581of thing: 582 583 my $obj = Some::Module->new; 584 isa_ok( $obj, 'Some::Module' ); 585 586where you'd otherwise have to write 587 588 my $obj = Some::Module->new; 589 ok( defined $obj && $obj->isa('Some::Module') ); 590 591to safeguard against your test script blowing up. 592 593You can also test a class, to make sure that it has the right ancestor: 594 595 isa_ok( 'Vole', 'Rodent' ); 596 597It works on references, too: 598 599 isa_ok( $array_ref, 'ARRAY' ); 600 601The diagnostics of this test normally just refer to 'the object'. If 602you'd like them to be more specific, you can supply an $object_name 603(for example 'Test customer'). 604 605=cut 606 607sub isa_ok ($$;$) { 608 my( $thing, $class, $thing_name ) = @_; 609 my $tb = Test::More->builder; 610 611 my $whatami; 612 if( !defined $thing ) { 613 $whatami = 'undef'; 614 } 615 elsif( ref $thing ) { 616 $whatami = 'reference'; 617 618 local($@,$!); 619 require Scalar::Util; 620 if( Scalar::Util::blessed($thing) ) { 621 $whatami = 'object'; 622 } 623 } 624 else { 625 $whatami = 'class'; 626 } 627 628 # We can't use UNIVERSAL::isa because we want to honor isa() overrides 629 my( $rslt, $error ) = $tb->_try( sub { $thing->isa($class) } ); 630 631 if($error) { 632 die <<WHOA unless $error =~ /^Can't (locate|call) method "isa"/; 633WHOA! I tried to call ->isa on your $whatami and got some weird error. 634Here's the error. 635$error 636WHOA 637 } 638 639 # Special case for isa_ok( [], "ARRAY" ) and like 640 if( $whatami eq 'reference' ) { 641 $rslt = UNIVERSAL::isa($thing, $class); 642 } 643 644 my($diag, $name); 645 if( defined $thing_name ) { 646 $name = "'$thing_name' isa '$class'"; 647 $diag = defined $thing ? "'$thing_name' isn't a '$class'" : "'$thing_name' isn't defined"; 648 } 649 elsif( $whatami eq 'object' ) { 650 my $my_class = ref $thing; 651 $thing_name = qq[An object of class '$my_class']; 652 $name = "$thing_name isa '$class'"; 653 $diag = "The object of class '$my_class' isn't a '$class'"; 654 } 655 elsif( $whatami eq 'reference' ) { 656 my $type = ref $thing; 657 $thing_name = qq[A reference of type '$type']; 658 $name = "$thing_name isa '$class'"; 659 $diag = "The reference of type '$type' isn't a '$class'"; 660 } 661 elsif( $whatami eq 'undef' ) { 662 $thing_name = 'undef'; 663 $name = "$thing_name isa '$class'"; 664 $diag = "$thing_name isn't defined"; 665 } 666 elsif( $whatami eq 'class' ) { 667 $thing_name = qq[The class (or class-like) '$thing']; 668 $name = "$thing_name isa '$class'"; 669 $diag = "$thing_name isn't a '$class'"; 670 } 671 else { 672 die; 673 } 674 675 my $ok; 676 if($rslt) { 677 $ok = $tb->ok( 1, $name ); 678 } 679 else { 680 $ok = $tb->ok( 0, $name ); 681 $tb->diag(" $diag\n"); 682 } 683 684 return $ok; 685} 686 687=item B<new_ok> 688 689 my $obj = new_ok( $class ); 690 my $obj = new_ok( $class => \@args ); 691 my $obj = new_ok( $class => \@args, $object_name ); 692 693A convenience function which combines creating an object and calling 694C<isa_ok()> on that object. 695 696It is basically equivalent to: 697 698 my $obj = $class->new(@args); 699 isa_ok $obj, $class, $object_name; 700 701If @args is not given, an empty list will be used. 702 703This function only works on C<new()> and it assumes C<new()> will return 704just a single object which isa C<$class>. 705 706=cut 707 708sub new_ok { 709 my $tb = Test::More->builder; 710 $tb->croak("new_ok() must be given at least a class") unless @_; 711 712 my( $class, $args, $object_name ) = @_; 713 714 $args ||= []; 715 716 my $obj; 717 my( $success, $error ) = $tb->_try( sub { $obj = $class->new(@$args); 1 } ); 718 if($success) { 719 local $Test::Builder::Level = $Test::Builder::Level + 1; 720 isa_ok $obj, $class, $object_name; 721 } 722 else { 723 $class = 'undef' if !defined $class; 724 $tb->ok( 0, "$class->new() died" ); 725 $tb->diag(" Error was: $error"); 726 } 727 728 return $obj; 729} 730 731=item B<subtest> 732 733 subtest $name => \&code, @args; 734 735C<subtest()> runs the &code as its own little test with its own plan and 736its own result. The main test counts this as a single test using the 737result of the whole subtest to determine if its ok or not ok. 738 739For example... 740 741 use Test::More tests => 3; 742 743 pass("First test"); 744 745 subtest 'An example subtest' => sub { 746 plan tests => 2; 747 748 pass("This is a subtest"); 749 pass("So is this"); 750 }; 751 752 pass("Third test"); 753 754This would produce. 755 756 1..3 757 ok 1 - First test 758 # Subtest: An example subtest 759 1..2 760 ok 1 - This is a subtest 761 ok 2 - So is this 762 ok 2 - An example subtest 763 ok 3 - Third test 764 765A subtest may call C<skip_all>. No tests will be run, but the subtest is 766considered a skip. 767 768 subtest 'skippy' => sub { 769 plan skip_all => 'cuz I said so'; 770 pass('this test will never be run'); 771 }; 772 773Returns true if the subtest passed, false otherwise. 774 775Due to how subtests work, you may omit a plan if you desire. This adds an 776implicit C<done_testing()> to the end of your subtest. The following two 777subtests are equivalent: 778 779 subtest 'subtest with implicit done_testing()', sub { 780 ok 1, 'subtests with an implicit done testing should work'; 781 ok 1, '... and support more than one test'; 782 ok 1, '... no matter how many tests are run'; 783 }; 784 785 subtest 'subtest with explicit done_testing()', sub { 786 ok 1, 'subtests with an explicit done testing should work'; 787 ok 1, '... and support more than one test'; 788 ok 1, '... no matter how many tests are run'; 789 done_testing(); 790 }; 791 792Extra arguments given to C<subtest> are passed to the callback. For example: 793 794 sub my_subtest { 795 my $range = shift; 796 ... 797 } 798 799 for my $range (1, 10, 100, 1000) { 800 subtest "testing range $range", \&my_subtest, $range; 801 } 802 803=cut 804 805sub subtest { 806 my $tb = Test::More->builder; 807 return $tb->subtest(@_); 808} 809 810=item B<pass> 811 812=item B<fail> 813 814 pass($test_name); 815 fail($test_name); 816 817Sometimes you just want to say that the tests have passed. Usually 818the case is you've got some complicated condition that is difficult to 819wedge into an C<ok()>. In this case, you can simply use C<pass()> (to 820declare the test ok) or fail (for not ok). They are synonyms for 821C<ok(1)> and C<ok(0)>. 822 823Use these very, very, very sparingly. 824 825=cut 826 827sub pass (;$) { 828 my $tb = Test::More->builder; 829 830 return $tb->ok( 1, @_ ); 831} 832 833sub fail (;$) { 834 my $tb = Test::More->builder; 835 836 return $tb->ok( 0, @_ ); 837} 838 839=back 840 841 842=head2 Module tests 843 844Sometimes you want to test if a module, or a list of modules, can 845successfully load. For example, you'll often want a first test which 846simply loads all the modules in the distribution to make sure they 847work before going on to do more complicated testing. 848 849For such purposes we have C<use_ok> and C<require_ok>. 850 851=over 4 852 853=item B<require_ok> 854 855 require_ok($module); 856 require_ok($file); 857 858Tries to C<require> the given $module or $file. If it loads 859successfully, the test will pass. Otherwise it fails and displays the 860load error. 861 862C<require_ok> will guess whether the input is a module name or a 863filename. 864 865No exception will be thrown if the load fails. 866 867 # require Some::Module 868 require_ok "Some::Module"; 869 870 # require "Some/File.pl"; 871 require_ok "Some/File.pl"; 872 873 # stop testing if any of your modules will not load 874 for my $module (@module) { 875 require_ok $module or BAIL_OUT "Can't load $module"; 876 } 877 878=cut 879 880sub require_ok ($) { 881 my($module) = shift; 882 my $tb = Test::More->builder; 883 884 my $pack = caller; 885 886 # Try to determine if we've been given a module name or file. 887 # Module names must be barewords, files not. 888 $module = qq['$module'] unless _is_module_name($module); 889 890 my $code = <<REQUIRE; 891package $pack; 892require $module; 8931; 894REQUIRE 895 896 my( $eval_result, $eval_error ) = _eval($code); 897 my $ok = $tb->ok( $eval_result, "require $module;" ); 898 899 unless($ok) { 900 chomp $eval_error; 901 $tb->diag(<<DIAGNOSTIC); 902 Tried to require '$module'. 903 Error: $eval_error 904DIAGNOSTIC 905 906 } 907 908 return $ok; 909} 910 911sub _is_module_name { 912 my $module = shift; 913 914 # Module names start with a letter. 915 # End with an alphanumeric. 916 # The rest is an alphanumeric or :: 917 $module =~ s/\b::\b//g; 918 919 return $module =~ /^[a-zA-Z]\w*$/ ? 1 : 0; 920} 921 922 923=item B<use_ok> 924 925 BEGIN { use_ok($module); } 926 BEGIN { use_ok($module, @imports); } 927 928Like C<require_ok>, but it will C<use> the $module in question and 929only loads modules, not files. 930 931If you just want to test a module can be loaded, use C<require_ok>. 932 933If you just want to load a module in a test, we recommend simply using 934C<use> directly. It will cause the test to stop. 935 936It's recommended that you run C<use_ok()> inside a BEGIN block so its 937functions are exported at compile-time and prototypes are properly 938honored. 939 940If @imports are given, they are passed through to the use. So this: 941 942 BEGIN { use_ok('Some::Module', qw(foo bar)) } 943 944is like doing this: 945 946 use Some::Module qw(foo bar); 947 948Version numbers can be checked like so: 949 950 # Just like "use Some::Module 1.02" 951 BEGIN { use_ok('Some::Module', 1.02) } 952 953Don't try to do this: 954 955 BEGIN { 956 use_ok('Some::Module'); 957 958 ...some code that depends on the use... 959 ...happening at compile time... 960 } 961 962because the notion of "compile-time" is relative. Instead, you want: 963 964 BEGIN { use_ok('Some::Module') } 965 BEGIN { ...some code that depends on the use... } 966 967If you want the equivalent of C<use Foo ()>, use a module but not 968import anything, use C<require_ok>. 969 970 BEGIN { require_ok "Foo" } 971 972=cut 973 974sub use_ok ($;@) { 975 my( $module, @imports ) = @_; 976 @imports = () unless @imports; 977 my $tb = Test::More->builder; 978 979 my %caller; 980 @caller{qw/pack file line sub args want eval req strict warn/} = caller(0); 981 982 my ($pack, $filename, $line, $warn) = @caller{qw/pack file line warn/}; 983 $filename =~ y/\n\r/_/; # so it doesn't run off the "#line $line $f" line 984 985 my $code; 986 if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) { 987 # probably a version check. Perl needs to see the bare number 988 # for it to work with non-Exporter based modules. 989 $code = <<USE; 990package $pack; 991BEGIN { \${^WARNING_BITS} = \$args[-1] if defined \$args[-1] } 992#line $line $filename 993use $module $imports[0]; 9941; 995USE 996 } 997 else { 998 $code = <<USE; 999package $pack; 1000BEGIN { \${^WARNING_BITS} = \$args[-1] if defined \$args[-1] } 1001#line $line $filename 1002use $module \@{\$args[0]}; 10031; 1004USE 1005 } 1006 1007 my ($eval_result, $eval_error) = _eval($code, \@imports, $warn); 1008 my $ok = $tb->ok( $eval_result, "use $module;" ); 1009 1010 unless($ok) { 1011 chomp $eval_error; 1012 $@ =~ s{^BEGIN failed--compilation aborted at .*$} 1013 {BEGIN failed--compilation aborted at $filename line $line.}m; 1014 $tb->diag(<<DIAGNOSTIC); 1015 Tried to use '$module'. 1016 Error: $eval_error 1017DIAGNOSTIC 1018 1019 } 1020 1021 return $ok; 1022} 1023 1024sub _eval { 1025 my( $code, @args ) = @_; 1026 1027 # Work around oddities surrounding resetting of $@ by immediately 1028 # storing it. 1029 my( $sigdie, $eval_result, $eval_error ); 1030 { 1031 local( $@, $!, $SIG{__DIE__} ); # isolate eval 1032 $eval_result = eval $code; ## no critic (BuiltinFunctions::ProhibitStringyEval) 1033 $eval_error = $@; 1034 $sigdie = $SIG{__DIE__} || undef; 1035 } 1036 # make sure that $code got a chance to set $SIG{__DIE__} 1037 $SIG{__DIE__} = $sigdie if defined $sigdie; 1038 1039 return( $eval_result, $eval_error ); 1040} 1041 1042 1043=back 1044 1045 1046=head2 Complex data structures 1047 1048Not everything is a simple eq check or regex. There are times you 1049need to see if two data structures are equivalent. For these 1050instances Test::More provides a handful of useful functions. 1051 1052B<NOTE> I'm not quite sure what will happen with filehandles. 1053 1054=over 4 1055 1056=item B<is_deeply> 1057 1058 is_deeply( $got, $expected, $test_name ); 1059 1060Similar to C<is()>, except that if $got and $expected are references, it 1061does a deep comparison walking each data structure to see if they are 1062equivalent. If the two structures are different, it will display the 1063place where they start differing. 1064 1065C<is_deeply()> compares the dereferenced values of references, the 1066references themselves (except for their type) are ignored. This means 1067aspects such as blessing and ties are not considered "different". 1068 1069C<is_deeply()> currently has very limited handling of function reference 1070and globs. It merely checks if they have the same referent. This may 1071improve in the future. 1072 1073L<Test::Differences> and L<Test::Deep> provide more in-depth functionality 1074along these lines. 1075 1076B<NOTE> is_deeply() has limitations when it comes to comparing strings and 1077refs: 1078 1079 my $path = path('.'); 1080 my $hash = {}; 1081 is_deeply( $path, "$path" ); # ok 1082 is_deeply( $hash, "$hash" ); # fail 1083 1084This happens because is_deeply will unoverload all arguments unconditionally. 1085It is probably best not to use is_deeply with overloading. For legacy reasons 1086this is not likely to ever be fixed. If you would like a much better tool for 1087this you should see L<Test2::Suite> Specifically L<Test2::Tools::Compare> has 1088an C<is()> function that works like C<is_deeply> with many improvements. 1089 1090=cut 1091 1092our( @Data_Stack, %Refs_Seen ); 1093my $DNE = bless [], 'Does::Not::Exist'; 1094 1095sub _dne { 1096 return ref $_[0] eq ref $DNE; 1097} 1098 1099## no critic (Subroutines::RequireArgUnpacking) 1100sub is_deeply { 1101 my $tb = Test::More->builder; 1102 1103 unless( @_ == 2 or @_ == 3 ) { 1104 my $msg = <<'WARNING'; 1105is_deeply() takes two or three args, you gave %d. 1106This usually means you passed an array or hash instead 1107of a reference to it 1108WARNING 1109 chop $msg; # clip off newline so carp() will put in line/file 1110 1111 _carp sprintf $msg, scalar @_; 1112 1113 return $tb->ok(0); 1114 } 1115 1116 my( $got, $expected, $name ) = @_; 1117 1118 $tb->_unoverload_str( \$expected, \$got ); 1119 1120 my $ok; 1121 if( !ref $got and !ref $expected ) { # neither is a reference 1122 $ok = $tb->is_eq( $got, $expected, $name ); 1123 } 1124 elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't 1125 $ok = $tb->ok( 0, $name ); 1126 $tb->diag( _format_stack({ vals => [ $got, $expected ] }) ); 1127 } 1128 else { # both references 1129 local @Data_Stack = (); 1130 if( _deep_check( $got, $expected ) ) { 1131 $ok = $tb->ok( 1, $name ); 1132 } 1133 else { 1134 $ok = $tb->ok( 0, $name ); 1135 $tb->diag( _format_stack(@Data_Stack) ); 1136 } 1137 } 1138 1139 return $ok; 1140} 1141 1142sub _format_stack { 1143 my(@Stack) = @_; 1144 1145 my $var = '$FOO'; 1146 my $did_arrow = 0; 1147 foreach my $entry (@Stack) { 1148 my $type = $entry->{type} || ''; 1149 my $idx = $entry->{'idx'}; 1150 if( $type eq 'HASH' ) { 1151 $var .= "->" unless $did_arrow++; 1152 $var .= "{$idx}"; 1153 } 1154 elsif( $type eq 'ARRAY' ) { 1155 $var .= "->" unless $did_arrow++; 1156 $var .= "[$idx]"; 1157 } 1158 elsif( $type eq 'REF' ) { 1159 $var = "\${$var}"; 1160 } 1161 } 1162 1163 my @vals = @{ $Stack[-1]{vals} }[ 0, 1 ]; 1164 my @vars = (); 1165 ( $vars[0] = $var ) =~ s/\$FOO/ \$got/; 1166 ( $vars[1] = $var ) =~ s/\$FOO/\$expected/; 1167 1168 my $out = "Structures begin differing at:\n"; 1169 foreach my $idx ( 0 .. $#vals ) { 1170 my $val = $vals[$idx]; 1171 $vals[$idx] 1172 = !defined $val ? 'undef' 1173 : _dne($val) ? "Does not exist" 1174 : ref $val ? "$val" 1175 : "'$val'"; 1176 } 1177 1178 $out .= "$vars[0] = $vals[0]\n"; 1179 $out .= "$vars[1] = $vals[1]\n"; 1180 1181 $out =~ s/^/ /msg; 1182 return $out; 1183} 1184 1185sub _type { 1186 my $thing = shift; 1187 1188 return '' if !ref $thing; 1189 1190 for my $type (qw(Regexp ARRAY HASH REF SCALAR GLOB CODE VSTRING)) { 1191 return $type if UNIVERSAL::isa( $thing, $type ); 1192 } 1193 1194 return ''; 1195} 1196 1197=back 1198 1199 1200=head2 Diagnostics 1201 1202If you pick the right test function, you'll usually get a good idea of 1203what went wrong when it failed. But sometimes it doesn't work out 1204that way. So here we have ways for you to write your own diagnostic 1205messages which are safer than just C<print STDERR>. 1206 1207=over 4 1208 1209=item B<diag> 1210 1211 diag(@diagnostic_message); 1212 1213Prints a diagnostic message which is guaranteed not to interfere with 1214test output. Like C<print> @diagnostic_message is simply concatenated 1215together. 1216 1217Returns false, so as to preserve failure. 1218 1219Handy for this sort of thing: 1220 1221 ok( grep(/foo/, @users), "There's a foo user" ) or 1222 diag("Since there's no foo, check that /etc/bar is set up right"); 1223 1224which would produce: 1225 1226 not ok 42 - There's a foo user 1227 # Failed test 'There's a foo user' 1228 # in foo.t at line 52. 1229 # Since there's no foo, check that /etc/bar is set up right. 1230 1231You might remember C<ok() or diag()> with the mnemonic C<open() or 1232die()>. 1233 1234B<NOTE> The exact formatting of the diagnostic output is still 1235changing, but it is guaranteed that whatever you throw at it won't 1236interfere with the test. 1237 1238=item B<note> 1239 1240 note(@diagnostic_message); 1241 1242Like C<diag()>, except the message will not be seen when the test is run 1243in a harness. It will only be visible in the verbose TAP stream. 1244 1245Handy for putting in notes which might be useful for debugging, but 1246don't indicate a problem. 1247 1248 note("Tempfile is $tempfile"); 1249 1250=cut 1251 1252sub diag { 1253 return Test::More->builder->diag(@_); 1254} 1255 1256sub note { 1257 return Test::More->builder->note(@_); 1258} 1259 1260=item B<explain> 1261 1262 my @dump = explain @diagnostic_message; 1263 1264Will dump the contents of any references in a human readable format. 1265Usually you want to pass this into C<note> or C<diag>. 1266 1267Handy for things like... 1268 1269 is_deeply($have, $want) || diag explain $have; 1270 1271or 1272 1273 note explain \%args; 1274 Some::Class->method(%args); 1275 1276=cut 1277 1278sub explain { 1279 return Test::More->builder->explain(@_); 1280} 1281 1282=back 1283 1284 1285=head2 Conditional tests 1286 1287Sometimes running a test under certain conditions will cause the 1288test script to die. A certain function or method isn't implemented 1289(such as C<fork()> on MacOS), some resource isn't available (like a 1290net connection) or a module isn't available. In these cases it's 1291necessary to skip tests, or declare that they are supposed to fail 1292but will work in the future (a todo test). 1293 1294For more details on the mechanics of skip and todo tests see 1295L<Test::Harness>. 1296 1297The way Test::More handles this is with a named block. Basically, a 1298block of tests which can be skipped over or made todo. It's best if I 1299just show you... 1300 1301=over 4 1302 1303=item B<SKIP: BLOCK> 1304 1305 SKIP: { 1306 skip $why, $how_many if $condition; 1307 1308 ...normal testing code goes here... 1309 } 1310 1311This declares a block of tests that might be skipped, $how_many tests 1312there are, $why and under what $condition to skip them. An example is 1313the easiest way to illustrate: 1314 1315 SKIP: { 1316 eval { require HTML::Lint }; 1317 1318 skip "HTML::Lint not installed", 2 if $@; 1319 1320 my $lint = new HTML::Lint; 1321 isa_ok( $lint, "HTML::Lint" ); 1322 1323 $lint->parse( $html ); 1324 is( $lint->errors, 0, "No errors found in HTML" ); 1325 } 1326 1327If the user does not have HTML::Lint installed, the whole block of 1328code I<won't be run at all>. Test::More will output special ok's 1329which Test::Harness interprets as skipped, but passing, tests. 1330 1331It's important that $how_many accurately reflects the number of tests 1332in the SKIP block so the # of tests run will match up with your plan. 1333If your plan is C<no_plan> $how_many is optional and will default to 1. 1334 1335It's perfectly safe to nest SKIP blocks. Each SKIP block must have 1336the label C<SKIP>, or Test::More can't work its magic. 1337 1338You don't skip tests which are failing because there's a bug in your 1339program, or for which you don't yet have code written. For that you 1340use TODO. Read on. 1341 1342=cut 1343 1344## no critic (Subroutines::RequireFinalReturn) 1345sub skip { 1346 my( $why, $how_many ) = @_; 1347 my $tb = Test::More->builder; 1348 1349 # If the plan is set, and is static, then skip needs a count. If the plan 1350 # is 'no_plan' we are fine. As well if plan is undefined then we are 1351 # waiting for done_testing. 1352 unless (defined $how_many) { 1353 my $plan = $tb->has_plan; 1354 _carp "skip() needs to know \$how_many tests are in the block" 1355 if $plan && $plan =~ m/^\d+$/; 1356 $how_many = 1; 1357 } 1358 1359 if( defined $how_many and $how_many =~ /\D/ ) { 1360 _carp 1361 "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?"; 1362 $how_many = 1; 1363 } 1364 1365 for( 1 .. $how_many ) { 1366 $tb->skip($why); 1367 } 1368 1369 no warnings 'exiting'; 1370 last SKIP; 1371} 1372 1373=item B<TODO: BLOCK> 1374 1375 TODO: { 1376 local $TODO = $why if $condition; 1377 1378 ...normal testing code goes here... 1379 } 1380 1381Declares a block of tests you expect to fail and $why. Perhaps it's 1382because you haven't fixed a bug or haven't finished a new feature: 1383 1384 TODO: { 1385 local $TODO = "URI::Geller not finished"; 1386 1387 my $card = "Eight of clubs"; 1388 is( URI::Geller->your_card, $card, 'Is THIS your card?' ); 1389 1390 my $spoon; 1391 URI::Geller->bend_spoon; 1392 is( $spoon, 'bent', "Spoon bending, that's original" ); 1393 } 1394 1395With a todo block, the tests inside are expected to fail. Test::More 1396will run the tests normally, but print out special flags indicating 1397they are "todo". L<Test::Harness> will interpret failures as being ok. 1398Should anything succeed, it will report it as an unexpected success. 1399You then know the thing you had todo is done and can remove the 1400TODO flag. 1401 1402The nice part about todo tests, as opposed to simply commenting out a 1403block of tests, is it's like having a programmatic todo list. You know 1404how much work is left to be done, you're aware of what bugs there are, 1405and you'll know immediately when they're fixed. 1406 1407Once a todo test starts succeeding, simply move it outside the block. 1408When the block is empty, delete it. 1409 1410 1411=item B<todo_skip> 1412 1413 TODO: { 1414 todo_skip $why, $how_many if $condition; 1415 1416 ...normal testing code... 1417 } 1418 1419With todo tests, it's best to have the tests actually run. That way 1420you'll know when they start passing. Sometimes this isn't possible. 1421Often a failing test will cause the whole program to die or hang, even 1422inside an C<eval BLOCK> with and using C<alarm>. In these extreme 1423cases you have no choice but to skip over the broken tests entirely. 1424 1425The syntax and behavior is similar to a C<SKIP: BLOCK> except the 1426tests will be marked as failing but todo. L<Test::Harness> will 1427interpret them as passing. 1428 1429=cut 1430 1431sub todo_skip { 1432 my( $why, $how_many ) = @_; 1433 my $tb = Test::More->builder; 1434 1435 unless( defined $how_many ) { 1436 # $how_many can only be avoided when no_plan is in use. 1437 _carp "todo_skip() needs to know \$how_many tests are in the block" 1438 unless $tb->has_plan eq 'no_plan'; 1439 $how_many = 1; 1440 } 1441 1442 for( 1 .. $how_many ) { 1443 $tb->todo_skip($why); 1444 } 1445 1446 no warnings 'exiting'; 1447 last TODO; 1448} 1449 1450=item When do I use SKIP vs. TODO? 1451 1452B<If it's something the user might not be able to do>, use SKIP. 1453This includes optional modules that aren't installed, running under 1454an OS that doesn't have some feature (like C<fork()> or symlinks), or maybe 1455you need an Internet connection and one isn't available. 1456 1457B<If it's something the programmer hasn't done yet>, use TODO. This 1458is for any code you haven't written yet, or bugs you have yet to fix, 1459but want to put tests in your testing script (always a good idea). 1460 1461 1462=back 1463 1464 1465=head2 Test control 1466 1467=over 4 1468 1469=item B<BAIL_OUT> 1470 1471 BAIL_OUT($reason); 1472 1473Indicates to the harness that things are going so badly all testing 1474should terminate. This includes the running of any additional test scripts. 1475 1476This is typically used when testing cannot continue such as a critical 1477module failing to compile or a necessary external utility not being 1478available such as a database connection failing. 1479 1480The test will exit with 255. 1481 1482For even better control look at L<Test::Most>. 1483 1484=cut 1485 1486sub BAIL_OUT { 1487 my $reason = shift; 1488 my $tb = Test::More->builder; 1489 1490 $tb->BAIL_OUT($reason); 1491} 1492 1493=back 1494 1495 1496=head2 Discouraged comparison functions 1497 1498The use of the following functions is discouraged as they are not 1499actually testing functions and produce no diagnostics to help figure 1500out what went wrong. They were written before C<is_deeply()> existed 1501because I couldn't figure out how to display a useful diff of two 1502arbitrary data structures. 1503 1504These functions are usually used inside an C<ok()>. 1505 1506 ok( eq_array(\@got, \@expected) ); 1507 1508C<is_deeply()> can do that better and with diagnostics. 1509 1510 is_deeply( \@got, \@expected ); 1511 1512They may be deprecated in future versions. 1513 1514=over 4 1515 1516=item B<eq_array> 1517 1518 my $is_eq = eq_array(\@got, \@expected); 1519 1520Checks if two arrays are equivalent. This is a deep check, so 1521multi-level structures are handled correctly. 1522 1523=cut 1524 1525#'# 1526sub eq_array { 1527 local @Data_Stack = (); 1528 _deep_check(@_); 1529} 1530 1531sub _eq_array { 1532 my( $a1, $a2 ) = @_; 1533 1534 if( grep _type($_) ne 'ARRAY', $a1, $a2 ) { 1535 warn "eq_array passed a non-array ref"; 1536 return 0; 1537 } 1538 1539 return 1 if $a1 eq $a2; 1540 1541 my $ok = 1; 1542 my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; 1543 for( 0 .. $max ) { 1544 my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; 1545 my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; 1546 1547 next if _equal_nonrefs($e1, $e2); 1548 1549 push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] }; 1550 $ok = _deep_check( $e1, $e2 ); 1551 pop @Data_Stack if $ok; 1552 1553 last unless $ok; 1554 } 1555 1556 return $ok; 1557} 1558 1559sub _equal_nonrefs { 1560 my( $e1, $e2 ) = @_; 1561 1562 return if ref $e1 or ref $e2; 1563 1564 if ( defined $e1 ) { 1565 return 1 if defined $e2 and $e1 eq $e2; 1566 } 1567 else { 1568 return 1 if !defined $e2; 1569 } 1570 1571 return; 1572} 1573 1574sub _deep_check { 1575 my( $e1, $e2 ) = @_; 1576 my $tb = Test::More->builder; 1577 1578 my $ok = 0; 1579 1580 # Effectively turn %Refs_Seen into a stack. This avoids picking up 1581 # the same referenced used twice (such as [\$a, \$a]) to be considered 1582 # circular. 1583 local %Refs_Seen = %Refs_Seen; 1584 1585 { 1586 $tb->_unoverload_str( \$e1, \$e2 ); 1587 1588 # Either they're both references or both not. 1589 my $same_ref = !( !ref $e1 xor !ref $e2 ); 1590 my $not_ref = ( !ref $e1 and !ref $e2 ); 1591 1592 if( defined $e1 xor defined $e2 ) { 1593 $ok = 0; 1594 } 1595 elsif( !defined $e1 and !defined $e2 ) { 1596 # Shortcut if they're both undefined. 1597 $ok = 1; 1598 } 1599 elsif( _dne($e1) xor _dne($e2) ) { 1600 $ok = 0; 1601 } 1602 elsif( $same_ref and( $e1 eq $e2 ) ) { 1603 $ok = 1; 1604 } 1605 elsif($not_ref) { 1606 push @Data_Stack, { type => '', vals => [ $e1, $e2 ] }; 1607 $ok = 0; 1608 } 1609 else { 1610 if( $Refs_Seen{$e1} ) { 1611 return $Refs_Seen{$e1} eq $e2; 1612 } 1613 else { 1614 $Refs_Seen{$e1} = "$e2"; 1615 } 1616 1617 my $type = _type($e1); 1618 $type = 'DIFFERENT' unless _type($e2) eq $type; 1619 1620 if( $type eq 'DIFFERENT' ) { 1621 push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; 1622 $ok = 0; 1623 } 1624 elsif( $type eq 'ARRAY' ) { 1625 $ok = _eq_array( $e1, $e2 ); 1626 } 1627 elsif( $type eq 'HASH' ) { 1628 $ok = _eq_hash( $e1, $e2 ); 1629 } 1630 elsif( $type eq 'REF' ) { 1631 push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; 1632 $ok = _deep_check( $$e1, $$e2 ); 1633 pop @Data_Stack if $ok; 1634 } 1635 elsif( $type eq 'SCALAR' ) { 1636 push @Data_Stack, { type => 'REF', vals => [ $e1, $e2 ] }; 1637 $ok = _deep_check( $$e1, $$e2 ); 1638 pop @Data_Stack if $ok; 1639 } 1640 elsif($type) { 1641 push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; 1642 $ok = 0; 1643 } 1644 else { 1645 _whoa( 1, "No type in _deep_check" ); 1646 } 1647 } 1648 } 1649 1650 return $ok; 1651} 1652 1653sub _whoa { 1654 my( $check, $desc ) = @_; 1655 if($check) { 1656 die <<"WHOA"; 1657WHOA! $desc 1658This should never happen! Please contact the author immediately! 1659WHOA 1660 } 1661} 1662 1663=item B<eq_hash> 1664 1665 my $is_eq = eq_hash(\%got, \%expected); 1666 1667Determines if the two hashes contain the same keys and values. This 1668is a deep check. 1669 1670=cut 1671 1672sub eq_hash { 1673 local @Data_Stack = (); 1674 return _deep_check(@_); 1675} 1676 1677sub _eq_hash { 1678 my( $a1, $a2 ) = @_; 1679 1680 if( grep _type($_) ne 'HASH', $a1, $a2 ) { 1681 warn "eq_hash passed a non-hash ref"; 1682 return 0; 1683 } 1684 1685 return 1 if $a1 eq $a2; 1686 1687 my $ok = 1; 1688 my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; 1689 foreach my $k ( keys %$bigger ) { 1690 my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; 1691 my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; 1692 1693 next if _equal_nonrefs($e1, $e2); 1694 1695 push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] }; 1696 $ok = _deep_check( $e1, $e2 ); 1697 pop @Data_Stack if $ok; 1698 1699 last unless $ok; 1700 } 1701 1702 return $ok; 1703} 1704 1705=item B<eq_set> 1706 1707 my $is_eq = eq_set(\@got, \@expected); 1708 1709Similar to C<eq_array()>, except the order of the elements is B<not> 1710important. This is a deep check, but the irrelevancy of order only 1711applies to the top level. 1712 1713 ok( eq_set(\@got, \@expected) ); 1714 1715Is better written: 1716 1717 is_deeply( [sort @got], [sort @expected] ); 1718 1719B<NOTE> By historical accident, this is not a true set comparison. 1720While the order of elements does not matter, duplicate elements do. 1721 1722B<NOTE> C<eq_set()> does not know how to deal with references at the top 1723level. The following is an example of a comparison which might not work: 1724 1725 eq_set([\1, \2], [\2, \1]); 1726 1727L<Test::Deep> contains much better set comparison functions. 1728 1729=cut 1730 1731sub eq_set { 1732 my( $a1, $a2 ) = @_; 1733 return 0 unless @$a1 == @$a2; 1734 1735 no warnings 'uninitialized'; 1736 1737 # It really doesn't matter how we sort them, as long as both arrays are 1738 # sorted with the same algorithm. 1739 # 1740 # Ensure that references are not accidentally treated the same as a 1741 # string containing the reference. 1742 # 1743 # Have to inline the sort routine due to a threading/sort bug. 1744 # See [rt.cpan.org 6782] 1745 # 1746 # I don't know how references would be sorted so we just don't sort 1747 # them. This means eq_set doesn't really work with refs. 1748 return eq_array( 1749 [ grep( ref, @$a1 ), sort( grep( !ref, @$a1 ) ) ], 1750 [ grep( ref, @$a2 ), sort( grep( !ref, @$a2 ) ) ], 1751 ); 1752} 1753 1754=back 1755 1756 1757=head2 Extending and Embedding Test::More 1758 1759Sometimes the Test::More interface isn't quite enough. Fortunately, 1760Test::More is built on top of L<Test::Builder> which provides a single, 1761unified backend for any test library to use. This means two test 1762libraries which both use <Test::Builder> B<can> be used together in the 1763same program>. 1764 1765If you simply want to do a little tweaking of how the tests behave, 1766you can access the underlying L<Test::Builder> object like so: 1767 1768=over 4 1769 1770=item B<builder> 1771 1772 my $test_builder = Test::More->builder; 1773 1774Returns the L<Test::Builder> object underlying Test::More for you to play 1775with. 1776 1777 1778=back 1779 1780 1781=head1 EXIT CODES 1782 1783If all your tests passed, L<Test::Builder> will exit with zero (which is 1784normal). If anything failed it will exit with how many failed. If 1785you run less (or more) tests than you planned, the missing (or extras) 1786will be considered failures. If no tests were ever run L<Test::Builder> 1787will throw a warning and exit with 255. If the test died, even after 1788having successfully completed all its tests, it will still be 1789considered a failure and will exit with 255. 1790 1791So the exit codes are... 1792 1793 0 all tests successful 1794 255 test died or all passed but wrong # of tests run 1795 any other number how many failed (including missing or extras) 1796 1797If you fail more than 254 tests, it will be reported as 254. 1798 1799B<NOTE> This behavior may go away in future versions. 1800 1801 1802=head1 COMPATIBILITY 1803 1804Test::More works with Perls as old as 5.8.1. 1805 1806Thread support is not very reliable before 5.10.1, but that's 1807because threads are not very reliable before 5.10.1. 1808 1809Although Test::More has been a core module in versions of Perl since 5.6.2, Test::More has evolved since then, and not all of the features you're used to will be present in the shipped version of Test::More. If you are writing a module, don't forget to indicate in your package metadata the minimum version of Test::More that you require. For instance, if you want to use C<done_testing()> but want your test script to run on Perl 5.10.0, you will need to explicitly require Test::More > 0.88. 1810 1811Key feature milestones include: 1812 1813=over 4 1814 1815=item subtests 1816 1817Subtests were released in Test::More 0.94, which came with Perl 5.12.0. Subtests did not implicitly call C<done_testing()> until 0.96; the first Perl with that fix was Perl 5.14.0 with 0.98. 1818 1819=item C<done_testing()> 1820 1821This was released in Test::More 0.88 and first shipped with Perl in 5.10.1 as part of Test::More 0.92. 1822 1823=item C<cmp_ok()> 1824 1825Although C<cmp_ok()> was introduced in 0.40, 0.86 fixed an important bug to make it safe for overloaded objects; the fixed first shipped with Perl in 5.10.1 as part of Test::More 0.92. 1826 1827=item C<new_ok()> C<note()> and C<explain()> 1828 1829These were was released in Test::More 0.82, and first shipped with Perl in 5.10.1 as part of Test::More 0.92. 1830 1831=back 1832 1833There is a full version history in the Changes file, and the Test::More versions included as core can be found using L<Module::CoreList>: 1834 1835 $ corelist -a Test::More 1836 1837 1838=head1 CAVEATS and NOTES 1839 1840=over 4 1841 1842=item utf8 / "Wide character in print" 1843 1844If you use utf8 or other non-ASCII characters with Test::More you 1845might get a "Wide character in print" warning. Using 1846C<< binmode STDOUT, ":utf8" >> will not fix it. 1847L<Test::Builder> (which powers 1848Test::More) duplicates STDOUT and STDERR. So any changes to them, 1849including changing their output disciplines, will not be seem by 1850Test::More. 1851 1852One work around is to apply encodings to STDOUT and STDERR as early 1853as possible and before Test::More (or any other Test module) loads. 1854 1855 use open ':std', ':encoding(utf8)'; 1856 use Test::More; 1857 1858A more direct work around is to change the filehandles used by 1859L<Test::Builder>. 1860 1861 my $builder = Test::More->builder; 1862 binmode $builder->output, ":encoding(utf8)"; 1863 binmode $builder->failure_output, ":encoding(utf8)"; 1864 binmode $builder->todo_output, ":encoding(utf8)"; 1865 1866 1867=item Overloaded objects 1868 1869String overloaded objects are compared B<as strings> (or in C<cmp_ok()>'s 1870case, strings or numbers as appropriate to the comparison op). This 1871prevents Test::More from piercing an object's interface allowing 1872better blackbox testing. So if a function starts returning overloaded 1873objects instead of bare strings your tests won't notice the 1874difference. This is good. 1875 1876However, it does mean that functions like C<is_deeply()> cannot be used to 1877test the internals of string overloaded objects. In this case I would 1878suggest L<Test::Deep> which contains more flexible testing functions for 1879complex data structures. 1880 1881 1882=item Threads 1883 1884Test::More will only be aware of threads if C<use threads> has been done 1885I<before> Test::More is loaded. This is ok: 1886 1887 use threads; 1888 use Test::More; 1889 1890This may cause problems: 1891 1892 use Test::More 1893 use threads; 1894 18955.8.1 and above are supported. Anything below that has too many bugs. 1896 1897=back 1898 1899 1900=head1 HISTORY 1901 1902This is a case of convergent evolution with Joshua Pritikin's L<Test> 1903module. I was largely unaware of its existence when I'd first 1904written my own C<ok()> routines. This module exists because I can't 1905figure out how to easily wedge test names into Test's interface (along 1906with a few other problems). 1907 1908The goal here is to have a testing utility that's simple to learn, 1909quick to use and difficult to trip yourself up with while still 1910providing more flexibility than the existing Test.pm. As such, the 1911names of the most common routines are kept tiny, special cases and 1912magic side-effects are kept to a minimum. WYSIWYG. 1913 1914 1915=head1 SEE ALSO 1916 1917=head2 1918 1919=head2 ALTERNATIVES 1920 1921L<Test::Simple> if all this confuses you and you just want to write 1922some tests. You can upgrade to Test::More later (it's forward 1923compatible). 1924 1925L<Test::Legacy> tests written with Test.pm, the original testing 1926module, do not play well with other testing libraries. Test::Legacy 1927emulates the Test.pm interface and does play well with others. 1928 1929=head2 TESTING FRAMEWORKS 1930 1931L<Fennec> The Fennec framework is a testers toolbox. It uses L<Test::Builder> 1932under the hood. It brings enhancements for forking, defining state, and 1933mocking. Fennec enhances several modules to work better together than they 1934would if you loaded them individually on your own. 1935 1936L<Fennec::Declare> Provides enhanced (L<Devel::Declare>) syntax for Fennec. 1937 1938=head2 ADDITIONAL LIBRARIES 1939 1940L<Test::Differences> for more ways to test complex data structures. 1941And it plays well with Test::More. 1942 1943L<Test::Class> is like xUnit but more perlish. 1944 1945L<Test::Deep> gives you more powerful complex data structure testing. 1946 1947L<Test::Inline> shows the idea of embedded testing. 1948 1949L<Mock::Quick> The ultimate mocking library. Easily spawn objects defined on 1950the fly. Can also override, block, or reimplement packages as needed. 1951 1952L<Test::FixtureBuilder> Quickly define fixture data for unit tests. 1953 1954=head2 OTHER COMPONENTS 1955 1956L<Test::Harness> is the test runner and output interpreter for Perl. 1957It's the thing that powers C<make test> and where the C<prove> utility 1958comes from. 1959 1960=head2 BUNDLES 1961 1962L<Test::Most> Most commonly needed test functions and features. 1963 1964=head1 AUTHORS 1965 1966Michael G Schwern E<lt>schwern@pobox.comE<gt> with much inspiration 1967from Joshua Pritikin's Test module and lots of help from Barrie 1968Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and 1969the perl-qa gang. 1970 1971=head1 MAINTAINERS 1972 1973=over 4 1974 1975=item Chad Granum E<lt>exodist@cpan.orgE<gt> 1976 1977=back 1978 1979 1980=head1 BUGS 1981 1982See F<https://github.com/Test-More/test-more/issues> to report and view bugs. 1983 1984 1985=head1 SOURCE 1986 1987The source code repository for Test::More can be found at 1988F<http://github.com/Test-More/test-more/>. 1989 1990 1991=head1 COPYRIGHT 1992 1993Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. 1994 1995This program is free software; you can redistribute it and/or 1996modify it under the same terms as Perl itself. 1997 1998See F<http://www.perl.com/perl/misc/Artistic.html> 1999 2000=cut 2001 20021; 2003