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