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