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