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