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