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