1package Test::Builder; 2 3use 5.004; 4 5# $^C was only introduced in 5.005-ish. We do this to prevent 6# use of uninitialized value warnings in older perls. 7$^C ||= 0; 8 9use strict; 10use vars qw($VERSION); 11$VERSION = '0.22'; 12$VERSION = eval $VERSION; # make the alpha version come out as a number 13 14# Make Test::Builder thread-safe for ithreads. 15BEGIN { 16 use Config; 17 # Load threads::shared when threads are turned on 18 if( $] >= 5.008 && $Config{useithreads} && $INC{'threads.pm'}) { 19 require threads::shared; 20 21 # Hack around YET ANOTHER threads::shared bug. It would 22 # occassionally forget the contents of the variable when sharing it. 23 # So we first copy the data, then share, then put our copy back. 24 *share = sub (\[$@%]) { 25 my $type = ref $_[0]; 26 my $data; 27 28 if( $type eq 'HASH' ) { 29 %$data = %{$_[0]}; 30 } 31 elsif( $type eq 'ARRAY' ) { 32 @$data = @{$_[0]}; 33 } 34 elsif( $type eq 'SCALAR' ) { 35 $$data = ${$_[0]}; 36 } 37 else { 38 die "Unknown type: ".$type; 39 } 40 41 $_[0] = &threads::shared::share($_[0]); 42 43 if( $type eq 'HASH' ) { 44 %{$_[0]} = %$data; 45 } 46 elsif( $type eq 'ARRAY' ) { 47 @{$_[0]} = @$data; 48 } 49 elsif( $type eq 'SCALAR' ) { 50 ${$_[0]} = $$data; 51 } 52 else { 53 die "Unknown type: ".$type; 54 } 55 56 return $_[0]; 57 }; 58 } 59 # 5.8.0's threads::shared is busted when threads are off. 60 # We emulate it here. 61 else { 62 *share = sub { return $_[0] }; 63 *lock = sub { 0 }; 64 } 65} 66 67 68=head1 NAME 69 70Test::Builder - Backend for building test libraries 71 72=head1 SYNOPSIS 73 74 package My::Test::Module; 75 use Test::Builder; 76 require Exporter; 77 @ISA = qw(Exporter); 78 @EXPORT = qw(ok); 79 80 my $Test = Test::Builder->new; 81 $Test->output('my_logfile'); 82 83 sub import { 84 my($self) = shift; 85 my $pack = caller; 86 87 $Test->exported_to($pack); 88 $Test->plan(@_); 89 90 $self->export_to_level(1, $self, 'ok'); 91 } 92 93 sub ok { 94 my($test, $name) = @_; 95 96 $Test->ok($test, $name); 97 } 98 99 100=head1 DESCRIPTION 101 102Test::Simple and Test::More have proven to be popular testing modules, 103but they're not always flexible enough. Test::Builder provides the a 104building block upon which to write your own test libraries I<which can 105work together>. 106 107=head2 Construction 108 109=over 4 110 111=item B<new> 112 113 my $Test = Test::Builder->new; 114 115Returns a Test::Builder object representing the current state of the 116test. 117 118Since you only run one test per program, there is B<one and only one> 119Test::Builder object. No matter how many times you call new(), you're 120getting the same object. (This is called a singleton). 121 122=cut 123 124my $Test = Test::Builder->new; 125sub new { 126 my($class) = shift; 127 $Test ||= bless ['Move along, nothing to see here'], $class; 128 return $Test; 129} 130 131=item B<reset> 132 133 $Test->reset; 134 135Reinitializes the Test::Builder singleton to its original state. 136Mostly useful for tests run in persistent environments where the same 137test might be run multiple times in the same process. 138 139=cut 140 141my $Test_Died; 142my $Have_Plan; 143my $No_Plan; 144my $Curr_Test; share($Curr_Test); 145use vars qw($Level); 146my $Original_Pid; 147my @Test_Results; share(@Test_Results); 148 149my $Exported_To; 150my $Expected_Tests; 151 152my $Skip_All; 153 154my $Use_Nums; 155 156my($No_Header, $No_Ending); 157 158$Test->reset; 159 160sub reset { 161 my ($self) = @_; 162 163 $Test_Died = 0; 164 $Have_Plan = 0; 165 $No_Plan = 0; 166 $Curr_Test = 0; 167 $Level = 1; 168 $Original_Pid = $$; 169 @Test_Results = (); 170 171 $Exported_To = undef; 172 $Expected_Tests = 0; 173 174 $Skip_All = 0; 175 176 $Use_Nums = 1; 177 178 ($No_Header, $No_Ending) = (0,0); 179 180 $self->_dup_stdhandles unless $^C; 181 182 return undef; 183} 184 185=back 186 187=head2 Setting up tests 188 189These methods are for setting up tests and declaring how many there 190are. You usually only want to call one of these methods. 191 192=over 4 193 194=item B<exported_to> 195 196 my $pack = $Test->exported_to; 197 $Test->exported_to($pack); 198 199Tells Test::Builder what package you exported your functions to. 200This is important for getting TODO tests right. 201 202=cut 203 204sub exported_to { 205 my($self, $pack) = @_; 206 207 if( defined $pack ) { 208 $Exported_To = $pack; 209 } 210 return $Exported_To; 211} 212 213=item B<plan> 214 215 $Test->plan('no_plan'); 216 $Test->plan( skip_all => $reason ); 217 $Test->plan( tests => $num_tests ); 218 219A convenient way to set up your tests. Call this and Test::Builder 220will print the appropriate headers and take the appropriate actions. 221 222If you call plan(), don't call any of the other methods below. 223 224=cut 225 226sub plan { 227 my($self, $cmd, $arg) = @_; 228 229 return unless $cmd; 230 231 if( $Have_Plan ) { 232 die sprintf "You tried to plan twice! Second plan at %s line %d\n", 233 ($self->caller)[1,2]; 234 } 235 236 if( $cmd eq 'no_plan' ) { 237 $self->no_plan; 238 } 239 elsif( $cmd eq 'skip_all' ) { 240 return $self->skip_all($arg); 241 } 242 elsif( $cmd eq 'tests' ) { 243 if( $arg ) { 244 return $self->expected_tests($arg); 245 } 246 elsif( !defined $arg ) { 247 die "Got an undefined number of tests. Looks like you tried to ". 248 "say how many tests you plan to run but made a mistake.\n"; 249 } 250 elsif( !$arg ) { 251 die "You said to run 0 tests! You've got to run something.\n"; 252 } 253 } 254 else { 255 require Carp; 256 my @args = grep { defined } ($cmd, $arg); 257 Carp::croak("plan() doesn't understand @args"); 258 } 259 260 return 1; 261} 262 263=item B<expected_tests> 264 265 my $max = $Test->expected_tests; 266 $Test->expected_tests($max); 267 268Gets/sets the # of tests we expect this test to run and prints out 269the appropriate headers. 270 271=cut 272 273sub expected_tests { 274 my $self = shift; 275 my($max) = @_; 276 277 if( @_ ) { 278 die "Number of tests must be a postive integer. You gave it '$max'.\n" 279 unless $max =~ /^\+?\d+$/ and $max > 0; 280 281 $Expected_Tests = $max; 282 $Have_Plan = 1; 283 284 $self->_print("1..$max\n") unless $self->no_header; 285 } 286 return $Expected_Tests; 287} 288 289 290=item B<no_plan> 291 292 $Test->no_plan; 293 294Declares that this test will run an indeterminate # of tests. 295 296=cut 297 298sub no_plan { 299 $No_Plan = 1; 300 $Have_Plan = 1; 301} 302 303=item B<has_plan> 304 305 $plan = $Test->has_plan 306 307Find out whether a plan has been defined. $plan is either C<undef> (no plan has been set), C<no_plan> (indeterminate # of tests) or an integer (the number of expected tests). 308 309=cut 310 311sub has_plan { 312 return($Expected_Tests) if $Expected_Tests; 313 return('no_plan') if $No_Plan; 314 return(undef); 315}; 316 317 318=item B<skip_all> 319 320 $Test->skip_all; 321 $Test->skip_all($reason); 322 323Skips all the tests, using the given $reason. Exits immediately with 0. 324 325=cut 326 327sub skip_all { 328 my($self, $reason) = @_; 329 330 my $out = "1..0"; 331 $out .= " # Skip $reason" if $reason; 332 $out .= "\n"; 333 334 $Skip_All = 1; 335 336 $self->_print($out) unless $self->no_header; 337 exit(0); 338} 339 340=back 341 342=head2 Running tests 343 344These actually run the tests, analogous to the functions in 345Test::More. 346 347$name is always optional. 348 349=over 4 350 351=item B<ok> 352 353 $Test->ok($test, $name); 354 355Your basic test. Pass if $test is true, fail if $test is false. Just 356like Test::Simple's ok(). 357 358=cut 359 360sub ok { 361 my($self, $test, $name) = @_; 362 363 # $test might contain an object which we don't want to accidentally 364 # store, so we turn it into a boolean. 365 $test = $test ? 1 : 0; 366 367 unless( $Have_Plan ) { 368 require Carp; 369 Carp::croak("You tried to run a test without a plan! Gotta have a plan."); 370 } 371 372 lock $Curr_Test; 373 $Curr_Test++; 374 375 # In case $name is a string overloaded object, force it to stringify. 376 $self->_unoverload(\$name); 377 378 $self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/; 379 You named your test '$name'. You shouldn't use numbers for your test names. 380 Very confusing. 381ERR 382 383 my($pack, $file, $line) = $self->caller; 384 385 my $todo = $self->todo($pack); 386 $self->_unoverload(\$todo); 387 388 my $out; 389 my $result = &share({}); 390 391 unless( $test ) { 392 $out .= "not "; 393 @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 ); 394 } 395 else { 396 @$result{ 'ok', 'actual_ok' } = ( 1, $test ); 397 } 398 399 $out .= "ok"; 400 $out .= " $Curr_Test" if $self->use_numbers; 401 402 if( defined $name ) { 403 $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. 404 $out .= " - $name"; 405 $result->{name} = $name; 406 } 407 else { 408 $result->{name} = ''; 409 } 410 411 if( $todo ) { 412 $out .= " # TODO $todo"; 413 $result->{reason} = $todo; 414 $result->{type} = 'todo'; 415 } 416 else { 417 $result->{reason} = ''; 418 $result->{type} = ''; 419 } 420 421 $Test_Results[$Curr_Test-1] = $result; 422 $out .= "\n"; 423 424 $self->_print($out); 425 426 unless( $test ) { 427 my $msg = $todo ? "Failed (TODO)" : "Failed"; 428 $self->_print_diag("\n") if $ENV{HARNESS_ACTIVE}; 429 $self->diag(" $msg test ($file at line $line)\n"); 430 } 431 432 return $test ? 1 : 0; 433} 434 435 436sub _unoverload { 437 my $self = shift; 438 439 local($@,$!); 440 441 eval { require overload } || return; 442 443 foreach my $thing (@_) { 444 eval { 445 if( defined $$thing ) { 446 if( my $string_meth = overload::Method($$thing, '""') ) { 447 $$thing = $$thing->$string_meth(); 448 } 449 } 450 }; 451 } 452} 453 454 455=item B<is_eq> 456 457 $Test->is_eq($got, $expected, $name); 458 459Like Test::More's is(). Checks if $got eq $expected. This is the 460string version. 461 462=item B<is_num> 463 464 $Test->is_num($got, $expected, $name); 465 466Like Test::More's is(). Checks if $got == $expected. This is the 467numeric version. 468 469=cut 470 471sub is_eq { 472 my($self, $got, $expect, $name) = @_; 473 local $Level = $Level + 1; 474 475 if( !defined $got || !defined $expect ) { 476 # undef only matches undef and nothing else 477 my $test = !defined $got && !defined $expect; 478 479 $self->ok($test, $name); 480 $self->_is_diag($got, 'eq', $expect) unless $test; 481 return $test; 482 } 483 484 return $self->cmp_ok($got, 'eq', $expect, $name); 485} 486 487sub is_num { 488 my($self, $got, $expect, $name) = @_; 489 local $Level = $Level + 1; 490 491 if( !defined $got || !defined $expect ) { 492 # undef only matches undef and nothing else 493 my $test = !defined $got && !defined $expect; 494 495 $self->ok($test, $name); 496 $self->_is_diag($got, '==', $expect) unless $test; 497 return $test; 498 } 499 500 return $self->cmp_ok($got, '==', $expect, $name); 501} 502 503sub _is_diag { 504 my($self, $got, $type, $expect) = @_; 505 506 foreach my $val (\$got, \$expect) { 507 if( defined $$val ) { 508 if( $type eq 'eq' ) { 509 # quote and force string context 510 $$val = "'$$val'" 511 } 512 else { 513 # force numeric context 514 $$val = $$val+0; 515 } 516 } 517 else { 518 $$val = 'undef'; 519 } 520 } 521 522 return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect); 523 got: %s 524 expected: %s 525DIAGNOSTIC 526 527} 528 529=item B<isnt_eq> 530 531 $Test->isnt_eq($got, $dont_expect, $name); 532 533Like Test::More's isnt(). Checks if $got ne $dont_expect. This is 534the string version. 535 536=item B<isnt_num> 537 538 $Test->is_num($got, $dont_expect, $name); 539 540Like Test::More's isnt(). Checks if $got ne $dont_expect. This is 541the numeric version. 542 543=cut 544 545sub isnt_eq { 546 my($self, $got, $dont_expect, $name) = @_; 547 local $Level = $Level + 1; 548 549 if( !defined $got || !defined $dont_expect ) { 550 # undef only matches undef and nothing else 551 my $test = defined $got || defined $dont_expect; 552 553 $self->ok($test, $name); 554 $self->_cmp_diag($got, 'ne', $dont_expect) unless $test; 555 return $test; 556 } 557 558 return $self->cmp_ok($got, 'ne', $dont_expect, $name); 559} 560 561sub isnt_num { 562 my($self, $got, $dont_expect, $name) = @_; 563 local $Level = $Level + 1; 564 565 if( !defined $got || !defined $dont_expect ) { 566 # undef only matches undef and nothing else 567 my $test = defined $got || defined $dont_expect; 568 569 $self->ok($test, $name); 570 $self->_cmp_diag($got, '!=', $dont_expect) unless $test; 571 return $test; 572 } 573 574 return $self->cmp_ok($got, '!=', $dont_expect, $name); 575} 576 577 578=item B<like> 579 580 $Test->like($this, qr/$regex/, $name); 581 $Test->like($this, '/$regex/', $name); 582 583Like Test::More's like(). Checks if $this matches the given $regex. 584 585You'll want to avoid qr// if you want your tests to work before 5.005. 586 587=item B<unlike> 588 589 $Test->unlike($this, qr/$regex/, $name); 590 $Test->unlike($this, '/$regex/', $name); 591 592Like Test::More's unlike(). Checks if $this B<does not match> the 593given $regex. 594 595=cut 596 597sub like { 598 my($self, $this, $regex, $name) = @_; 599 600 local $Level = $Level + 1; 601 $self->_regex_ok($this, $regex, '=~', $name); 602} 603 604sub unlike { 605 my($self, $this, $regex, $name) = @_; 606 607 local $Level = $Level + 1; 608 $self->_regex_ok($this, $regex, '!~', $name); 609} 610 611=item B<maybe_regex> 612 613 $Test->maybe_regex(qr/$regex/); 614 $Test->maybe_regex('/$regex/'); 615 616Convenience method for building testing functions that take regular 617expressions as arguments, but need to work before perl 5.005. 618 619Takes a quoted regular expression produced by qr//, or a string 620representing a regular expression. 621 622Returns a Perl value which may be used instead of the corresponding 623regular expression, or undef if it's argument is not recognised. 624 625For example, a version of like(), sans the useful diagnostic messages, 626could be written as: 627 628 sub laconic_like { 629 my ($self, $this, $regex, $name) = @_; 630 my $usable_regex = $self->maybe_regex($regex); 631 die "expecting regex, found '$regex'\n" 632 unless $usable_regex; 633 $self->ok($this =~ m/$usable_regex/, $name); 634 } 635 636=cut 637 638 639sub maybe_regex { 640 my ($self, $regex) = @_; 641 my $usable_regex = undef; 642 643 return $usable_regex unless defined $regex; 644 645 my($re, $opts); 646 647 # Check for qr/foo/ 648 if( ref $regex eq 'Regexp' ) { 649 $usable_regex = $regex; 650 } 651 # Check for '/foo/' or 'm,foo,' 652 elsif( ($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or 653 (undef, $re, $opts) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx 654 ) 655 { 656 $usable_regex = length $opts ? "(?$opts)$re" : $re; 657 } 658 659 return $usable_regex; 660}; 661 662sub _regex_ok { 663 my($self, $this, $regex, $cmp, $name) = @_; 664 665 local $Level = $Level + 1; 666 667 my $ok = 0; 668 my $usable_regex = $self->maybe_regex($regex); 669 unless (defined $usable_regex) { 670 $ok = $self->ok( 0, $name ); 671 $self->diag(" '$regex' doesn't look much like a regex to me."); 672 return $ok; 673 } 674 675 { 676 local $^W = 0; 677 my $test = $this =~ /$usable_regex/ ? 1 : 0; 678 $test = !$test if $cmp eq '!~'; 679 $ok = $self->ok( $test, $name ); 680 } 681 682 unless( $ok ) { 683 $this = defined $this ? "'$this'" : 'undef'; 684 my $match = $cmp eq '=~' ? "doesn't match" : "matches"; 685 $self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex); 686 %s 687 %13s '%s' 688DIAGNOSTIC 689 690 } 691 692 return $ok; 693} 694 695=item B<cmp_ok> 696 697 $Test->cmp_ok($this, $type, $that, $name); 698 699Works just like Test::More's cmp_ok(). 700 701 $Test->cmp_ok($big_num, '!=', $other_big_num); 702 703=cut 704 705sub cmp_ok { 706 my($self, $got, $type, $expect, $name) = @_; 707 708 my $test; 709 { 710 local $^W = 0; 711 local($@,$!); # don't interfere with $@ 712 # eval() sometimes resets $! 713 $test = eval "\$got $type \$expect"; 714 } 715 local $Level = $Level + 1; 716 my $ok = $self->ok($test, $name); 717 718 unless( $ok ) { 719 if( $type =~ /^(eq|==)$/ ) { 720 $self->_is_diag($got, $type, $expect); 721 } 722 else { 723 $self->_cmp_diag($got, $type, $expect); 724 } 725 } 726 return $ok; 727} 728 729sub _cmp_diag { 730 my($self, $got, $type, $expect) = @_; 731 732 $got = defined $got ? "'$got'" : 'undef'; 733 $expect = defined $expect ? "'$expect'" : 'undef'; 734 return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect); 735 %s 736 %s 737 %s 738DIAGNOSTIC 739} 740 741=item B<BAILOUT> 742 743 $Test->BAILOUT($reason); 744 745Indicates to the Test::Harness that things are going so badly all 746testing should terminate. This includes running any additional test 747scripts. 748 749It will exit with 255. 750 751=cut 752 753sub BAILOUT { 754 my($self, $reason) = @_; 755 756 $self->_print("Bail out! $reason"); 757 exit 255; 758} 759 760=item B<skip> 761 762 $Test->skip; 763 $Test->skip($why); 764 765Skips the current test, reporting $why. 766 767=cut 768 769sub skip { 770 my($self, $why) = @_; 771 $why ||= ''; 772 $self->_unoverload(\$why); 773 774 unless( $Have_Plan ) { 775 require Carp; 776 Carp::croak("You tried to run tests without a plan! Gotta have a plan."); 777 } 778 779 lock($Curr_Test); 780 $Curr_Test++; 781 782 $Test_Results[$Curr_Test-1] = &share({ 783 'ok' => 1, 784 actual_ok => 1, 785 name => '', 786 type => 'skip', 787 reason => $why, 788 }); 789 790 my $out = "ok"; 791 $out .= " $Curr_Test" if $self->use_numbers; 792 $out .= " # skip"; 793 $out .= " $why" if length $why; 794 $out .= "\n"; 795 796 $Test->_print($out); 797 798 return 1; 799} 800 801 802=item B<todo_skip> 803 804 $Test->todo_skip; 805 $Test->todo_skip($why); 806 807Like skip(), only it will declare the test as failing and TODO. Similar 808to 809 810 print "not ok $tnum # TODO $why\n"; 811 812=cut 813 814sub todo_skip { 815 my($self, $why) = @_; 816 $why ||= ''; 817 818 unless( $Have_Plan ) { 819 require Carp; 820 Carp::croak("You tried to run tests without a plan! Gotta have a plan."); 821 } 822 823 lock($Curr_Test); 824 $Curr_Test++; 825 826 $Test_Results[$Curr_Test-1] = &share({ 827 'ok' => 1, 828 actual_ok => 0, 829 name => '', 830 type => 'todo_skip', 831 reason => $why, 832 }); 833 834 my $out = "not ok"; 835 $out .= " $Curr_Test" if $self->use_numbers; 836 $out .= " # TODO & SKIP $why\n"; 837 838 $Test->_print($out); 839 840 return 1; 841} 842 843 844=begin _unimplemented 845 846=item B<skip_rest> 847 848 $Test->skip_rest; 849 $Test->skip_rest($reason); 850 851Like skip(), only it skips all the rest of the tests you plan to run 852and terminates the test. 853 854If you're running under no_plan, it skips once and terminates the 855test. 856 857=end _unimplemented 858 859=back 860 861 862=head2 Test style 863 864=over 4 865 866=item B<level> 867 868 $Test->level($how_high); 869 870How far up the call stack should $Test look when reporting where the 871test failed. 872 873Defaults to 1. 874 875Setting $Test::Builder::Level overrides. This is typically useful 876localized: 877 878 { 879 local $Test::Builder::Level = 2; 880 $Test->ok($test); 881 } 882 883=cut 884 885sub level { 886 my($self, $level) = @_; 887 888 if( defined $level ) { 889 $Level = $level; 890 } 891 return $Level; 892} 893 894 895=item B<use_numbers> 896 897 $Test->use_numbers($on_or_off); 898 899Whether or not the test should output numbers. That is, this if true: 900 901 ok 1 902 ok 2 903 ok 3 904 905or this if false 906 907 ok 908 ok 909 ok 910 911Most useful when you can't depend on the test output order, such as 912when threads or forking is involved. 913 914Test::Harness will accept either, but avoid mixing the two styles. 915 916Defaults to on. 917 918=cut 919 920sub use_numbers { 921 my($self, $use_nums) = @_; 922 923 if( defined $use_nums ) { 924 $Use_Nums = $use_nums; 925 } 926 return $Use_Nums; 927} 928 929=item B<no_header> 930 931 $Test->no_header($no_header); 932 933If set to true, no "1..N" header will be printed. 934 935=item B<no_ending> 936 937 $Test->no_ending($no_ending); 938 939Normally, Test::Builder does some extra diagnostics when the test 940ends. It also changes the exit code as described below. 941 942If this is true, none of that will be done. 943 944=cut 945 946sub no_header { 947 my($self, $no_header) = @_; 948 949 if( defined $no_header ) { 950 $No_Header = $no_header; 951 } 952 return $No_Header; 953} 954 955sub no_ending { 956 my($self, $no_ending) = @_; 957 958 if( defined $no_ending ) { 959 $No_Ending = $no_ending; 960 } 961 return $No_Ending; 962} 963 964 965=back 966 967=head2 Output 968 969Controlling where the test output goes. 970 971It's ok for your test to change where STDOUT and STDERR point to, 972Test::Builder's default output settings will not be affected. 973 974=over 4 975 976=item B<diag> 977 978 $Test->diag(@msgs); 979 980Prints out the given @msgs. Like C<print>, arguments are simply 981appended together. 982 983Normally, it uses the failure_output() handle, but if this is for a 984TODO test, the todo_output() handle is used. 985 986Output will be indented and marked with a # so as not to interfere 987with test output. A newline will be put on the end if there isn't one 988already. 989 990We encourage using this rather than calling print directly. 991 992Returns false. Why? Because diag() is often used in conjunction with 993a failing test (C<ok() || diag()>) it "passes through" the failure. 994 995 return ok(...) || diag(...); 996 997=for blame transfer 998Mark Fowler <mark@twoshortplanks.com> 999 1000=cut 1001 1002sub diag { 1003 my($self, @msgs) = @_; 1004 return unless @msgs; 1005 1006 # Prevent printing headers when compiling (i.e. -c) 1007 return if $^C; 1008 1009 # Smash args together like print does. 1010 # Convert undef to 'undef' so its readable. 1011 my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs; 1012 1013 # Escape each line with a #. 1014 $msg =~ s/^/# /gm; 1015 1016 # Stick a newline on the end if it needs it. 1017 $msg .= "\n" unless $msg =~ /\n\Z/; 1018 1019 local $Level = $Level + 1; 1020 $self->_print_diag($msg); 1021 1022 return 0; 1023} 1024 1025=begin _private 1026 1027=item B<_print> 1028 1029 $Test->_print(@msgs); 1030 1031Prints to the output() filehandle. 1032 1033=end _private 1034 1035=cut 1036 1037sub _print { 1038 my($self, @msgs) = @_; 1039 1040 # Prevent printing headers when only compiling. Mostly for when 1041 # tests are deparsed with B::Deparse 1042 return if $^C; 1043 1044 my $msg = join '', @msgs; 1045 1046 local($\, $", $,) = (undef, ' ', ''); 1047 my $fh = $self->output; 1048 1049 # Escape each line after the first with a # so we don't 1050 # confuse Test::Harness. 1051 $msg =~ s/\n(.)/\n# $1/sg; 1052 1053 # Stick a newline on the end if it needs it. 1054 $msg .= "\n" unless $msg =~ /\n\Z/; 1055 1056 print $fh $msg; 1057} 1058 1059 1060=item B<_print_diag> 1061 1062 $Test->_print_diag(@msg); 1063 1064Like _print, but prints to the current diagnostic filehandle. 1065 1066=cut 1067 1068sub _print_diag { 1069 my $self = shift; 1070 1071 local($\, $", $,) = (undef, ' ', ''); 1072 my $fh = $self->todo ? $self->todo_output : $self->failure_output; 1073 print $fh @_; 1074} 1075 1076=item B<output> 1077 1078 $Test->output($fh); 1079 $Test->output($file); 1080 1081Where normal "ok/not ok" test output should go. 1082 1083Defaults to STDOUT. 1084 1085=item B<failure_output> 1086 1087 $Test->failure_output($fh); 1088 $Test->failure_output($file); 1089 1090Where diagnostic output on test failures and diag() should go. 1091 1092Defaults to STDERR. 1093 1094=item B<todo_output> 1095 1096 $Test->todo_output($fh); 1097 $Test->todo_output($file); 1098 1099Where diagnostics about todo test failures and diag() should go. 1100 1101Defaults to STDOUT. 1102 1103=cut 1104 1105my($Out_FH, $Fail_FH, $Todo_FH); 1106sub output { 1107 my($self, $fh) = @_; 1108 1109 if( defined $fh ) { 1110 $Out_FH = _new_fh($fh); 1111 } 1112 return $Out_FH; 1113} 1114 1115sub failure_output { 1116 my($self, $fh) = @_; 1117 1118 if( defined $fh ) { 1119 $Fail_FH = _new_fh($fh); 1120 } 1121 return $Fail_FH; 1122} 1123 1124sub todo_output { 1125 my($self, $fh) = @_; 1126 1127 if( defined $fh ) { 1128 $Todo_FH = _new_fh($fh); 1129 } 1130 return $Todo_FH; 1131} 1132 1133 1134sub _new_fh { 1135 my($file_or_fh) = shift; 1136 1137 my $fh; 1138 if( _is_fh($file_or_fh) ) { 1139 $fh = $file_or_fh; 1140 } 1141 else { 1142 $fh = do { local *FH }; 1143 open $fh, ">$file_or_fh" or 1144 die "Can't open test output log $file_or_fh: $!"; 1145 } 1146 1147 return $fh; 1148} 1149 1150 1151sub _is_fh { 1152 my $maybe_fh = shift; 1153 1154 return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob 1155 1156 return UNIVERSAL::isa($maybe_fh, 'GLOB') || 1157 UNIVERSAL::isa($maybe_fh, 'IO::Handle') || 1158 1159 # 5.5.4's tied() and can() doesn't like getting undef 1160 UNIVERSAL::can((tied($maybe_fh) || ''), 'TIEHANDLE'); 1161} 1162 1163 1164sub _autoflush { 1165 my($fh) = shift; 1166 my $old_fh = select $fh; 1167 $| = 1; 1168 select $old_fh; 1169} 1170 1171 1172my $Opened_Testhandles = 0; 1173sub _dup_stdhandles { 1174 my $self = shift; 1175 1176 $self->_open_testhandles unless $Opened_Testhandles; 1177 1178 # Set everything to unbuffered else plain prints to STDOUT will 1179 # come out in the wrong order from our own prints. 1180 _autoflush(\*TESTOUT); 1181 _autoflush(\*STDOUT); 1182 _autoflush(\*TESTERR); 1183 _autoflush(\*STDERR); 1184 1185 $Test->output(\*TESTOUT); 1186 $Test->failure_output(\*TESTERR); 1187 $Test->todo_output(\*TESTOUT); 1188} 1189 1190sub _open_testhandles { 1191 # We dup STDOUT and STDERR so people can change them in their 1192 # test suites while still getting normal test output. 1193 open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!"; 1194 open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!"; 1195 $Opened_Testhandles = 1; 1196} 1197 1198 1199=back 1200 1201 1202=head2 Test Status and Info 1203 1204=over 4 1205 1206=item B<current_test> 1207 1208 my $curr_test = $Test->current_test; 1209 $Test->current_test($num); 1210 1211Gets/sets the current test number we're on. You usually shouldn't 1212have to set this. 1213 1214If set forward, the details of the missing tests are filled in as 'unknown'. 1215if set backward, the details of the intervening tests are deleted. You 1216can erase history if you really want to. 1217 1218=cut 1219 1220sub current_test { 1221 my($self, $num) = @_; 1222 1223 lock($Curr_Test); 1224 if( defined $num ) { 1225 unless( $Have_Plan ) { 1226 require Carp; 1227 Carp::croak("Can't change the current test number without a plan!"); 1228 } 1229 1230 $Curr_Test = $num; 1231 1232 # If the test counter is being pushed forward fill in the details. 1233 if( $num > @Test_Results ) { 1234 my $start = @Test_Results ? $#Test_Results + 1 : 0; 1235 for ($start..$num-1) { 1236 $Test_Results[$_] = &share({ 1237 'ok' => 1, 1238 actual_ok => undef, 1239 reason => 'incrementing test number', 1240 type => 'unknown', 1241 name => undef 1242 }); 1243 } 1244 } 1245 # If backward, wipe history. Its their funeral. 1246 elsif( $num < @Test_Results ) { 1247 $#Test_Results = $num - 1; 1248 } 1249 } 1250 return $Curr_Test; 1251} 1252 1253 1254=item B<summary> 1255 1256 my @tests = $Test->summary; 1257 1258A simple summary of the tests so far. True for pass, false for fail. 1259This is a logical pass/fail, so todos are passes. 1260 1261Of course, test #1 is $tests[0], etc... 1262 1263=cut 1264 1265sub summary { 1266 my($self) = shift; 1267 1268 return map { $_->{'ok'} } @Test_Results; 1269} 1270 1271=item B<details> 1272 1273 my @tests = $Test->details; 1274 1275Like summary(), but with a lot more detail. 1276 1277 $tests[$test_num - 1] = 1278 { 'ok' => is the test considered a pass? 1279 actual_ok => did it literally say 'ok'? 1280 name => name of the test (if any) 1281 type => type of test (if any, see below). 1282 reason => reason for the above (if any) 1283 }; 1284 1285'ok' is true if Test::Harness will consider the test to be a pass. 1286 1287'actual_ok' is a reflection of whether or not the test literally 1288printed 'ok' or 'not ok'. This is for examining the result of 'todo' 1289tests. 1290 1291'name' is the name of the test. 1292 1293'type' indicates if it was a special test. Normal tests have a type 1294of ''. Type can be one of the following: 1295 1296 skip see skip() 1297 todo see todo() 1298 todo_skip see todo_skip() 1299 unknown see below 1300 1301Sometimes the Test::Builder test counter is incremented without it 1302printing any test output, for example, when current_test() is changed. 1303In these cases, Test::Builder doesn't know the result of the test, so 1304it's type is 'unkown'. These details for these tests are filled in. 1305They are considered ok, but the name and actual_ok is left undef. 1306 1307For example "not ok 23 - hole count # TODO insufficient donuts" would 1308result in this structure: 1309 1310 $tests[22] = # 23 - 1, since arrays start from 0. 1311 { ok => 1, # logically, the test passed since it's todo 1312 actual_ok => 0, # in absolute terms, it failed 1313 name => 'hole count', 1314 type => 'todo', 1315 reason => 'insufficient donuts' 1316 }; 1317 1318=cut 1319 1320sub details { 1321 return @Test_Results; 1322} 1323 1324=item B<todo> 1325 1326 my $todo_reason = $Test->todo; 1327 my $todo_reason = $Test->todo($pack); 1328 1329todo() looks for a $TODO variable in your tests. If set, all tests 1330will be considered 'todo' (see Test::More and Test::Harness for 1331details). Returns the reason (ie. the value of $TODO) if running as 1332todo tests, false otherwise. 1333 1334todo() is pretty part about finding the right package to look for 1335$TODO in. It uses the exported_to() package to find it. If that's 1336not set, it's pretty good at guessing the right package to look at. 1337 1338Sometimes there is some confusion about where todo() should be looking 1339for the $TODO variable. If you want to be sure, tell it explicitly 1340what $pack to use. 1341 1342=cut 1343 1344sub todo { 1345 my($self, $pack) = @_; 1346 1347 $pack = $pack || $self->exported_to || $self->caller(1); 1348 1349 no strict 'refs'; 1350 return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'} 1351 : 0; 1352} 1353 1354=item B<caller> 1355 1356 my $package = $Test->caller; 1357 my($pack, $file, $line) = $Test->caller; 1358 my($pack, $file, $line) = $Test->caller($height); 1359 1360Like the normal caller(), except it reports according to your level(). 1361 1362=cut 1363 1364sub caller { 1365 my($self, $height) = @_; 1366 $height ||= 0; 1367 1368 my @caller = CORE::caller($self->level + $height + 1); 1369 return wantarray ? @caller : $caller[0]; 1370} 1371 1372=back 1373 1374=cut 1375 1376=begin _private 1377 1378=over 4 1379 1380=item B<_sanity_check> 1381 1382 _sanity_check(); 1383 1384Runs a bunch of end of test sanity checks to make sure reality came 1385through ok. If anything is wrong it will die with a fairly friendly 1386error message. 1387 1388=cut 1389 1390#'# 1391sub _sanity_check { 1392 _whoa($Curr_Test < 0, 'Says here you ran a negative number of tests!'); 1393 _whoa(!$Have_Plan and $Curr_Test, 1394 'Somehow your tests ran without a plan!'); 1395 _whoa($Curr_Test != @Test_Results, 1396 'Somehow you got a different number of results than tests ran!'); 1397} 1398 1399=item B<_whoa> 1400 1401 _whoa($check, $description); 1402 1403A sanity check, similar to assert(). If the $check is true, something 1404has gone horribly wrong. It will die with the given $description and 1405a note to contact the author. 1406 1407=cut 1408 1409sub _whoa { 1410 my($check, $desc) = @_; 1411 if( $check ) { 1412 die <<WHOA; 1413WHOA! $desc 1414This should never happen! Please contact the author immediately! 1415WHOA 1416 } 1417} 1418 1419=item B<_my_exit> 1420 1421 _my_exit($exit_num); 1422 1423Perl seems to have some trouble with exiting inside an END block. 5.005_03 1424and 5.6.1 both seem to do odd things. Instead, this function edits $? 1425directly. It should ONLY be called from inside an END block. It 1426doesn't actually exit, that's your job. 1427 1428=cut 1429 1430sub _my_exit { 1431 $? = $_[0]; 1432 1433 return 1; 1434} 1435 1436 1437=back 1438 1439=end _private 1440 1441=cut 1442 1443$SIG{__DIE__} = sub { 1444 # We don't want to muck with death in an eval, but $^S isn't 1445 # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing 1446 # with it. Instead, we use caller. This also means it runs under 1447 # 5.004! 1448 my $in_eval = 0; 1449 for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) { 1450 $in_eval = 1 if $sub =~ /^\(eval\)/; 1451 } 1452 $Test_Died = 1 unless $in_eval; 1453}; 1454 1455sub _ending { 1456 my $self = shift; 1457 1458 _sanity_check(); 1459 1460 # Don't bother with an ending if this is a forked copy. Only the parent 1461 # should do the ending. 1462 do{ _my_exit($?) && return } if $Original_Pid != $$; 1463 1464 # Bailout if plan() was never called. This is so 1465 # "require Test::Simple" doesn't puke. 1466 do{ _my_exit(0) && return } if !$Have_Plan && !$Test_Died; 1467 1468 # Figure out if we passed or failed and print helpful messages. 1469 if( @Test_Results ) { 1470 # The plan? We have no plan. 1471 if( $No_Plan ) { 1472 $self->_print("1..$Curr_Test\n") unless $self->no_header; 1473 $Expected_Tests = $Curr_Test; 1474 } 1475 1476 # Auto-extended arrays and elements which aren't explicitly 1477 # filled in with a shared reference will puke under 5.8.0 1478 # ithreads. So we have to fill them in by hand. :( 1479 my $empty_result = &share({}); 1480 for my $idx ( 0..$Expected_Tests-1 ) { 1481 $Test_Results[$idx] = $empty_result 1482 unless defined $Test_Results[$idx]; 1483 } 1484 1485 my $num_failed = grep !$_->{'ok'}, @Test_Results[0..$Expected_Tests-1]; 1486 $num_failed += abs($Expected_Tests - @Test_Results); 1487 1488 if( $Curr_Test < $Expected_Tests ) { 1489 my $s = $Expected_Tests == 1 ? '' : 's'; 1490 $self->diag(<<"FAIL"); 1491Looks like you planned $Expected_Tests test$s but only ran $Curr_Test. 1492FAIL 1493 } 1494 elsif( $Curr_Test > $Expected_Tests ) { 1495 my $num_extra = $Curr_Test - $Expected_Tests; 1496 my $s = $Expected_Tests == 1 ? '' : 's'; 1497 $self->diag(<<"FAIL"); 1498Looks like you planned $Expected_Tests test$s but ran $num_extra extra. 1499FAIL 1500 } 1501 elsif ( $num_failed ) { 1502 my $s = $num_failed == 1 ? '' : 's'; 1503 $self->diag(<<"FAIL"); 1504Looks like you failed $num_failed test$s of $Expected_Tests. 1505FAIL 1506 } 1507 1508 if( $Test_Died ) { 1509 $self->diag(<<"FAIL"); 1510Looks like your test died just after $Curr_Test. 1511FAIL 1512 1513 _my_exit( 255 ) && return; 1514 } 1515 1516 _my_exit( $num_failed <= 254 ? $num_failed : 254 ) && return; 1517 } 1518 elsif ( $Skip_All ) { 1519 _my_exit( 0 ) && return; 1520 } 1521 elsif ( $Test_Died ) { 1522 $self->diag(<<'FAIL'); 1523Looks like your test died before it could output anything. 1524FAIL 1525 _my_exit( 255 ) && return; 1526 } 1527 else { 1528 $self->diag("No tests run!\n"); 1529 _my_exit( 255 ) && return; 1530 } 1531} 1532 1533END { 1534 $Test->_ending if defined $Test and !$Test->no_ending; 1535} 1536 1537=head1 EXIT CODES 1538 1539If all your tests passed, Test::Builder will exit with zero (which is 1540normal). If anything failed it will exit with how many failed. If 1541you run less (or more) tests than you planned, the missing (or extras) 1542will be considered failures. If no tests were ever run Test::Builder 1543will throw a warning and exit with 255. If the test died, even after 1544having successfully completed all its tests, it will still be 1545considered a failure and will exit with 255. 1546 1547So the exit codes are... 1548 1549 0 all tests successful 1550 255 test died 1551 any other number how many failed (including missing or extras) 1552 1553If you fail more than 254 tests, it will be reported as 254. 1554 1555 1556=head1 THREADS 1557 1558In perl 5.8.0 and later, Test::Builder is thread-safe. The test 1559number is shared amongst all threads. This means if one thread sets 1560the test number using current_test() they will all be effected. 1561 1562Test::Builder is only thread-aware if threads.pm is loaded I<before> 1563Test::Builder. 1564 1565=head1 EXAMPLES 1566 1567CPAN can provide the best examples. Test::Simple, Test::More, 1568Test::Exception and Test::Differences all use Test::Builder. 1569 1570=head1 SEE ALSO 1571 1572Test::Simple, Test::More, Test::Harness 1573 1574=head1 AUTHORS 1575 1576Original code by chromatic, maintained by Michael G Schwern 1577E<lt>schwern@pobox.comE<gt> 1578 1579=head1 COPYRIGHT 1580 1581Copyright 2002, 2004 by chromatic E<lt>chromatic@wgz.orgE<gt> and 1582 Michael G Schwern E<lt>schwern@pobox.comE<gt>. 1583 1584This program is free software; you can redistribute it and/or 1585modify it under the same terms as Perl itself. 1586 1587See F<http://www.perl.com/perl/misc/Artistic.html> 1588 1589=cut 1590 15911; 1592