1package Test::More; 2 3use 5.004; 4 5use strict; 6use Test::Builder; 7 8 9# Can't use Carp because it might cause use_ok() to accidentally succeed 10# even though the module being used forgot to use Carp. Yes, this 11# actually happened. 12sub _carp { 13 my($file, $line) = (caller(1))[1,2]; 14 warn @_, " at $file line $line\n"; 15} 16 17 18 19require Exporter; 20use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO); 21$VERSION = '0.47'; 22@ISA = qw(Exporter); 23@EXPORT = qw(ok use_ok require_ok 24 is isnt like unlike is_deeply 25 cmp_ok 26 skip todo todo_skip 27 pass fail 28 eq_array eq_hash eq_set 29 $TODO 30 plan 31 can_ok isa_ok 32 diag 33 ); 34 35my $Test = Test::Builder->new; 36 37 38# 5.004's Exporter doesn't have export_to_level. 39sub _export_to_level 40{ 41 my $pkg = shift; 42 my $level = shift; 43 (undef) = shift; # redundant arg 44 my $callpkg = caller($level); 45 $pkg->export($callpkg, @_); 46} 47 48 49=head1 NAME 50 51Test::More - yet another framework for writing test scripts 52 53=head1 SYNOPSIS 54 55 use Test::More tests => $Num_Tests; 56 # or 57 use Test::More qw(no_plan); 58 # or 59 use Test::More skip_all => $reason; 60 61 BEGIN { use_ok( 'Some::Module' ); } 62 require_ok( 'Some::Module' ); 63 64 # Various ways to say "ok" 65 ok($this eq $that, $test_name); 66 67 is ($this, $that, $test_name); 68 isnt($this, $that, $test_name); 69 70 # Rather than print STDERR "# here's what went wrong\n" 71 diag("here's what went wrong"); 72 73 like ($this, qr/that/, $test_name); 74 unlike($this, qr/that/, $test_name); 75 76 cmp_ok($this, '==', $that, $test_name); 77 78 is_deeply($complex_structure1, $complex_structure2, $test_name); 79 80 SKIP: { 81 skip $why, $how_many unless $have_some_feature; 82 83 ok( foo(), $test_name ); 84 is( foo(42), 23, $test_name ); 85 }; 86 87 TODO: { 88 local $TODO = $why; 89 90 ok( foo(), $test_name ); 91 is( foo(42), 23, $test_name ); 92 }; 93 94 can_ok($module, @methods); 95 isa_ok($object, $class); 96 97 pass($test_name); 98 fail($test_name); 99 100 # Utility comparison functions. 101 eq_array(\@this, \@that); 102 eq_hash(\%this, \%that); 103 eq_set(\@this, \@that); 104 105 # UNIMPLEMENTED!!! 106 my @status = Test::More::status; 107 108 # UNIMPLEMENTED!!! 109 BAIL_OUT($why); 110 111 112=head1 DESCRIPTION 113 114B<STOP!> If you're just getting started writing tests, have a look at 115Test::Simple first. This is a drop in replacement for Test::Simple 116which you can switch to once you get the hang of basic testing. 117 118The purpose of this module is to provide a wide range of testing 119utilities. Various ways to say "ok" with better diagnostics, 120facilities to skip tests, test future features and compare complicated 121data structures. While you can do almost anything with a simple 122C<ok()> function, it doesn't provide good diagnostic output. 123 124 125=head2 I love it when a plan comes together 126 127Before anything else, you need a testing plan. This basically declares 128how many tests your script is going to run to protect against premature 129failure. 130 131The preferred way to do this is to declare a plan when you C<use Test::More>. 132 133 use Test::More tests => $Num_Tests; 134 135There are rare cases when you will not know beforehand how many tests 136your script is going to run. In this case, you can declare that you 137have no plan. (Try to avoid using this as it weakens your test.) 138 139 use Test::More qw(no_plan); 140 141In some cases, you'll want to completely skip an entire testing script. 142 143 use Test::More skip_all => $skip_reason; 144 145Your script will declare a skip with the reason why you skipped and 146exit immediately with a zero (success). See L<Test::Harness> for 147details. 148 149If you want to control what functions Test::More will export, you 150have to use the 'import' option. For example, to import everything 151but 'fail', you'd do: 152 153 use Test::More tests => 23, import => ['!fail']; 154 155Alternatively, you can use the plan() function. Useful for when you 156have to calculate the number of tests. 157 158 use Test::More; 159 plan tests => keys %Stuff * 3; 160 161or for deciding between running the tests at all: 162 163 use Test::More; 164 if( $^O eq 'MacOS' ) { 165 plan skip_all => 'Test irrelevant on MacOS'; 166 } 167 else { 168 plan tests => 42; 169 } 170 171=cut 172 173sub plan { 174 my(@plan) = @_; 175 176 my $caller = caller; 177 178 $Test->exported_to($caller); 179 180 my @imports = (); 181 foreach my $idx (0..$#plan) { 182 if( $plan[$idx] eq 'import' ) { 183 my($tag, $imports) = splice @plan, $idx, 2; 184 @imports = @$imports; 185 last; 186 } 187 } 188 189 $Test->plan(@plan); 190 191 __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports); 192} 193 194sub import { 195 my($class) = shift; 196 goto &plan; 197} 198 199 200=head2 Test names 201 202By convention, each test is assigned a number in order. This is 203largely done automatically for you. However, it's often very useful to 204assign a name to each test. Which would you rather see: 205 206 ok 4 207 not ok 5 208 ok 6 209 210or 211 212 ok 4 - basic multi-variable 213 not ok 5 - simple exponential 214 ok 6 - force == mass * acceleration 215 216The later gives you some idea of what failed. It also makes it easier 217to find the test in your script, simply search for "simple 218exponential". 219 220All test functions take a name argument. It's optional, but highly 221suggested that you use it. 222 223 224=head2 I'm ok, you're not ok. 225 226The basic purpose of this module is to print out either "ok #" or "not 227ok #" depending on if a given test succeeded or failed. Everything 228else is just gravy. 229 230All of the following print "ok" or "not ok" depending on if the test 231succeeded or failed. They all also return true or false, 232respectively. 233 234=over 4 235 236=item B<ok> 237 238 ok($this eq $that, $test_name); 239 240This simply evaluates any expression (C<$this eq $that> is just a 241simple example) and uses that to determine if the test succeeded or 242failed. A true expression passes, a false one fails. Very simple. 243 244For example: 245 246 ok( $exp{9} == 81, 'simple exponential' ); 247 ok( Film->can('db_Main'), 'set_db()' ); 248 ok( $p->tests == 4, 'saw tests' ); 249 ok( !grep !defined $_, @items, 'items populated' ); 250 251(Mnemonic: "This is ok.") 252 253$test_name is a very short description of the test that will be printed 254out. It makes it very easy to find a test in your script when it fails 255and gives others an idea of your intentions. $test_name is optional, 256but we B<very> strongly encourage its use. 257 258Should an ok() fail, it will produce some diagnostics: 259 260 not ok 18 - sufficient mucus 261 # Failed test 18 (foo.t at line 42) 262 263This is actually Test::Simple's ok() routine. 264 265=cut 266 267sub ok ($;$) { 268 my($test, $name) = @_; 269 $Test->ok($test, $name); 270} 271 272=item B<is> 273 274=item B<isnt> 275 276 is ( $this, $that, $test_name ); 277 isnt( $this, $that, $test_name ); 278 279Similar to ok(), is() and isnt() compare their two arguments 280with C<eq> and C<ne> respectively and use the result of that to 281determine if the test succeeded or failed. So these: 282 283 # Is the ultimate answer 42? 284 is( ultimate_answer(), 42, "Meaning of Life" ); 285 286 # $foo isn't empty 287 isnt( $foo, '', "Got some foo" ); 288 289are similar to these: 290 291 ok( ultimate_answer() eq 42, "Meaning of Life" ); 292 ok( $foo ne '', "Got some foo" ); 293 294(Mnemonic: "This is that." "This isn't that.") 295 296So why use these? They produce better diagnostics on failure. ok() 297cannot know what you are testing for (beyond the name), but is() and 298isnt() know what the test was and why it failed. For example this 299test: 300 301 my $foo = 'waffle'; my $bar = 'yarblokos'; 302 is( $foo, $bar, 'Is foo the same as bar?' ); 303 304Will produce something like this: 305 306 not ok 17 - Is foo the same as bar? 307 # Failed test (foo.t at line 139) 308 # got: 'waffle' 309 # expected: 'yarblokos' 310 311So you can figure out what went wrong without rerunning the test. 312 313You are encouraged to use is() and isnt() over ok() where possible, 314however do not be tempted to use them to find out if something is 315true or false! 316 317 # XXX BAD! $pope->isa('Catholic') eq 1 318 is( $pope->isa('Catholic'), 1, 'Is the Pope Catholic?' ); 319 320This does not check if C<$pope->isa('Catholic')> is true, it checks if 321it returns 1. Very different. Similar caveats exist for false and 0. 322In these cases, use ok(). 323 324 ok( $pope->isa('Catholic') ), 'Is the Pope Catholic?' ); 325 326For those grammatical pedants out there, there's an C<isn't()> 327function which is an alias of isnt(). 328 329=cut 330 331sub is ($$;$) { 332 $Test->is_eq(@_); 333} 334 335sub isnt ($$;$) { 336 $Test->isnt_eq(@_); 337} 338 339*isn't = \&isnt; 340 341 342=item B<like> 343 344 like( $this, qr/that/, $test_name ); 345 346Similar to ok(), like() matches $this against the regex C<qr/that/>. 347 348So this: 349 350 like($this, qr/that/, 'this is like that'); 351 352is similar to: 353 354 ok( $this =~ /that/, 'this is like that'); 355 356(Mnemonic "This is like that".) 357 358The second argument is a regular expression. It may be given as a 359regex reference (i.e. C<qr//>) or (for better compatibility with older 360perls) as a string that looks like a regex (alternative delimiters are 361currently not supported): 362 363 like( $this, '/that/', 'this is like that' ); 364 365Regex options may be placed on the end (C<'/that/i'>). 366 367Its advantages over ok() are similar to that of is() and isnt(). Better 368diagnostics on failure. 369 370=cut 371 372sub like ($$;$) { 373 $Test->like(@_); 374} 375 376 377=item B<unlike> 378 379 unlike( $this, qr/that/, $test_name ); 380 381Works exactly as like(), only it checks if $this B<does not> match the 382given pattern. 383 384=cut 385 386sub unlike { 387 $Test->unlike(@_); 388} 389 390 391=item B<cmp_ok> 392 393 cmp_ok( $this, $op, $that, $test_name ); 394 395Halfway between ok() and is() lies cmp_ok(). This allows you to 396compare two arguments using any binary perl operator. 397 398 # ok( $this eq $that ); 399 cmp_ok( $this, 'eq', $that, 'this eq that' ); 400 401 # ok( $this == $that ); 402 cmp_ok( $this, '==', $that, 'this == that' ); 403 404 # ok( $this && $that ); 405 cmp_ok( $this, '&&', $that, 'this || that' ); 406 ...etc... 407 408Its advantage over ok() is when the test fails you'll know what $this 409and $that were: 410 411 not ok 1 412 # Failed test (foo.t at line 12) 413 # '23' 414 # && 415 # undef 416 417It's also useful in those cases where you are comparing numbers and 418is()'s use of C<eq> will interfere: 419 420 cmp_ok( $big_hairy_number, '==', $another_big_hairy_number ); 421 422=cut 423 424sub cmp_ok($$$;$) { 425 $Test->cmp_ok(@_); 426} 427 428 429=item B<can_ok> 430 431 can_ok($module, @methods); 432 can_ok($object, @methods); 433 434Checks to make sure the $module or $object can do these @methods 435(works with functions, too). 436 437 can_ok('Foo', qw(this that whatever)); 438 439is almost exactly like saying: 440 441 ok( Foo->can('this') && 442 Foo->can('that') && 443 Foo->can('whatever') 444 ); 445 446only without all the typing and with a better interface. Handy for 447quickly testing an interface. 448 449No matter how many @methods you check, a single can_ok() call counts 450as one test. If you desire otherwise, use: 451 452 foreach my $meth (@methods) { 453 can_ok('Foo', $meth); 454 } 455 456=cut 457 458sub can_ok ($@) { 459 my($proto, @methods) = @_; 460 my $class = ref $proto || $proto; 461 462 unless( @methods ) { 463 my $ok = $Test->ok( 0, "$class->can(...)" ); 464 $Test->diag(' can_ok() called with no methods'); 465 return $ok; 466 } 467 468 my @nok = (); 469 foreach my $method (@methods) { 470 local($!, $@); # don't interfere with caller's $@ 471 # eval sometimes resets $! 472 eval { $proto->can($method) } || push @nok, $method; 473 } 474 475 my $name; 476 $name = @methods == 1 ? "$class->can('$methods[0]')" 477 : "$class->can(...)"; 478 479 my $ok = $Test->ok( !@nok, $name ); 480 481 $Test->diag(map " $class->can('$_') failed\n", @nok); 482 483 return $ok; 484} 485 486=item B<isa_ok> 487 488 isa_ok($object, $class, $object_name); 489 isa_ok($ref, $type, $ref_name); 490 491Checks to see if the given $object->isa($class). Also checks to make 492sure the object was defined in the first place. Handy for this sort 493of thing: 494 495 my $obj = Some::Module->new; 496 isa_ok( $obj, 'Some::Module' ); 497 498where you'd otherwise have to write 499 500 my $obj = Some::Module->new; 501 ok( defined $obj && $obj->isa('Some::Module') ); 502 503to safeguard against your test script blowing up. 504 505It works on references, too: 506 507 isa_ok( $array_ref, 'ARRAY' ); 508 509The diagnostics of this test normally just refer to 'the object'. If 510you'd like them to be more specific, you can supply an $object_name 511(for example 'Test customer'). 512 513=cut 514 515sub isa_ok ($$;$) { 516 my($object, $class, $obj_name) = @_; 517 518 my $diag; 519 $obj_name = 'The object' unless defined $obj_name; 520 my $name = "$obj_name isa $class"; 521 if( !defined $object ) { 522 $diag = "$obj_name isn't defined"; 523 } 524 elsif( !ref $object ) { 525 $diag = "$obj_name isn't a reference"; 526 } 527 else { 528 # We can't use UNIVERSAL::isa because we want to honor isa() overrides 529 local($@, $!); # eval sometimes resets $! 530 my $rslt = eval { $object->isa($class) }; 531 if( $@ ) { 532 if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) { 533 if( !UNIVERSAL::isa($object, $class) ) { 534 my $ref = ref $object; 535 $diag = "$obj_name isn't a '$class' it's a '$ref'"; 536 } 537 } else { 538 die <<WHOA; 539WHOA! I tried to call ->isa on your object and got some weird error. 540This should never happen. Please contact the author immediately. 541Here's the error. 542$@ 543WHOA 544 } 545 } 546 elsif( !$rslt ) { 547 my $ref = ref $object; 548 $diag = "$obj_name isn't a '$class' it's a '$ref'"; 549 } 550 } 551 552 553 554 my $ok; 555 if( $diag ) { 556 $ok = $Test->ok( 0, $name ); 557 $Test->diag(" $diag\n"); 558 } 559 else { 560 $ok = $Test->ok( 1, $name ); 561 } 562 563 return $ok; 564} 565 566 567=item B<pass> 568 569=item B<fail> 570 571 pass($test_name); 572 fail($test_name); 573 574Sometimes you just want to say that the tests have passed. Usually 575the case is you've got some complicated condition that is difficult to 576wedge into an ok(). In this case, you can simply use pass() (to 577declare the test ok) or fail (for not ok). They are synonyms for 578ok(1) and ok(0). 579 580Use these very, very, very sparingly. 581 582=cut 583 584sub pass (;$) { 585 $Test->ok(1, @_); 586} 587 588sub fail (;$) { 589 $Test->ok(0, @_); 590} 591 592=back 593 594=head2 Diagnostics 595 596If you pick the right test function, you'll usually get a good idea of 597what went wrong when it failed. But sometimes it doesn't work out 598that way. So here we have ways for you to write your own diagnostic 599messages which are safer than just C<print STDERR>. 600 601=over 4 602 603=item B<diag> 604 605 diag(@diagnostic_message); 606 607Prints a diagnostic message which is guaranteed not to interfere with 608test output. Handy for this sort of thing: 609 610 ok( grep(/foo/, @users), "There's a foo user" ) or 611 diag("Since there's no foo, check that /etc/bar is set up right"); 612 613which would produce: 614 615 not ok 42 - There's a foo user 616 # Failed test (foo.t at line 52) 617 # Since there's no foo, check that /etc/bar is set up right. 618 619You might remember C<ok() or diag()> with the mnemonic C<open() or 620die()>. 621 622B<NOTE> The exact formatting of the diagnostic output is still 623changing, but it is guaranteed that whatever you throw at it it won't 624interfere with the test. 625 626=cut 627 628sub diag { 629 $Test->diag(@_); 630} 631 632 633=back 634 635=head2 Module tests 636 637You usually want to test if the module you're testing loads ok, rather 638than just vomiting if its load fails. For such purposes we have 639C<use_ok> and C<require_ok>. 640 641=over 4 642 643=item B<use_ok> 644 645 BEGIN { use_ok($module); } 646 BEGIN { use_ok($module, @imports); } 647 648These simply use the given $module and test to make sure the load 649happened ok. It's recommended that you run use_ok() inside a BEGIN 650block so its functions are exported at compile-time and prototypes are 651properly honored. 652 653If @imports are given, they are passed through to the use. So this: 654 655 BEGIN { use_ok('Some::Module', qw(foo bar)) } 656 657is like doing this: 658 659 use Some::Module qw(foo bar); 660 661don't try to do this: 662 663 BEGIN { 664 use_ok('Some::Module'); 665 666 ...some code that depends on the use... 667 ...happening at compile time... 668 } 669 670instead, you want: 671 672 BEGIN { use_ok('Some::Module') } 673 BEGIN { ...some code that depends on the use... } 674 675 676=cut 677 678sub use_ok ($;@) { 679 my($module, @imports) = @_; 680 @imports = () unless @imports; 681 682 my $pack = caller; 683 684 local($@,$!); # eval sometimes interferes with $! 685 eval <<USE; 686package $pack; 687require $module; 688'$module'->import(\@imports); 689USE 690 691 my $ok = $Test->ok( !$@, "use $module;" ); 692 693 unless( $ok ) { 694 chomp $@; 695 $Test->diag(<<DIAGNOSTIC); 696 Tried to use '$module'. 697 Error: $@ 698DIAGNOSTIC 699 700 } 701 702 return $ok; 703} 704 705=item B<require_ok> 706 707 require_ok($module); 708 709Like use_ok(), except it requires the $module. 710 711=cut 712 713sub require_ok ($) { 714 my($module) = shift; 715 716 my $pack = caller; 717 718 local($!, $@); # eval sometimes interferes with $! 719 eval <<REQUIRE; 720package $pack; 721require $module; 722REQUIRE 723 724 my $ok = $Test->ok( !$@, "require $module;" ); 725 726 unless( $ok ) { 727 chomp $@; 728 $Test->diag(<<DIAGNOSTIC); 729 Tried to require '$module'. 730 Error: $@ 731DIAGNOSTIC 732 733 } 734 735 return $ok; 736} 737 738=back 739 740=head2 Conditional tests 741 742Sometimes running a test under certain conditions will cause the 743test script to die. A certain function or method isn't implemented 744(such as fork() on MacOS), some resource isn't available (like a 745net connection) or a module isn't available. In these cases it's 746necessary to skip tests, or declare that they are supposed to fail 747but will work in the future (a todo test). 748 749For more details on the mechanics of skip and todo tests see 750L<Test::Harness>. 751 752The way Test::More handles this is with a named block. Basically, a 753block of tests which can be skipped over or made todo. It's best if I 754just show you... 755 756=over 4 757 758=item B<SKIP: BLOCK> 759 760 SKIP: { 761 skip $why, $how_many if $condition; 762 763 ...normal testing code goes here... 764 } 765 766This declares a block of tests that might be skipped, $how_many tests 767there are, $why and under what $condition to skip them. An example is 768the easiest way to illustrate: 769 770 SKIP: { 771 eval { require HTML::Lint }; 772 773 skip "HTML::Lint not installed", 2 if $@; 774 775 my $lint = new HTML::Lint; 776 isa_ok( $lint, "HTML::Lint" ); 777 778 $lint->parse( $html ); 779 is( $lint->errors, 0, "No errors found in HTML" ); 780 } 781 782If the user does not have HTML::Lint installed, the whole block of 783code I<won't be run at all>. Test::More will output special ok's 784which Test::Harness interprets as skipped, but passing, tests. 785It's important that $how_many accurately reflects the number of tests 786in the SKIP block so the # of tests run will match up with your plan. 787 788It's perfectly safe to nest SKIP blocks. Each SKIP block must have 789the label C<SKIP>, or Test::More can't work its magic. 790 791You don't skip tests which are failing because there's a bug in your 792program, or for which you don't yet have code written. For that you 793use TODO. Read on. 794 795=cut 796 797#'# 798sub skip { 799 my($why, $how_many) = @_; 800 801 unless( defined $how_many ) { 802 # $how_many can only be avoided when no_plan is in use. 803 _carp "skip() needs to know \$how_many tests are in the block" 804 unless $Test::Builder::No_Plan; 805 $how_many = 1; 806 } 807 808 for( 1..$how_many ) { 809 $Test->skip($why); 810 } 811 812 local $^W = 0; 813 last SKIP; 814} 815 816 817=item B<TODO: BLOCK> 818 819 TODO: { 820 local $TODO = $why if $condition; 821 822 ...normal testing code goes here... 823 } 824 825Declares a block of tests you expect to fail and $why. Perhaps it's 826because you haven't fixed a bug or haven't finished a new feature: 827 828 TODO: { 829 local $TODO = "URI::Geller not finished"; 830 831 my $card = "Eight of clubs"; 832 is( URI::Geller->your_card, $card, 'Is THIS your card?' ); 833 834 my $spoon; 835 URI::Geller->bend_spoon; 836 is( $spoon, 'bent', "Spoon bending, that's original" ); 837 } 838 839With a todo block, the tests inside are expected to fail. Test::More 840will run the tests normally, but print out special flags indicating 841they are "todo". Test::Harness will interpret failures as being ok. 842Should anything succeed, it will report it as an unexpected success. 843You then know the thing you had todo is done and can remove the 844TODO flag. 845 846The nice part about todo tests, as opposed to simply commenting out a 847block of tests, is it's like having a programmatic todo list. You know 848how much work is left to be done, you're aware of what bugs there are, 849and you'll know immediately when they're fixed. 850 851Once a todo test starts succeeding, simply move it outside the block. 852When the block is empty, delete it. 853 854 855=item B<todo_skip> 856 857 TODO: { 858 todo_skip $why, $how_many if $condition; 859 860 ...normal testing code... 861 } 862 863With todo tests, it's best to have the tests actually run. That way 864you'll know when they start passing. Sometimes this isn't possible. 865Often a failing test will cause the whole program to die or hang, even 866inside an C<eval BLOCK> with and using C<alarm>. In these extreme 867cases you have no choice but to skip over the broken tests entirely. 868 869The syntax and behavior is similar to a C<SKIP: BLOCK> except the 870tests will be marked as failing but todo. Test::Harness will 871interpret them as passing. 872 873=cut 874 875sub todo_skip { 876 my($why, $how_many) = @_; 877 878 unless( defined $how_many ) { 879 # $how_many can only be avoided when no_plan is in use. 880 _carp "todo_skip() needs to know \$how_many tests are in the block" 881 unless $Test::Builder::No_Plan; 882 $how_many = 1; 883 } 884 885 for( 1..$how_many ) { 886 $Test->todo_skip($why); 887 } 888 889 local $^W = 0; 890 last TODO; 891} 892 893=item When do I use SKIP vs. TODO? 894 895B<If it's something the user might not be able to do>, use SKIP. 896This includes optional modules that aren't installed, running under 897an OS that doesn't have some feature (like fork() or symlinks), or maybe 898you need an Internet connection and one isn't available. 899 900B<If it's something the programmer hasn't done yet>, use TODO. This 901is for any code you haven't written yet, or bugs you have yet to fix, 902but want to put tests in your testing script (always a good idea). 903 904 905=back 906 907=head2 Comparison functions 908 909Not everything is a simple eq check or regex. There are times you 910need to see if two arrays are equivalent, for instance. For these 911instances, Test::More provides a handful of useful functions. 912 913B<NOTE> These are NOT well-tested on circular references. Nor am I 914quite sure what will happen with filehandles. 915 916=over 4 917 918=item B<is_deeply> 919 920 is_deeply( $this, $that, $test_name ); 921 922Similar to is(), except that if $this and $that are hash or array 923references, it does a deep comparison walking each data structure to 924see if they are equivalent. If the two structures are different, it 925will display the place where they start differing. 926 927Barrie Slaymaker's Test::Differences module provides more in-depth 928functionality along these lines, and it plays well with Test::More. 929 930B<NOTE> Display of scalar refs is not quite 100% 931 932=cut 933 934use vars qw(@Data_Stack); 935my $DNE = bless [], 'Does::Not::Exist'; 936sub is_deeply { 937 my($this, $that, $name) = @_; 938 939 my $ok; 940 if( !ref $this || !ref $that ) { 941 $ok = $Test->is_eq($this, $that, $name); 942 } 943 else { 944 local @Data_Stack = (); 945 if( _deep_check($this, $that) ) { 946 $ok = $Test->ok(1, $name); 947 } 948 else { 949 $ok = $Test->ok(0, $name); 950 $ok = $Test->diag(_format_stack(@Data_Stack)); 951 } 952 } 953 954 return $ok; 955} 956 957sub _format_stack { 958 my(@Stack) = @_; 959 960 my $var = '$FOO'; 961 my $did_arrow = 0; 962 foreach my $entry (@Stack) { 963 my $type = $entry->{type} || ''; 964 my $idx = $entry->{'idx'}; 965 if( $type eq 'HASH' ) { 966 $var .= "->" unless $did_arrow++; 967 $var .= "{$idx}"; 968 } 969 elsif( $type eq 'ARRAY' ) { 970 $var .= "->" unless $did_arrow++; 971 $var .= "[$idx]"; 972 } 973 elsif( $type eq 'REF' ) { 974 $var = "\${$var}"; 975 } 976 } 977 978 my @vals = @{$Stack[-1]{vals}}[0,1]; 979 my @vars = (); 980 ($vars[0] = $var) =~ s/\$FOO/ \$got/; 981 ($vars[1] = $var) =~ s/\$FOO/\$expected/; 982 983 my $out = "Structures begin differing at:\n"; 984 foreach my $idx (0..$#vals) { 985 my $val = $vals[$idx]; 986 $vals[$idx] = !defined $val ? 'undef' : 987 $val eq $DNE ? "Does not exist" 988 : "'$val'"; 989 } 990 991 $out .= "$vars[0] = $vals[0]\n"; 992 $out .= "$vars[1] = $vals[1]\n"; 993 994 $out =~ s/^/ /msg; 995 return $out; 996} 997 998 999=item B<eq_array> 1000 1001 eq_array(\@this, \@that); 1002 1003Checks if two arrays are equivalent. This is a deep check, so 1004multi-level structures are handled correctly. 1005 1006=cut 1007 1008#'# 1009sub eq_array { 1010 my($a1, $a2) = @_; 1011 return 1 if $a1 eq $a2; 1012 1013 my $ok = 1; 1014 my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; 1015 for (0..$max) { 1016 my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; 1017 my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; 1018 1019 push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] }; 1020 $ok = _deep_check($e1,$e2); 1021 pop @Data_Stack if $ok; 1022 1023 last unless $ok; 1024 } 1025 return $ok; 1026} 1027 1028sub _deep_check { 1029 my($e1, $e2) = @_; 1030 my $ok = 0; 1031 1032 my $eq; 1033 { 1034 # Quiet uninitialized value warnings when comparing undefs. 1035 local $^W = 0; 1036 1037 if( $e1 eq $e2 ) { 1038 $ok = 1; 1039 } 1040 else { 1041 if( UNIVERSAL::isa($e1, 'ARRAY') and 1042 UNIVERSAL::isa($e2, 'ARRAY') ) 1043 { 1044 $ok = eq_array($e1, $e2); 1045 } 1046 elsif( UNIVERSAL::isa($e1, 'HASH') and 1047 UNIVERSAL::isa($e2, 'HASH') ) 1048 { 1049 $ok = eq_hash($e1, $e2); 1050 } 1051 elsif( UNIVERSAL::isa($e1, 'REF') and 1052 UNIVERSAL::isa($e2, 'REF') ) 1053 { 1054 push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; 1055 $ok = _deep_check($$e1, $$e2); 1056 pop @Data_Stack if $ok; 1057 } 1058 elsif( UNIVERSAL::isa($e1, 'SCALAR') and 1059 UNIVERSAL::isa($e2, 'SCALAR') ) 1060 { 1061 push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; 1062 $ok = _deep_check($$e1, $$e2); 1063 } 1064 else { 1065 push @Data_Stack, { vals => [$e1, $e2] }; 1066 $ok = 0; 1067 } 1068 } 1069 } 1070 1071 return $ok; 1072} 1073 1074 1075=item B<eq_hash> 1076 1077 eq_hash(\%this, \%that); 1078 1079Determines if the two hashes contain the same keys and values. This 1080is a deep check. 1081 1082=cut 1083 1084sub eq_hash { 1085 my($a1, $a2) = @_; 1086 return 1 if $a1 eq $a2; 1087 1088 my $ok = 1; 1089 my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; 1090 foreach my $k (keys %$bigger) { 1091 my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; 1092 my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; 1093 1094 push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] }; 1095 $ok = _deep_check($e1, $e2); 1096 pop @Data_Stack if $ok; 1097 1098 last unless $ok; 1099 } 1100 1101 return $ok; 1102} 1103 1104=item B<eq_set> 1105 1106 eq_set(\@this, \@that); 1107 1108Similar to eq_array(), except the order of the elements is B<not> 1109important. This is a deep check, but the irrelevancy of order only 1110applies to the top level. 1111 1112B<NOTE> By historical accident, this is not a true set comparision. 1113While the order of elements does not matter, duplicate elements do. 1114 1115=cut 1116 1117# We must make sure that references are treated neutrally. It really 1118# doesn't matter how we sort them, as long as both arrays are sorted 1119# with the same algorithm. 1120sub _bogus_sort { local $^W = 0; ref $a ? 0 : $a cmp $b } 1121 1122sub eq_set { 1123 my($a1, $a2) = @_; 1124 return 0 unless @$a1 == @$a2; 1125 1126 # There's faster ways to do this, but this is easiest. 1127 return eq_array( [sort _bogus_sort @$a1], [sort _bogus_sort @$a2] ); 1128} 1129 1130=back 1131 1132 1133=head2 Extending and Embedding Test::More 1134 1135Sometimes the Test::More interface isn't quite enough. Fortunately, 1136Test::More is built on top of Test::Builder which provides a single, 1137unified backend for any test library to use. This means two test 1138libraries which both use Test::Builder B<can be used together in the 1139same program>. 1140 1141If you simply want to do a little tweaking of how the tests behave, 1142you can access the underlying Test::Builder object like so: 1143 1144=over 4 1145 1146=item B<builder> 1147 1148 my $test_builder = Test::More->builder; 1149 1150Returns the Test::Builder object underlying Test::More for you to play 1151with. 1152 1153=cut 1154 1155sub builder { 1156 return Test::Builder->new; 1157} 1158 1159=back 1160 1161 1162=head1 NOTES 1163 1164Test::More is B<explicitly> tested all the way back to perl 5.004. 1165 1166Test::More is thread-safe for perl 5.8.0 and up. 1167 1168=head1 BUGS and CAVEATS 1169 1170=over 4 1171 1172=item Making your own ok() 1173 1174If you are trying to extend Test::More, don't. Use Test::Builder 1175instead. 1176 1177=item The eq_* family has some caveats. 1178 1179=item Test::Harness upgrades 1180 1181no_plan and todo depend on new Test::Harness features and fixes. If 1182you're going to distribute tests that use no_plan or todo your 1183end-users will have to upgrade Test::Harness to the latest one on 1184CPAN. If you avoid no_plan and TODO tests, the stock Test::Harness 1185will work fine. 1186 1187If you simply depend on Test::More, it's own dependencies will cause a 1188Test::Harness upgrade. 1189 1190=back 1191 1192 1193=head1 HISTORY 1194 1195This is a case of convergent evolution with Joshua Pritikin's Test 1196module. I was largely unaware of its existence when I'd first 1197written my own ok() routines. This module exists because I can't 1198figure out how to easily wedge test names into Test's interface (along 1199with a few other problems). 1200 1201The goal here is to have a testing utility that's simple to learn, 1202quick to use and difficult to trip yourself up with while still 1203providing more flexibility than the existing Test.pm. As such, the 1204names of the most common routines are kept tiny, special cases and 1205magic side-effects are kept to a minimum. WYSIWYG. 1206 1207 1208=head1 SEE ALSO 1209 1210L<Test::Simple> if all this confuses you and you just want to write 1211some tests. You can upgrade to Test::More later (it's forward 1212compatible). 1213 1214L<Test::Differences> for more ways to test complex data structures. 1215And it plays well with Test::More. 1216 1217L<Test> is the old testing module. Its main benefit is that it has 1218been distributed with Perl since 5.004_05. 1219 1220L<Test::Harness> for details on how your test results are interpreted 1221by Perl. 1222 1223L<Test::Unit> describes a very featureful unit testing interface. 1224 1225L<Test::Inline> shows the idea of embedded testing. 1226 1227L<SelfTest> is another approach to embedded testing. 1228 1229 1230=head1 AUTHORS 1231 1232Michael G Schwern E<lt>schwern@pobox.comE<gt> with much inspiration 1233from Joshua Pritikin's Test module and lots of help from Barrie 1234Slaymaker, Tony Bowden, chromatic and the perl-qa gang. 1235 1236 1237=head1 COPYRIGHT 1238 1239Copyright 2001 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. 1240 1241This program is free software; you can redistribute it and/or 1242modify it under the same terms as Perl itself. 1243 1244See F<http://www.perl.com/perl/misc/Artistic.html> 1245 1246=cut 1247 12481; 1249