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