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.302199'; 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 1209my %_types = ( 1210 (map +($_ => $_), qw( 1211 Regexp 1212 ARRAY 1213 HASH 1214 SCALAR 1215 REF 1216 GLOB 1217 CODE 1218 )), 1219 'LVALUE' => 'SCALAR', 1220 'REF' => 'SCALAR', 1221 'VSTRING' => 'SCALAR', 1222); 1223 1224sub _type { 1225 my $thing = shift; 1226 1227 return '' if !ref $thing; 1228 1229 for my $type (keys %_types) { 1230 return $_types{$type} if UNIVERSAL::isa( $thing, $type ); 1231 } 1232 1233 return ''; 1234} 1235 1236=back 1237 1238 1239=head2 Diagnostics 1240 1241If you pick the right test function, you'll usually get a good idea of 1242what went wrong when it failed. But sometimes it doesn't work out 1243that way. So here we have ways for you to write your own diagnostic 1244messages which are safer than just C<print STDERR>. 1245 1246=over 4 1247 1248=item B<diag> 1249 1250 diag(@diagnostic_message); 1251 1252Prints a diagnostic message which is guaranteed not to interfere with 1253test output. Like C<print> @diagnostic_message is simply concatenated 1254together. 1255 1256Returns false, so as to preserve failure. 1257 1258Handy for this sort of thing: 1259 1260 ok( grep(/foo/, @users), "There's a foo user" ) or 1261 diag("Since there's no foo, check that /etc/bar is set up right"); 1262 1263which would produce: 1264 1265 not ok 42 - There's a foo user 1266 # Failed test 'There's a foo user' 1267 # in foo.t at line 52. 1268 # Since there's no foo, check that /etc/bar is set up right. 1269 1270You might remember C<ok() or diag()> with the mnemonic C<open() or 1271die()>. 1272 1273B<NOTE> The exact formatting of the diagnostic output is still 1274changing, but it is guaranteed that whatever you throw at it won't 1275interfere with the test. 1276 1277=item B<note> 1278 1279 note(@diagnostic_message); 1280 1281Like C<diag()>, except the message will not be seen when the test is run 1282in a harness. It will only be visible in the verbose TAP stream. 1283 1284Handy for putting in notes which might be useful for debugging, but 1285don't indicate a problem. 1286 1287 note("Tempfile is $tempfile"); 1288 1289=cut 1290 1291sub diag { 1292 return Test::More->builder->diag(@_); 1293} 1294 1295sub note { 1296 return Test::More->builder->note(@_); 1297} 1298 1299=item B<explain> 1300 1301 my @dump = explain @diagnostic_message; 1302 1303Will dump the contents of any references in a human readable format. 1304Usually you want to pass this into C<note> or C<diag>. 1305 1306Handy for things like... 1307 1308 is_deeply($have, $want) || diag explain $have; 1309 1310or 1311 1312 note explain \%args; 1313 Some::Class->method(%args); 1314 1315=cut 1316 1317sub explain { 1318 return Test::More->builder->explain(@_); 1319} 1320 1321=back 1322 1323 1324=head2 Conditional tests 1325 1326Sometimes running a test under certain conditions will cause the 1327test script to die. A certain function or method isn't implemented 1328(such as C<fork()> on MacOS), some resource isn't available (like a 1329net connection) or a module isn't available. In these cases it's 1330necessary to skip tests, or declare that they are supposed to fail 1331but will work in the future (a todo test). 1332 1333For more details on the mechanics of skip and todo tests see 1334L<Test::Harness>. 1335 1336The way Test::More handles this is with a named block. Basically, a 1337block of tests which can be skipped over or made todo. It's best if I 1338just show you... 1339 1340=over 4 1341 1342=item B<SKIP: BLOCK> 1343 1344 SKIP: { 1345 skip $why, $how_many if $condition; 1346 1347 ...normal testing code goes here... 1348 } 1349 1350This declares a block of tests that might be skipped, $how_many tests 1351there are, $why and under what $condition to skip them. An example is 1352the easiest way to illustrate: 1353 1354 SKIP: { 1355 eval { require HTML::Lint }; 1356 1357 skip "HTML::Lint not installed", 2 if $@; 1358 1359 my $lint = new HTML::Lint; 1360 isa_ok( $lint, "HTML::Lint" ); 1361 1362 $lint->parse( $html ); 1363 is( $lint->errors, 0, "No errors found in HTML" ); 1364 } 1365 1366If the user does not have HTML::Lint installed, the whole block of 1367code I<won't be run at all>. Test::More will output special ok's 1368which Test::Harness interprets as skipped, but passing, tests. 1369 1370It's important that $how_many accurately reflects the number of tests 1371in the SKIP block so the # of tests run will match up with your plan. 1372If your plan is C<no_plan> $how_many is optional and will default to 1. 1373 1374It's perfectly safe to nest SKIP blocks. Each SKIP block must have 1375the label C<SKIP>, or Test::More can't work its magic. 1376 1377You don't skip tests which are failing because there's a bug in your 1378program, or for which you don't yet have code written. For that you 1379use TODO. Read on. 1380 1381=cut 1382 1383## no critic (Subroutines::RequireFinalReturn) 1384sub skip { 1385 my( $why, $how_many ) = @_; 1386 my $tb = Test::More->builder; 1387 1388 # If the plan is set, and is static, then skip needs a count. If the plan 1389 # is 'no_plan' we are fine. As well if plan is undefined then we are 1390 # waiting for done_testing. 1391 unless (defined $how_many) { 1392 my $plan = $tb->has_plan; 1393 _carp "skip() needs to know \$how_many tests are in the block" 1394 if $plan && $plan =~ m/^\d+$/; 1395 $how_many = 1; 1396 } 1397 1398 if( defined $how_many and $how_many =~ /\D/ ) { 1399 _carp 1400 "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?"; 1401 $how_many = 1; 1402 } 1403 1404 for( 1 .. $how_many ) { 1405 $tb->skip($why); 1406 } 1407 1408 no warnings 'exiting'; 1409 last SKIP; 1410} 1411 1412=item B<TODO: BLOCK> 1413 1414 TODO: { 1415 local $TODO = $why if $condition; 1416 1417 ...normal testing code goes here... 1418 } 1419 1420Declares a block of tests you expect to fail and $why. Perhaps it's 1421because you haven't fixed a bug or haven't finished a new feature: 1422 1423 TODO: { 1424 local $TODO = "URI::Geller not finished"; 1425 1426 my $card = "Eight of clubs"; 1427 is( URI::Geller->your_card, $card, 'Is THIS your card?' ); 1428 1429 my $spoon; 1430 URI::Geller->bend_spoon; 1431 is( $spoon, 'bent', "Spoon bending, that's original" ); 1432 } 1433 1434With a todo block, the tests inside are expected to fail. Test::More 1435will run the tests normally, but print out special flags indicating 1436they are "todo". L<Test::Harness> will interpret failures as being ok. 1437Should anything succeed, it will report it as an unexpected success. 1438You then know the thing you had todo is done and can remove the 1439TODO flag. 1440 1441The nice part about todo tests, as opposed to simply commenting out a 1442block of tests, is that it is like having a programmatic todo list. You know 1443how much work is left to be done, you're aware of what bugs there are, 1444and you'll know immediately when they're fixed. 1445 1446Once a todo test starts succeeding, simply move it outside the block. 1447When the block is empty, delete it. 1448 1449Note that, if you leave $TODO unset or undef, Test::More reports failures 1450as normal. This can be useful to mark the tests as expected to fail only 1451in certain conditions, e.g.: 1452 1453 TODO: { 1454 local $TODO = "$^O doesn't work yet. :(" if !_os_is_supported($^O); 1455 1456 ... 1457 } 1458 1459=item B<todo_skip> 1460 1461 TODO: { 1462 todo_skip $why, $how_many if $condition; 1463 1464 ...normal testing code... 1465 } 1466 1467With todo tests, it's best to have the tests actually run. That way 1468you'll know when they start passing. Sometimes this isn't possible. 1469Often a failing test will cause the whole program to die or hang, even 1470inside an C<eval BLOCK> with and using C<alarm>. In these extreme 1471cases you have no choice but to skip over the broken tests entirely. 1472 1473The syntax and behavior is similar to a C<SKIP: BLOCK> except the 1474tests will be marked as failing but todo. L<Test::Harness> will 1475interpret them as passing. 1476 1477=cut 1478 1479sub todo_skip { 1480 my( $why, $how_many ) = @_; 1481 my $tb = Test::More->builder; 1482 1483 unless( defined $how_many ) { 1484 # $how_many can only be avoided when no_plan is in use. 1485 _carp "todo_skip() needs to know \$how_many tests are in the block" 1486 unless $tb->has_plan eq 'no_plan'; 1487 $how_many = 1; 1488 } 1489 1490 for( 1 .. $how_many ) { 1491 $tb->todo_skip($why); 1492 } 1493 1494 no warnings 'exiting'; 1495 last TODO; 1496} 1497 1498=item When do I use SKIP vs. TODO? 1499 1500B<If it's something the user might not be able to do>, use SKIP. 1501This includes optional modules that aren't installed, running under 1502an OS that doesn't have some feature (like C<fork()> or symlinks), or maybe 1503you need an Internet connection and one isn't available. 1504 1505B<If it's something the programmer hasn't done yet>, use TODO. This 1506is for any code you haven't written yet, or bugs you have yet to fix, 1507but want to put tests in your testing script (always a good idea). 1508 1509 1510=back 1511 1512 1513=head2 Test control 1514 1515=over 4 1516 1517=item B<BAIL_OUT> 1518 1519 BAIL_OUT($reason); 1520 1521Indicates to the harness that things are going so badly all testing 1522should terminate. This includes the running of any additional test scripts. 1523 1524This is typically used when testing cannot continue such as a critical 1525module failing to compile or a necessary external utility not being 1526available such as a database connection failing. 1527 1528The test will exit with 255. 1529 1530For even better control look at L<Test::Most>. 1531 1532=cut 1533 1534sub BAIL_OUT { 1535 my $reason = shift; 1536 my $tb = Test::More->builder; 1537 1538 $tb->BAIL_OUT($reason); 1539} 1540 1541=back 1542 1543 1544=head2 Discouraged comparison functions 1545 1546The use of the following functions is discouraged as they are not 1547actually testing functions and produce no diagnostics to help figure 1548out what went wrong. They were written before C<is_deeply()> existed 1549because I couldn't figure out how to display a useful diff of two 1550arbitrary data structures. 1551 1552These functions are usually used inside an C<ok()>. 1553 1554 ok( eq_array(\@got, \@expected) ); 1555 1556C<is_deeply()> can do that better and with diagnostics. 1557 1558 is_deeply( \@got, \@expected ); 1559 1560They may be deprecated in future versions. 1561 1562=over 4 1563 1564=item B<eq_array> 1565 1566 my $is_eq = eq_array(\@got, \@expected); 1567 1568Checks if two arrays are equivalent. This is a deep check, so 1569multi-level structures are handled correctly. 1570 1571=cut 1572 1573#'# 1574sub eq_array { 1575 local @Data_Stack = (); 1576 _deep_check(@_); 1577} 1578 1579sub _eq_array { 1580 my( $a1, $a2 ) = @_; 1581 1582 if( grep _type($_) ne 'ARRAY', $a1, $a2 ) { 1583 warn "eq_array passed a non-array ref"; 1584 return 0; 1585 } 1586 1587 return 1 if $a1 eq $a2; 1588 1589 my $ok = 1; 1590 my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; 1591 for( 0 .. $max ) { 1592 my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; 1593 my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; 1594 1595 next if _equal_nonrefs($e1, $e2); 1596 1597 push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] }; 1598 $ok = _deep_check( $e1, $e2 ); 1599 pop @Data_Stack if $ok; 1600 1601 last unless $ok; 1602 } 1603 1604 return $ok; 1605} 1606 1607sub _equal_nonrefs { 1608 my( $e1, $e2 ) = @_; 1609 1610 return if ref $e1 or ref $e2; 1611 1612 if ( defined $e1 ) { 1613 return 1 if defined $e2 and $e1 eq $e2; 1614 } 1615 else { 1616 return 1 if !defined $e2; 1617 } 1618 1619 return; 1620} 1621 1622sub _deep_check { 1623 my( $e1, $e2 ) = @_; 1624 my $tb = Test::More->builder; 1625 1626 my $ok = 0; 1627 1628 # Effectively turn %Refs_Seen into a stack. This avoids picking up 1629 # the same referenced used twice (such as [\$a, \$a]) to be considered 1630 # circular. 1631 local %Refs_Seen = %Refs_Seen; 1632 1633 { 1634 $tb->_unoverload_str( \$e1, \$e2 ); 1635 1636 # Either they're both references or both not. 1637 my $same_ref = !( !ref $e1 xor !ref $e2 ); 1638 my $not_ref = ( !ref $e1 and !ref $e2 ); 1639 1640 if( defined $e1 xor defined $e2 ) { 1641 $ok = 0; 1642 } 1643 elsif( !defined $e1 and !defined $e2 ) { 1644 # Shortcut if they're both undefined. 1645 $ok = 1; 1646 } 1647 elsif( _dne($e1) xor _dne($e2) ) { 1648 $ok = 0; 1649 } 1650 elsif( $same_ref and( $e1 eq $e2 ) ) { 1651 $ok = 1; 1652 } 1653 elsif($not_ref) { 1654 push @Data_Stack, { type => '', vals => [ $e1, $e2 ] }; 1655 $ok = 0; 1656 } 1657 else { 1658 if( $Refs_Seen{$e1} ) { 1659 return $Refs_Seen{$e1} eq $e2; 1660 } 1661 else { 1662 $Refs_Seen{$e1} = "$e2"; 1663 } 1664 1665 my $type = _type($e1); 1666 $type = 'DIFFERENT' unless _type($e2) eq $type; 1667 1668 if( $type eq 'DIFFERENT' ) { 1669 push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; 1670 $ok = 0; 1671 } 1672 elsif( $type eq 'ARRAY' ) { 1673 $ok = _eq_array( $e1, $e2 ); 1674 } 1675 elsif( $type eq 'HASH' ) { 1676 $ok = _eq_hash( $e1, $e2 ); 1677 } 1678 elsif( $type eq 'REF' ) { 1679 push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; 1680 $ok = _deep_check( $$e1, $$e2 ); 1681 pop @Data_Stack if $ok; 1682 } 1683 elsif( $type eq 'SCALAR' ) { 1684 push @Data_Stack, { type => 'REF', vals => [ $e1, $e2 ] }; 1685 $ok = _deep_check( $$e1, $$e2 ); 1686 pop @Data_Stack if $ok; 1687 } 1688 elsif($type) { 1689 push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; 1690 $ok = 0; 1691 } 1692 else { 1693 _whoa( 1, "No type in _deep_check" ); 1694 } 1695 } 1696 } 1697 1698 return $ok; 1699} 1700 1701sub _whoa { 1702 my( $check, $desc ) = @_; 1703 if($check) { 1704 die <<"WHOA"; 1705WHOA! $desc 1706This should never happen! Please contact the author immediately! 1707WHOA 1708 } 1709} 1710 1711=item B<eq_hash> 1712 1713 my $is_eq = eq_hash(\%got, \%expected); 1714 1715Determines if the two hashes contain the same keys and values. This 1716is a deep check. 1717 1718=cut 1719 1720sub eq_hash { 1721 local @Data_Stack = (); 1722 return _deep_check(@_); 1723} 1724 1725sub _eq_hash { 1726 my( $a1, $a2 ) = @_; 1727 1728 if( grep _type($_) ne 'HASH', $a1, $a2 ) { 1729 warn "eq_hash passed a non-hash ref"; 1730 return 0; 1731 } 1732 1733 return 1 if $a1 eq $a2; 1734 1735 my $ok = 1; 1736 my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; 1737 foreach my $k ( keys %$bigger ) { 1738 my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; 1739 my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; 1740 1741 next if _equal_nonrefs($e1, $e2); 1742 1743 push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] }; 1744 $ok = _deep_check( $e1, $e2 ); 1745 pop @Data_Stack if $ok; 1746 1747 last unless $ok; 1748 } 1749 1750 return $ok; 1751} 1752 1753=item B<eq_set> 1754 1755 my $is_eq = eq_set(\@got, \@expected); 1756 1757Similar to C<eq_array()>, except the order of the elements is B<not> 1758important. This is a deep check, but the irrelevancy of order only 1759applies to the top level. 1760 1761 ok( eq_set(\@got, \@expected) ); 1762 1763Is better written: 1764 1765 is_deeply( [sort @got], [sort @expected] ); 1766 1767B<NOTE> By historical accident, this is not a true set comparison. 1768While the order of elements does not matter, duplicate elements do. 1769 1770B<NOTE> C<eq_set()> does not know how to deal with references at the top 1771level. The following is an example of a comparison which might not work: 1772 1773 eq_set([\1, \2], [\2, \1]); 1774 1775L<Test::Deep> contains much better set comparison functions. 1776 1777=cut 1778 1779sub eq_set { 1780 my( $a1, $a2 ) = @_; 1781 return 0 unless @$a1 == @$a2; 1782 1783 no warnings 'uninitialized'; 1784 1785 # It really doesn't matter how we sort them, as long as both arrays are 1786 # sorted with the same algorithm. 1787 # 1788 # Ensure that references are not accidentally treated the same as a 1789 # string containing the reference. 1790 # 1791 # Have to inline the sort routine due to a threading/sort bug. 1792 # See [rt.cpan.org 6782] 1793 # 1794 # I don't know how references would be sorted so we just don't sort 1795 # them. This means eq_set doesn't really work with refs. 1796 return eq_array( 1797 [ grep( ref, @$a1 ), sort( grep( !ref, @$a1 ) ) ], 1798 [ grep( ref, @$a2 ), sort( grep( !ref, @$a2 ) ) ], 1799 ); 1800} 1801 1802=back 1803 1804 1805=head2 Extending and Embedding Test::More 1806 1807Sometimes the Test::More interface isn't quite enough. Fortunately, 1808Test::More is built on top of L<Test::Builder> which provides a single, 1809unified backend for any test library to use. This means two test 1810libraries which both use L<Test::Builder> B<can> be used together in the 1811same program. 1812 1813If you simply want to do a little tweaking of how the tests behave, 1814you can access the underlying L<Test::Builder> object like so: 1815 1816=over 4 1817 1818=item B<builder> 1819 1820 my $test_builder = Test::More->builder; 1821 1822Returns the L<Test::Builder> object underlying Test::More for you to play 1823with. 1824 1825 1826=back 1827 1828 1829=head1 EXIT CODES 1830 1831If all your tests passed, L<Test::Builder> will exit with zero (which is 1832normal). If anything failed it will exit with how many failed. If 1833you run less (or more) tests than you planned, the missing (or extras) 1834will be considered failures. If no tests were ever run L<Test::Builder> 1835will throw a warning and exit with 255. If the test died, even after 1836having successfully completed all its tests, it will still be 1837considered a failure and will exit with 255. 1838 1839So the exit codes are... 1840 1841 0 all tests successful 1842 255 test died or all passed but wrong # of tests run 1843 any other number how many failed (including missing or extras) 1844 1845If you fail more than 254 tests, it will be reported as 254. 1846 1847B<NOTE> This behavior may go away in future versions. 1848 1849 1850=head1 COMPATIBILITY 1851 1852Test::More works with Perls as old as 5.8.1. 1853 1854Thread support is not very reliable before 5.10.1, but that's 1855because threads are not very reliable before 5.10.1. 1856 1857Although 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. 1858 1859Key feature milestones include: 1860 1861=over 4 1862 1863=item subtests 1864 1865Subtests 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. 1866 1867=item C<done_testing()> 1868 1869This was released in Test::More 0.88 and first shipped with Perl in 5.10.1 as part of Test::More 0.92. 1870 1871=item C<cmp_ok()> 1872 1873Although 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. 1874 1875=item C<new_ok()> C<note()> and C<explain()> 1876 1877These were was released in Test::More 0.82, and first shipped with Perl in 5.10.1 as part of Test::More 0.92. 1878 1879=back 1880 1881There is a full version history in the Changes file, and the Test::More versions included as core can be found using L<Module::CoreList>: 1882 1883 $ corelist -a Test::More 1884 1885 1886=head1 CAVEATS and NOTES 1887 1888=over 4 1889 1890=item utf8 / "Wide character in print" 1891 1892If you use utf8 or other non-ASCII characters with Test::More you 1893might get a "Wide character in print" warning. Using 1894C<< binmode STDOUT, ":utf8" >> will not fix it. 1895L<Test::Builder> (which powers 1896Test::More) duplicates STDOUT and STDERR. So any changes to them, 1897including changing their output disciplines, will not be seen by 1898Test::More. 1899 1900One work around is to apply encodings to STDOUT and STDERR as early 1901as possible and before Test::More (or any other Test module) loads. 1902 1903 use open ':std', ':encoding(utf8)'; 1904 use Test::More; 1905 1906A more direct work around is to change the filehandles used by 1907L<Test::Builder>. 1908 1909 my $builder = Test::More->builder; 1910 binmode $builder->output, ":encoding(utf8)"; 1911 binmode $builder->failure_output, ":encoding(utf8)"; 1912 binmode $builder->todo_output, ":encoding(utf8)"; 1913 1914 1915=item Overloaded objects 1916 1917String overloaded objects are compared B<as strings> (or in C<cmp_ok()>'s 1918case, strings or numbers as appropriate to the comparison op). This 1919prevents Test::More from piercing an object's interface allowing 1920better blackbox testing. So if a function starts returning overloaded 1921objects instead of bare strings your tests won't notice the 1922difference. This is good. 1923 1924However, it does mean that functions like C<is_deeply()> cannot be used to 1925test the internals of string overloaded objects. In this case I would 1926suggest L<Test::Deep> which contains more flexible testing functions for 1927complex data structures. 1928 1929 1930=item Threads 1931 1932Test::More will only be aware of threads if C<use threads> has been done 1933I<before> Test::More is loaded. This is ok: 1934 1935 use threads; 1936 use Test::More; 1937 1938This may cause problems: 1939 1940 use Test::More 1941 use threads; 1942 19435.8.1 and above are supported. Anything below that has too many bugs. 1944 1945=back 1946 1947 1948=head1 HISTORY 1949 1950This is a case of convergent evolution with Joshua Pritikin's L<Test> 1951module. I was largely unaware of its existence when I'd first 1952written my own C<ok()> routines. This module exists because I can't 1953figure out how to easily wedge test names into Test's interface (along 1954with a few other problems). 1955 1956The goal here is to have a testing utility that's simple to learn, 1957quick to use and difficult to trip yourself up with while still 1958providing more flexibility than the existing Test.pm. As such, the 1959names of the most common routines are kept tiny, special cases and 1960magic side-effects are kept to a minimum. WYSIWYG. 1961 1962 1963=head1 SEE ALSO 1964 1965=head2 1966 1967=head2 ALTERNATIVES 1968 1969L<Test2::Suite> is the most recent and modern set of tools for testing. 1970 1971L<Test::Simple> if all this confuses you and you just want to write 1972some tests. You can upgrade to Test::More later (it's forward 1973compatible). 1974 1975L<Test::Legacy> tests written with Test.pm, the original testing 1976module, do not play well with other testing libraries. Test::Legacy 1977emulates the Test.pm interface and does play well with others. 1978 1979=head2 ADDITIONAL LIBRARIES 1980 1981L<Test::Differences> for more ways to test complex data structures. 1982And it plays well with Test::More. 1983 1984L<Test::Class> is like xUnit but more perlish. 1985 1986L<Test::Deep> gives you more powerful complex data structure testing. 1987 1988L<Test::Inline> shows the idea of embedded testing. 1989 1990L<Mock::Quick> The ultimate mocking library. Easily spawn objects defined on 1991the fly. Can also override, block, or reimplement packages as needed. 1992 1993L<Test::FixtureBuilder> Quickly define fixture data for unit tests. 1994 1995=head2 OTHER COMPONENTS 1996 1997L<Test::Harness> is the test runner and output interpreter for Perl. 1998It's the thing that powers C<make test> and where the C<prove> utility 1999comes from. 2000 2001=head2 BUNDLES 2002 2003L<Test::Most> Most commonly needed test functions and features. 2004 2005=head1 AUTHORS 2006 2007Michael G Schwern E<lt>schwern@pobox.comE<gt> with much inspiration 2008from Joshua Pritikin's Test module and lots of help from Barrie 2009Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and 2010the perl-qa gang. 2011 2012=head1 MAINTAINERS 2013 2014=over 4 2015 2016=item Chad Granum E<lt>exodist@cpan.orgE<gt> 2017 2018=back 2019 2020 2021=head1 BUGS 2022 2023See L<https://github.com/Test-More/test-more/issues> to report and view bugs. 2024 2025 2026=head1 SOURCE 2027 2028The source code repository for Test::More can be found at 2029L<https://github.com/Test-More/test-more/>. 2030 2031 2032=head1 COPYRIGHT 2033 2034Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. 2035 2036This program is free software; you can redistribute it and/or 2037modify it under the same terms as Perl itself. 2038 2039See L<https://dev.perl.org/licenses/> 2040 2041=cut 2042 20431; 2044