lib/Test/Builder.pm

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