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