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