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.33_02';
  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     if( $self->{Have_Plan} ) {
 251         $self->croak("You tried to plan twice");
 252     }
 253
 254     if( $cmd eq 'no_plan' ) {
 255         $self->no_plan;
 256     }
 257     elsif( $cmd eq 'skip_all' ) {
 258         return $self->skip_all($arg);
 259     }
 260     elsif( $cmd eq 'tests' ) {
 261         if( $arg ) {
 262             local $Level = $Level + 1;
 263             return $self->expected_tests($arg);
 264         }
 265         elsif( !defined $arg ) {
 266             $self->croak("Got an undefined number of tests");
 267         }
 268         elsif( !$arg ) {
 269             $self->croak("You said to run 0 tests");
 270         }
 271     }
 272     else {
 273         my @args = grep { defined } ($cmd, $arg);
 274         $self->croak("plan() doesn't understand @args");
 275     }
 276
 277     return 1;
 278 }
 279
 280 =item B<expected_tests>
 281
 282     my $max = $Test->expected_tests;
 283     $Test->expected_tests($max);
 284
 285 Gets/sets the # of tests we expect this test to run and prints out
 286 the appropriate headers.
 287
 288 =cut
 289
 290 sub expected_tests {
 291     my $self = shift;
 292     my($max) = @_;
 293
 294     if( @_ ) {
 295         $self->croak("Number of tests must be a positive integer.  You gave it '$max'")
 296           unless $max =~ /^\+?\d+$/ and $max > 0;
 297
 298         $self->{Expected_Tests} = $max;
 299         $self->{Have_Plan}      = 1;
 300
 301         $self->_print("1..$max\n") unless $self->no_header;
 302     }
 303     return $self->{Expected_Tests};
 304 }
 305
 306
 307 =item B<no_plan>
 308
 309   $Test->no_plan;
 310
 311 Declares that this test will run an indeterminate # of tests.
 312
 313 =cut
 314
 315 sub no_plan {
 316     my $self = shift;
 317
 318     $self->{No_Plan}   = 1;
 319     $self->{Have_Plan} = 1;
 320 }
 321
 322 =item B<has_plan>
 323
 324   $plan = $Test->has_plan
 325
 326 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).
 327
 328 =cut
 329
 330 sub has_plan {
 331     my $self = shift;
 332
 333     return($self->{Expected_Tests}) if $self->{Expected_Tests};
 334     return('no_plan') if $self->{No_Plan};
 335     return(undef);
 336 };
 337
 338
 339 =item B<skip_all>
 340
 341   $Test->skip_all;
 342   $Test->skip_all($reason);
 343
 344 Skips all the tests, using the given $reason.  Exits immediately with 0.
 345
 346 =cut
 347
 348 sub skip_all {
 349     my($self, $reason) = @_;
 350
 351     my $out = "1..0";
 352     $out .= " # Skip $reason" if $reason;
 353     $out .= "\n";
 354
 355     $self->{Skip_All} = 1;
 356
 357     $self->_print($out) unless $self->no_header;
 358     exit(0);
 359 }
 360
 361 =back
 362
 363 =head2 Running tests
 364
 365 These actually run the tests, analogous to the functions in
 366 Test::More.
 367
 368 $name is always optional.
 369
 370 =over 4
 371
 372 =item B<ok>
 373
 374   $Test->ok($test, $name);
 375
 376 Your basic test.  Pass if $test is true, fail if $test is false.  Just
 377 like Test::Simple's ok().
 378
 379 =cut
 380
 381 sub ok {
 382     my($self, $test, $name) = @_;
 383
 384     # $test might contain an object which we don't want to accidentally
 385     # store, so we turn it into a boolean.
 386     $test = $test ? 1 : 0;
 387
 388     $self->_plan_check;
 389
 390     lock $self->{Curr_Test};
 391     $self->{Curr_Test}++;
 392
 393     # In case $name is a string overloaded object, force it to stringify.
 394     $self->_unoverload_str(\$name);
 395
 396     $self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/;
 397     You named your test '$name'.  You shouldn't use numbers for your test names.
 398     Very confusing.
 399 ERR
 400
 401     my($pack, $file, $line) = $self->caller;
 402
 403     my $todo = $self->todo($pack);
 404     $self->_unoverload_str(\$todo);
 405
 406     my $out;
 407     my $result = &share({});
 408
 409     unless( $test ) {
 410         $out .= "not ";
 411         @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
 412     }
 413     else {
 414         @$result{ 'ok', 'actual_ok' } = ( 1, $test );
 415     }
 416
 417     $out .= "ok";
 418     $out .= " $self->{Curr_Test}" if $self->use_numbers;
 419
 420     if( defined $name ) {
 421         $name =~ s|#|\\#|g;     # # in a name can confuse Test::Harness.
 422         $out   .= " - $name";
 423         $result->{name} = $name;
 424     }
 425     else {
 426         $result->{name} = '';
 427     }
 428
 429     if( $todo ) {
 430         $out   .= " # TODO $todo";
 431         $result->{reason} = $todo;
 432         $result->{type}   = 'todo';
 433     }
 434     else {
 435         $result->{reason} = '';
 436         $result->{type}   = '';
 437     }
 438
 439     $self->{Test_Results}[$self->{Curr_Test}-1] = $result;
 440     $out .= "\n";
 441
 442     $self->_print($out);
 443
 444     unless( $test ) {
 445         my $msg = $todo ? "Failed (TODO)" : "Failed";
 446         $self->_print_diag("\n") if $ENV{HARNESS_ACTIVE};
 447
 448         if( defined $name ) {
 449             $self->diag(qq[  $msg test '$name'\n]);
 450             $self->diag(qq[  at $file line $line.\n]);
 451         }
 452         else {
 453             $self->diag(qq[  $msg test at $file line $line.\n]);
 454         }
 455     }
 456
 457     return $test ? 1 : 0;
 458 }
 459
 460
 461 sub _unoverload {
 462     my $self  = shift;
 463     my $type  = shift;
 464
 465     local($@,$!);
 466
 467     eval { require overload } || return;
 468
 469     foreach my $thing (@_) {
 470         eval {
 471             if( _is_object($$thing) ) {
 472                 if( my $string_meth = overload::Method($$thing, $type) ) {
 473                     $$thing = $$thing->$string_meth();
 474                 }
 475             }
 476         };
 477     }
 478 }
 479
 480
 481 sub _is_object {
 482     my $thing = shift;
 483
 484     return eval { ref $thing && $thing->isa('UNIVERSAL') } ? 1 : 0;
 485 }
 486
 487
 488 sub _unoverload_str {
 489     my $self = shift;
 490
 491     $self->_unoverload(q[""], @_);
 492 }
 493
 494 sub _unoverload_num {
 495     my $self = shift;
 496
 497     $self->_unoverload('0+', @_);
 498
 499     for my $val (@_) {
 500         next unless $self->_is_dualvar($$val);
 501         $$val = $$val+0;
 502     }
 503 }
 504
 505
 506 # This is a hack to detect a dualvar such as $!
 507 sub _is_dualvar {
 508     my($self, $val) = @_;
 509
 510     local $^W = 0;
 511     my $numval = $val+0;
 512     return 1 if $numval != 0 and $numval ne $val;
 513 }
 514
 515
 516
 517 =item B<is_eq>
 518
 519   $Test->is_eq($got, $expected, $name);
 520
 521 Like Test::More's is().  Checks if $got eq $expected.  This is the
 522 string version.
 523
 524 =item B<is_num>
 525
 526   $Test->is_num($got, $expected, $name);
 527
 528 Like Test::More's is().  Checks if $got == $expected.  This is the
 529 numeric version.
 530
 531 =cut
 532
 533 sub is_eq {
 534     my($self, $got, $expect, $name) = @_;
 535     local $Level = $Level + 1;
 536
 537     $self->_unoverload_str(\$got, \$expect);
 538
 539     if( !defined $got || !defined $expect ) {
 540         # undef only matches undef and nothing else
 541         my $test = !defined $got && !defined $expect;
 542
 543         $self->ok($test, $name);
 544         $self->_is_diag($got, 'eq', $expect) unless $test;
 545         return $test;
 546     }
 547
 548     return $self->cmp_ok($got, 'eq', $expect, $name);
 549 }
 550
 551 sub is_num {
 552     my($self, $got, $expect, $name) = @_;
 553     local $Level = $Level + 1;
 554
 555     $self->_unoverload_num(\$got, \$expect);
 556
 557     if( !defined $got || !defined $expect ) {
 558         # undef only matches undef and nothing else
 559         my $test = !defined $got && !defined $expect;
 560
 561         $self->ok($test, $name);
 562         $self->_is_diag($got, '==', $expect) unless $test;
 563         return $test;
 564     }
 565
 566     return $self->cmp_ok($got, '==', $expect, $name);
 567 }
 568
 569 sub _is_diag {
 570     my($self, $got, $type, $expect) = @_;
 571
 572     foreach my $val (\$got, \$expect) {
 573         if( defined $$val ) {
 574             if( $type eq 'eq' ) {
 575                 # quote and force string context
 576                 $$val = "'$$val'"
 577             }
 578             else {
 579                 # force numeric context
 580                 $self->_unoverload_num($val);
 581             }
 582         }
 583         else {
 584             $$val = 'undef';
 585         }
 586     }
 587
 588     return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
 589          got: %s
 590     expected: %s
 591 DIAGNOSTIC
 592
 593 }
 594
 595 =item B<isnt_eq>
 596
 597   $Test->isnt_eq($got, $dont_expect, $name);
 598
 599 Like Test::More's isnt().  Checks if $got ne $dont_expect.  This is
 600 the string version.
 601
 602 =item B<isnt_num>
 603
 604   $Test->isnt_num($got, $dont_expect, $name);
 605
 606 Like Test::More's isnt().  Checks if $got ne $dont_expect.  This is
 607 the numeric version.
 608
 609 =cut
 610
 611 sub isnt_eq {
 612     my($self, $got, $dont_expect, $name) = @_;
 613     local $Level = $Level + 1;
 614
 615     if( !defined $got || !defined $dont_expect ) {
 616         # undef only matches undef and nothing else
 617         my $test = defined $got || defined $dont_expect;
 618
 619         $self->ok($test, $name);
 620         $self->_cmp_diag($got, 'ne', $dont_expect) unless $test;
 621         return $test;
 622     }
 623
 624     return $self->cmp_ok($got, 'ne', $dont_expect, $name);
 625 }
 626
 627 sub isnt_num {
 628     my($self, $got, $dont_expect, $name) = @_;
 629     local $Level = $Level + 1;
 630
 631     if( !defined $got || !defined $dont_expect ) {
 632         # undef only matches undef and nothing else
 633         my $test = defined $got || defined $dont_expect;
 634
 635         $self->ok($test, $name);
 636         $self->_cmp_diag($got, '!=', $dont_expect) unless $test;
 637         return $test;
 638     }
 639
 640     return $self->cmp_ok($got, '!=', $dont_expect, $name);
 641 }
 642
 643
 644 =item B<like>
 645
 646   $Test->like($this, qr/$regex/, $name);
 647   $Test->like($this, '/$regex/', $name);
 648
 649 Like Test::More's like().  Checks if $this matches the given $regex.
 650
 651 You'll want to avoid qr// if you want your tests to work before 5.005.
 652
 653 =item B<unlike>
 654
 655   $Test->unlike($this, qr/$regex/, $name);
 656   $Test->unlike($this, '/$regex/', $name);
 657
 658 Like Test::More's unlike().  Checks if $this B<does not match> the
 659 given $regex.
 660
 661 =cut
 662
 663 sub like {
 664     my($self, $this, $regex, $name) = @_;
 665
 666     local $Level = $Level + 1;
 667     $self->_regex_ok($this, $regex, '=~', $name);
 668 }
 669
 670 sub unlike {
 671     my($self, $this, $regex, $name) = @_;
 672
 673     local $Level = $Level + 1;
 674     $self->_regex_ok($this, $regex, '!~', $name);
 675 }
 676
 677 =item B<maybe_regex>
 678
 679   $Test->maybe_regex(qr/$regex/);
 680   $Test->maybe_regex('/$regex/');
 681
 682 Convenience method for building testing functions that take regular
 683 expressions as arguments, but need to work before perl 5.005.
 684
 685 Takes a quoted regular expression produced by qr//, or a string
 686 representing a regular expression.
 687
 688 Returns a Perl value which may be used instead of the corresponding
 689 regular expression, or undef if it's argument is not recognised.
 690
 691 For example, a version of like(), sans the useful diagnostic messages,
 692 could be written as:
 693
 694   sub laconic_like {
 695       my ($self, $this, $regex, $name) = @_;
 696       my $usable_regex = $self->maybe_regex($regex);
 697       die "expecting regex, found '$regex'\n"
 698           unless $usable_regex;
 699       $self->ok($this =~ m/$usable_regex/, $name);
 700   }
 701
 702 =cut
 703
 704
 705 sub maybe_regex {
 706     my ($self, $regex) = @_;
 707     my $usable_regex = undef;
 708
 709     return $usable_regex unless defined $regex;
 710
 711     my($re, $opts);
 712
 713     # Check for qr/foo/
 714     if( ref $regex eq 'Regexp' ) {
 715         $usable_regex = $regex;
 716     }
 717     # Check for '/foo/' or 'm,foo,'
 718     elsif( ($re, $opts)        = $regex =~ m{^ /(.*)/ (\w*) $ }sx           or
 719            (undef, $re, $opts) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
 720          )
 721     {
 722         $usable_regex = length $opts ? "(?$opts)$re" : $re;
 723     }
 724
 725     return $usable_regex;
 726 };
 727
 728 sub _regex_ok {
 729     my($self, $this, $regex, $cmp, $name) = @_;
 730
 731     my $ok = 0;
 732     my $usable_regex = $self->maybe_regex($regex);
 733     unless (defined $usable_regex) {
 734         $ok = $self->ok( 0, $name );
 735         $self->diag("    '$regex' doesn't look much like a regex to me.");
 736         return $ok;
 737     }
 738
 739     {
 740         my $test;
 741         my $code = $self->_caller_context;
 742
 743         local($@, $!);
 744
 745         # Yes, it has to look like this or 5.4.5 won't see the #line directive.
 746         # Don't ask me, man, I just work here.
 747         $test = eval "
 748 $code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
 749
 750         $test = !$test if $cmp eq '!~';
 751
 752         local $Level = $Level + 1;
 753         $ok = $self->ok( $test, $name );
 754     }
 755
 756     unless( $ok ) {
 757         $this = defined $this ? "'$this'" : 'undef';
 758         my $match = $cmp eq '=~' ? "doesn't match" : "matches";
 759         $self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
 760                   %s
 761     %13s '%s'
 762 DIAGNOSTIC
 763
 764     }
 765
 766     return $ok;
 767 }
 768
 769 =item B<cmp_ok>
 770
 771   $Test->cmp_ok($this, $type, $that, $name);
 772
 773 Works just like Test::More's cmp_ok().
 774
 775     $Test->cmp_ok($big_num, '!=', $other_big_num);
 776
 777 =cut
 778
 779
 780 my %numeric_cmps = map { ($_, 1) }
 781                        ("<",  "<=", ">",  ">=", "==", "!=", "<=>");
 782
 783 sub cmp_ok {
 784     my($self, $got, $type, $expect, $name) = @_;
 785
 786     # Treat overloaded objects as numbers if we're asked to do a
 787     # numeric comparison.
 788     my $unoverload = $numeric_cmps{$type} ? '_unoverload_num'
 789                                           : '_unoverload_str';
 790
 791     $self->$unoverload(\$got, \$expect);
 792
 793
 794     my $test;
 795     {
 796         local($@,$!);   # don't interfere with $@
 797                         # eval() sometimes resets $!
 798
 799         my $code = $self->_caller_context;
 800
 801         # Yes, it has to look like this or 5.4.5 won't see the #line directive.
 802         # Don't ask me, man, I just work here.
 803         $test = eval "
 804 $code" . "\$got $type \$expect;";
 805
 806     }
 807     local $Level = $Level + 1;
 808     my $ok = $self->ok($test, $name);
 809
 810     unless( $ok ) {
 811         if( $type =~ /^(eq|==)$/ ) {
 812             $self->_is_diag($got, $type, $expect);
 813         }
 814         else {
 815             $self->_cmp_diag($got, $type, $expect);
 816         }
 817     }
 818     return $ok;
 819 }
 820
 821 sub _cmp_diag {
 822     my($self, $got, $type, $expect) = @_;
 823
 824     $got    = defined $got    ? "'$got'"    : 'undef';
 825     $expect = defined $expect ? "'$expect'" : 'undef';
 826     return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
 827     %s
 828         %s
 829     %s
 830 DIAGNOSTIC
 831 }
 832
 833
 834 sub _caller_context {
 835     my $self = shift;
 836
 837     my($pack, $file, $line) = $self->caller(1);
 838
 839     my $code = '';
 840     $code .= "#line $line $file\n" if defined $file and defined $line;
 841
 842     return $code;
 843 }
 844
 845
 846 =item B<BAIL_OUT>
 847
 848     $Test->BAIL_OUT($reason);
 849
 850 Indicates to the Test::Harness that things are going so badly all
 851 testing should terminate.  This includes running any additional test
 852 scripts.
 853
 854 It will exit with 255.
 855
 856 =cut
 857
 858 sub BAIL_OUT {
 859     my($self, $reason) = @_;
 860
 861     $self->{Bailed_Out} = 1;
 862     $self->_print("Bail out!  $reason");
 863     exit 255;
 864 }
 865
 866 =for deprecated
 867 BAIL_OUT() used to be BAILOUT()
 868
 869 =cut
 870
 871 *BAILOUT = \&BAIL_OUT;
 872
 873
 874 =item B<skip>
 875
 876     $Test->skip;
 877     $Test->skip($why);
 878
 879 Skips the current test, reporting $why.
 880
 881 =cut
 882
 883 sub skip {
 884     my($self, $why) = @_;
 885     $why ||= '';
 886     $self->_unoverload_str(\$why);
 887
 888     $self->_plan_check;
 889
 890     lock($self->{Curr_Test});
 891     $self->{Curr_Test}++;
 892
 893     $self->{Test_Results}[$self->{Curr_Test}-1] = &share({
 894         'ok'      => 1,
 895         actual_ok => 1,
 896         name      => '',
 897         type      => 'skip',
 898         reason    => $why,
 899     });
 900
 901     my $out = "ok";
 902     $out   .= " $self->{Curr_Test}" if $self->use_numbers;
 903     $out   .= " # skip";
 904     $out   .= " $why"       if length $why;
 905     $out   .= "\n";
 906
 907     $self->_print($out);
 908
 909     return 1;
 910 }
 911
 912
 913 =item B<todo_skip>
 914
 915   $Test->todo_skip;
 916   $Test->todo_skip($why);
 917
 918 Like skip(), only it will declare the test as failing and TODO.  Similar
 919 to
 920
 921     print "not ok $tnum # TODO $why\n";
 922
 923 =cut
 924
 925 sub todo_skip {
 926     my($self, $why) = @_;
 927     $why ||= '';
 928
 929     $self->_plan_check;
 930
 931     lock($self->{Curr_Test});
 932     $self->{Curr_Test}++;
 933
 934     $self->{Test_Results}[$self->{Curr_Test}-1] = &share({
 935         'ok'      => 1,
 936         actual_ok => 0,
 937         name      => '',
 938         type      => 'todo_skip',
 939         reason    => $why,
 940     });
 941
 942     my $out = "not ok";
 943     $out   .= " $self->{Curr_Test}" if $self->use_numbers;
 944     $out   .= " # TODO & SKIP $why\n";
 945
 946     $self->_print($out);
 947
 948     return 1;
 949 }
 950
 951
 952 =begin _unimplemented
 953
 954 =item B<skip_rest>
 955
 956   $Test->skip_rest;
 957   $Test->skip_rest($reason);
 958
 959 Like skip(), only it skips all the rest of the tests you plan to run
 960 and terminates the test.
 961
 962 If you're running under no_plan, it skips once and terminates the
 963 test.
 964
 965 =end _unimplemented
 966
 967 =back
 968
 969
 970 =head2 Test style
 971
 972 =over 4
 973
 974 =item B<level>
 975
 976     $Test->level($how_high);
 977
 978 How far up the call stack should $Test look when reporting where the
 979 test failed.
 980
 981 Defaults to 1.
 982
 983 Setting $Test::Builder::Level overrides.  This is typically useful
 984 localized:
 985
 986     {
 987         local $Test::Builder::Level = 2;
 988         $Test->ok($test);
 989     }
 990
 991 =cut
 992
 993 sub level {
 994     my($self, $level) = @_;
 995
 996     if( defined $level ) {
 997         $Level = $level;
 998     }
 999     return $Level;
1000 }
1001
1002
1003 =item B<use_numbers>
1004
1005     $Test->use_numbers($on_or_off);
1006
1007 Whether or not the test should output numbers.  That is, this if true:
1008
1009   ok 1
1010   ok 2
1011   ok 3
1012
1013 or this if false
1014
1015   ok
1016   ok
1017   ok
1018
1019 Most useful when you can't depend on the test output order, such as
1020 when threads or forking is involved.
1021
1022 Test::Harness will accept either, but avoid mixing the two styles.
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 + 2;
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 + 1;
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;