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