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