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.32';
  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 =cut
 874
 875 *BAILOUT = \&BAIL_OUT;
 876
 877
 878 =item B<skip>
 879
 880     $Test->skip;
 881     $Test->skip($why);
 882
 883 Skips the current test, reporting $why.
 884
 885 =cut
 886
 887 sub skip {
 888     my($self, $why) = @_;
 889     $why ||= '';
 890     $self->_unoverload_str(\$why);
 891
 892     unless( $self->{Have_Plan} ) {
 893         require Carp;
 894         Carp::croak("You tried to run tests without a plan!  Gotta have a plan.");
 895     }
 896
 897     lock($self->{Curr_Test});
 898     $self->{Curr_Test}++;
 899
 900     $self->{Test_Results}[$self->{Curr_Test}-1] = &share({
 901         'ok'      => 1,
 902         actual_ok => 1,
 903         name      => '',
 904         type      => 'skip',
 905         reason    => $why,
 906     });
 907
 908     my $out = "ok";
 909     $out   .= " $self->{Curr_Test}" if $self->use_numbers;
 910     $out   .= " # skip";
 911     $out   .= " $why"       if length $why;
 912     $out   .= "\n";
 913
 914     $self->_print($out);
 915
 916     return 1;
 917 }
 918
 919
 920 =item B<todo_skip>
 921
 922   $Test->todo_skip;
 923   $Test->todo_skip($why);
 924
 925 Like skip(), only it will declare the test as failing and TODO.  Similar
 926 to
 927
 928     print "not ok $tnum # TODO $why\n";
 929
 930 =cut
 931
 932 sub todo_skip {
 933     my($self, $why) = @_;
 934     $why ||= '';
 935
 936     unless( $self->{Have_Plan} ) {
 937         require Carp;
 938         Carp::croak("You tried to run tests without a plan!  Gotta have a plan.");
 939     }
 940
 941     lock($self->{Curr_Test});
 942     $self->{Curr_Test}++;
 943
 944     $self->{Test_Results}[$self->{Curr_Test}-1] = &share({
 945         'ok'      => 1,
 946         actual_ok => 0,
 947         name      => '',
 948         type      => 'todo_skip',
 949         reason    => $why,
 950     });
 951
 952     my $out = "not ok";
 953     $out   .= " $self->{Curr_Test}" if $self->use_numbers;
 954     $out   .= " # TODO & SKIP $why\n";
 955
 956     $self->_print($out);
 957
 958     return 1;
 959 }
 960
 961
 962 =begin _unimplemented
 963
 964 =item B<skip_rest>
 965
 966   $Test->skip_rest;
 967   $Test->skip_rest($reason);
 968
 969 Like skip(), only it skips all the rest of the tests you plan to run
 970 and terminates the test.
 971
 972 If you're running under no_plan, it skips once and terminates the
 973 test.
 974
 975 =end _unimplemented
 976
 977 =back
 978
 979
 980 =head2 Test style
 981
 982 =over 4
 983
 984 =item B<level>
 985
 986     $Test->level($how_high);
 987
 988 How far up the call stack should $Test look when reporting where the
 989 test failed.
 990
 991 Defaults to 1.
 992
 993 Setting $Test::Builder::Level overrides.  This is typically useful
 994 localized:
 995
 996     {
 997         local $Test::Builder::Level = 2;
 998         $Test->ok($test);
 999     }
1000
1001 =cut
1002
1003 sub level {
1004     my($self, $level) = @_;
1005
1006     if( defined $level ) {
1007         $Level = $level;
1008     }
1009     return $Level;
1010 }
1011
1012
1013 =item B<use_numbers>
1014
1015     $Test->use_numbers($on_or_off);
1016
1017 Whether or not the test should output numbers.  That is, this if true:
1018
1019   ok 1
1020   ok 2
1021   ok 3
1022
1023 or this if false
1024
1025   ok
1026   ok
1027   ok
1028
1029 Most useful when you can't depend on the test output order, such as
1030 when threads or forking is involved.
1031
1032 Test::Harness will accept either, but avoid mixing the two styles.
1033
1034 Defaults to on.
1035
1036 =cut
1037
1038 sub use_numbers {
1039     my($self, $use_nums) = @_;
1040
1041     if( defined $use_nums ) {
1042         $self->{Use_Nums} = $use_nums;
1043     }
1044     return $self->{Use_Nums};
1045 }
1046
1047
1048 =item B<no_diag>
1049
1050     $Test->no_diag($no_diag);
1051
1052 If set true no diagnostics will be printed.  This includes calls to
1053 diag().
1054
1055 =item B<no_ending>
1056
1057     $Test->no_ending($no_ending);
1058
1059 Normally, Test::Builder does some extra diagnostics when the test
1060 ends.  It also changes the exit code as described below.
1061
1062 If this is true, none of that will be done.
1063
1064 =item B<no_header>
1065
1066     $Test->no_header($no_header);
1067
1068 If set to true, no "1..N" header will be printed.
1069
1070 =cut
1071
1072 foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
1073     my $method = lc $attribute;
1074
1075     my $code = sub {
1076         my($self, $no) = @_;
1077
1078         if( defined $no ) {
1079             $self->{$attribute} = $no;
1080         }
1081         return $self->{$attribute};
1082     };
1083
1084     no strict 'refs';
1085     *{__PACKAGE__.'::'.$method} = $code;
1086 }
1087
1088
1089 =back
1090
1091 =head2 Output
1092
1093 Controlling where the test output goes.
1094
1095 It's ok for your test to change where STDOUT and STDERR point to,
1096 Test::Builder's default output settings will not be affected.
1097
1098 =over 4
1099
1100 =item B<diag>
1101
1102     $Test->diag(@msgs);
1103
1104 Prints out the given @msgs.  Like C<print>, arguments are simply
1105 appended together.
1106
1107 Normally, it uses the failure_output() handle, but if this is for a
1108 TODO test, the todo_output() handle is used.
1109
1110 Output will be indented and marked with a # so as not to interfere
1111 with test output.  A newline will be put on the end if there isn't one
1112 already.
1113
1114 We encourage using this rather than calling print directly.
1115
1116 Returns false.  Why?  Because diag() is often used in conjunction with
1117 a failing test (C<ok() || diag()>) it "passes through" the failure.
1118
1119     return ok(...) || diag(...);
1120
1121 =for blame transfer
1122 Mark Fowler <mark@twoshortplanks.com>
1123
1124 =cut
1125
1126 sub diag {
1127     my($self, @msgs) = @_;
1128
1129     return if $self->no_diag;
1130     return unless @msgs;
1131
1132     # Prevent printing headers when compiling (i.e. -c)
1133     return if $^C;
1134
1135     # Smash args together like print does.
1136     # Convert undef to 'undef' so its readable.
1137     my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
1138
1139     # Escape each line with a #.
1140     $msg =~ s/^/# /gm;
1141
1142     # Stick a newline on the end if it needs it.
1143     $msg .= "\n" unless $msg =~ /\n\Z/;
1144
1145     local $Level = $Level + 1;
1146     $self->_print_diag($msg);
1147
1148     return 0;
1149 }
1150
1151 =begin _private
1152
1153 =item B<_print>
1154
1155     $Test->_print(@msgs);
1156
1157 Prints to the output() filehandle.
1158
1159 =end _private
1160
1161 =cut
1162
1163 sub _print {
1164     my($self, @msgs) = @_;
1165
1166     # Prevent printing headers when only compiling.  Mostly for when
1167     # tests are deparsed with B::Deparse
1168     return if $^C;
1169
1170     my $msg = join '', @msgs;
1171
1172     local($\, $", $,) = (undef, ' ', '');
1173     my $fh = $self->output;
1174
1175     # Escape each line after the first with a # so we don't
1176     # confuse Test::Harness.
1177     $msg =~ s/\n(.)/\n# $1/sg;
1178
1179     # Stick a newline on the end if it needs it.
1180     $msg .= "\n" unless $msg =~ /\n\Z/;
1181
1182     print $fh $msg;
1183 }
1184
1185
1186 =item B<_print_diag>
1187
1188     $Test->_print_diag(@msg);
1189
1190 Like _print, but prints to the current diagnostic filehandle.
1191
1192 =cut
1193
1194 sub _print_diag {
1195     my $self = shift;
1196
1197     local($\, $", $,) = (undef, ' ', '');
1198     my $fh = $self->todo ? $self->todo_output : $self->failure_output;
1199     print $fh @_;
1200 }
1201
1202 =item B<output>
1203
1204     $Test->output($fh);
1205     $Test->output($file);
1206
1207 Where normal "ok/not ok" test output should go.
1208
1209 Defaults to STDOUT.
1210
1211 =item B<failure_output>
1212
1213     $Test->failure_output($fh);
1214     $Test->failure_output($file);
1215
1216 Where diagnostic output on test failures and diag() should go.
1217
1218 Defaults to STDERR.
1219
1220 =item B<todo_output>
1221
1222     $Test->todo_output($fh);
1223     $Test->todo_output($file);
1224
1225 Where diagnostics about todo test failures and diag() should go.
1226
1227 Defaults to STDOUT.
1228
1229 =cut
1230
1231 sub output {
1232     my($self, $fh) = @_;
1233
1234     if( defined $fh ) {
1235         $self->{Out_FH} = _new_fh($fh);
1236     }
1237     return $self->{Out_FH};
1238 }
1239
1240 sub failure_output {
1241     my($self, $fh) = @_;
1242
1243     if( defined $fh ) {
1244         $self->{Fail_FH} = _new_fh($fh);
1245     }
1246     return $self->{Fail_FH};
1247 }
1248
1249 sub todo_output {
1250     my($self, $fh) = @_;
1251
1252     if( defined $fh ) {
1253         $self->{Todo_FH} = _new_fh($fh);
1254     }
1255     return $self->{Todo_FH};
1256 }
1257
1258
1259 sub _new_fh {
1260     my($file_or_fh) = shift;
1261
1262     my $fh;
1263     if( _is_fh($file_or_fh) ) {
1264         $fh = $file_or_fh;
1265     }
1266     else {
1267         $fh = do { local *FH };
1268         open $fh, ">$file_or_fh" or
1269             die "Can't open test output log $file_or_fh: $!";
1270         _autoflush($fh);
1271     }
1272
1273     return $fh;
1274 }
1275
1276
1277 sub _is_fh {
1278     my $maybe_fh = shift;
1279     return 0 unless defined $maybe_fh;
1280
1281     return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
1282
1283     return UNIVERSAL::isa($maybe_fh,               'GLOB')       ||
1284            UNIVERSAL::isa($maybe_fh,               'IO::Handle') ||
1285
1286            # 5.5.4's tied() and can() doesn't like getting undef
1287            UNIVERSAL::can((tied($maybe_fh) || ''), 'TIEHANDLE');
1288 }
1289
1290
1291 sub _autoflush {
1292     my($fh) = shift;
1293     my $old_fh = select $fh;
1294     $| = 1;
1295     select $old_fh;
1296 }
1297
1298
1299 sub _dup_stdhandles {
1300     my $self = shift;
1301
1302     $self->_open_testhandles;
1303
1304     # Set everything to unbuffered else plain prints to STDOUT will
1305     # come out in the wrong order from our own prints.
1306     _autoflush(\*TESTOUT);
1307     _autoflush(\*STDOUT);
1308     _autoflush(\*TESTERR);
1309     _autoflush(\*STDERR);
1310
1311     $self->output(\*TESTOUT);
1312     $self->failure_output(\*TESTERR);
1313     $self->todo_output(\*TESTOUT);
1314 }
1315
1316
1317 my $Opened_Testhandles = 0;
1318 sub _open_testhandles {
1319     return if $Opened_Testhandles;
1320     # We dup STDOUT and STDERR so people can change them in their
1321     # test suites while still getting normal test output.
1322     open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT:  $!";
1323     open(TESTERR, ">&STDERR") or die "Can't dup STDERR:  $!";
1324     $Opened_Testhandles = 1;
1325 }
1326
1327
1328 =back
1329
1330
1331 =head2 Test Status and Info
1332
1333 =over 4
1334
1335 =item B<current_test>
1336
1337     my $curr_test = $Test->current_test;
1338     $Test->current_test($num);
1339
1340 Gets/sets the current test number we're on.  You usually shouldn't
1341 have to set this.
1342
1343 If set forward, the details of the missing tests are filled in as 'unknown'.
1344 if set backward, the details of the intervening tests are deleted.  You
1345 can erase history if you really want to.
1346
1347 =cut
1348
1349 sub current_test {
1350     my($self, $num) = @_;
1351
1352     lock($self->{Curr_Test});
1353     if( defined $num ) {
1354         unless( $self->{Have_Plan} ) {
1355             require Carp;
1356             Carp::croak("Can't change the current test number without a plan!");
1357         }
1358
1359         $self->{Curr_Test} = $num;
1360
1361         # If the test counter is being pushed forward fill in the details.
1362         my $test_results = $self->{Test_Results};
1363         if( $num > @$test_results ) {
1364             my $start = @$test_results ? @$test_results : 0;
1365             for ($start..$num-1) {
1366                 $test_results->[$_] = &share({
1367                     'ok'      => 1,
1368                     actual_ok => undef,
1369                     reason    => 'incrementing test number',
1370                     type      => 'unknown',
1371                     name      => undef
1372                 });
1373             }
1374         }
1375         # If backward, wipe history.  Its their funeral.
1376         elsif( $num < @$test_results ) {
1377             $#{$test_results} = $num - 1;
1378         }
1379     }
1380     return $self->{Curr_Test};
1381 }
1382
1383
1384 =item B<summary>
1385
1386     my @tests = $Test->summary;
1387
1388 A simple summary of the tests so far.  True for pass, false for fail.
1389 This is a logical pass/fail, so todos are passes.
1390
1391 Of course, test #1 is $tests[0], etc...
1392
1393 =cut
1394
1395 sub summary {
1396     my($self) = shift;
1397
1398     return map { $_->{'ok'} } @{ $self->{Test_Results} };
1399 }
1400
1401 =item B<details>
1402
1403     my @tests = $Test->details;
1404
1405 Like summary(), but with a lot more detail.
1406
1407     $tests[$test_num - 1] =
1408             { 'ok'       => is the test considered a pass?
1409               actual_ok  => did it literally say 'ok'?
1410               name       => name of the test (if any)
1411               type       => type of test (if any, see below).
1412               reason     => reason for the above (if any)
1413             };
1414
1415 'ok' is true if Test::Harness will consider the test to be a pass.
1416
1417 'actual_ok' is a reflection of whether or not the test literally
1418 printed 'ok' or 'not ok'.  This is for examining the result of 'todo'
1419 tests.
1420
1421 'name' is the name of the test.
1422
1423 'type' indicates if it was a special test.  Normal tests have a type
1424 of ''.  Type can be one of the following:
1425
1426     skip        see skip()
1427     todo        see todo()
1428     todo_skip   see todo_skip()
1429     unknown     see below
1430
1431 Sometimes the Test::Builder test counter is incremented without it
1432 printing any test output, for example, when current_test() is changed.
1433 In these cases, Test::Builder doesn't know the result of the test, so
1434 it's type is 'unkown'.  These details for these tests are filled in.
1435 They are considered ok, but the name and actual_ok is left undef.
1436
1437 For example "not ok 23 - hole count # TODO insufficient donuts" would
1438 result in this structure:
1439
1440     $tests[22] =    # 23 - 1, since arrays start from 0.
1441       { ok        => 1,   # logically, the test passed since it's todo
1442         actual_ok => 0,   # in absolute terms, it failed
1443         name      => 'hole count',
1444         type      => 'todo',
1445         reason    => 'insufficient donuts'
1446       };
1447
1448 =cut
1449
1450 sub details {
1451     my $self = shift;
1452     return @{ $self->{Test_Results} };
1453 }
1454
1455 =item B<todo>
1456
1457     my $todo_reason = $Test->todo;
1458     my $todo_reason = $Test->todo($pack);
1459
1460 todo() looks for a $TODO variable in your tests.  If set, all tests
1461 will be considered 'todo' (see Test::More and Test::Harness for
1462 details).  Returns the reason (ie. the value of $TODO) if running as
1463 todo tests, false otherwise.
1464
1465 todo() is about finding the right package to look for $TODO in.  It
1466 uses the exported_to() package to find it.  If that's not set, it's
1467 pretty good at guessing the right package to look at based on $Level.
1468
1469 Sometimes there is some confusion about where todo() should be looking
1470 for the $TODO variable.  If you want to be sure, tell it explicitly
1471 what $pack to use.
1472
1473 =cut
1474
1475 sub todo {
1476     my($self, $pack) = @_;
1477
1478     $pack = $pack || $self->exported_to || $self->caller($Level);
1479     return 0 unless $pack;
1480
1481     no strict 'refs';
1482     return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
1483                                      : 0;
1484 }
1485
1486 =item B<caller>
1487
1488     my $package = $Test->caller;
1489     my($pack, $file, $line) = $Test->caller;
1490     my($pack, $file, $line) = $Test->caller($height);
1491
1492 Like the normal caller(), except it reports according to your level().
1493
1494 =cut
1495
1496 sub caller {
1497     my($self, $height) = @_;
1498     $height ||= 0;
1499
1500     my @caller = CORE::caller($self->level + $height + 1);
1501     return wantarray ? @caller : $caller[0];
1502 }
1503
1504 =back
1505
1506 =cut
1507
1508 =begin _private
1509
1510 =over 4
1511
1512 =item B<_sanity_check>
1513
1514   $self->_sanity_check();
1515
1516 Runs a bunch of end of test sanity checks to make sure reality came
1517 through ok.  If anything is wrong it will die with a fairly friendly
1518 error message.
1519
1520 =cut
1521
1522 #'#
1523 sub _sanity_check {
1524     my $self = shift;
1525
1526     _whoa($self->{Curr_Test} < 0,  'Says here you ran a negative number of tests!');
1527     _whoa(!$self->{Have_Plan} and $self->{Curr_Test},
1528           'Somehow your tests ran without a plan!');
1529     _whoa($self->{Curr_Test} != @{ $self->{Test_Results} },
1530           'Somehow you got a different number of results than tests ran!');
1531 }
1532
1533 =item B<_whoa>
1534
1535   _whoa($check, $description);
1536
1537 A sanity check, similar to assert().  If the $check is true, something
1538 has gone horribly wrong.  It will die with the given $description and
1539 a note to contact the author.
1540
1541 =cut
1542
1543 sub _whoa {
1544     my($check, $desc) = @_;
1545     if( $check ) {
1546         die <<WHOA;
1547 WHOA!  $desc
1548 This should never happen!  Please contact the author immediately!
1549 WHOA
1550     }
1551 }
1552
1553 =item B<_my_exit>
1554
1555   _my_exit($exit_num);
1556
1557 Perl seems to have some trouble with exiting inside an END block.  5.005_03
1558 and 5.6.1 both seem to do odd things.  Instead, this function edits $?
1559 directly.  It should ONLY be called from inside an END block.  It
1560 doesn't actually exit, that's your job.
1561
1562 =cut
1563
1564 sub _my_exit {
1565     $? = $_[0];
1566
1567     return 1;
1568 }
1569
1570
1571 =back
1572
1573 =end _private
1574
1575 =cut
1576
1577 $SIG{__DIE__} = sub {
1578     # We don't want to muck with death in an eval, but $^S isn't
1579     # totally reliable.  5.005_03 and 5.6.1 both do the wrong thing
1580     # with it.  Instead, we use caller.  This also means it runs under
1581     # 5.004!
1582     my $in_eval = 0;
1583     for( my $stack = 1;  my $sub = (CORE::caller($stack))[3];  $stack++ ) {
1584         $in_eval = 1 if $sub =~ /^\(eval\)/;
1585     }
1586     $Test->{Test_Died} = 1 unless $in_eval;
1587 };
1588
1589 sub _ending {
1590     my $self = shift;
1591
1592     $self->_sanity_check();
1593
1594     # Don't bother with an ending if this is a forked copy.  Only the parent
1595     # should do the ending.
1596     # Exit if plan() was never called.  This is so "require Test::Simple"
1597     # doesn't puke.
1598     # Don't do an ending if we bailed out.
1599     if( ($self->{Original_Pid} != $$)                   or
1600         (!$self->{Have_Plan} && !$self->{Test_Died})    or
1601         $self->{Bailed_Out}
1602       )
1603     {
1604         _my_exit($?);
1605         return;
1606     }
1607
1608     # Figure out if we passed or failed and print helpful messages.
1609     my $test_results = $self->{Test_Results};
1610     if( @$test_results ) {
1611         # The plan?  We have no plan.
1612         if( $self->{No_Plan} ) {
1613             $self->_print("1..$self->{Curr_Test}\n") unless $self->no_header;
1614             $self->{Expected_Tests} = $self->{Curr_Test};
1615         }
1616
1617         # Auto-extended arrays and elements which aren't explicitly
1618         # filled in with a shared reference will puke under 5.8.0
1619         # ithreads.  So we have to fill them in by hand. :(
1620         my $empty_result = &share({});
1621         for my $idx ( 0..$self->{Expected_Tests}-1 ) {
1622             $test_results->[$idx] = $empty_result
1623               unless defined $test_results->[$idx];
1624         }
1625
1626         my $num_failed = grep !$_->{'ok'},
1627                               @{$test_results}[0..$self->{Curr_Test}-1];
1628
1629         my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
1630
1631         if( $num_extra < 0 ) {
1632             my $s = $self->{Expected_Tests} == 1 ? '' : 's';
1633             $self->diag(<<"FAIL");
1634 Looks like you planned $self->{Expected_Tests} test$s but only ran $self->{Curr_Test}.
1635 FAIL
1636         }
1637         elsif( $num_extra > 0 ) {
1638             my $s = $self->{Expected_Tests} == 1 ? '' : 's';
1639             $self->diag(<<"FAIL");
1640 Looks like you planned $self->{Expected_Tests} test$s but ran $num_extra extra.
1641 FAIL
1642         }
1643
1644         if ( $num_failed ) {
1645             my $num_tests = $self->{Curr_Test};
1646             my $s = $num_failed == 1 ? '' : 's';
1647
1648             my $qualifier = $num_extra == 0 ? '' : ' run';
1649
1650             $self->diag(<<"FAIL");
1651 Looks like you failed $num_failed test$s of $num_tests$qualifier.
1652 FAIL
1653         }
1654
1655         if( $self->{Test_Died} ) {
1656             $self->diag(<<"FAIL");
1657 Looks like your test died just after $self->{Curr_Test}.
1658 FAIL
1659
1660             _my_exit( 255 ) && return;
1661         }
1662
1663         my $exit_code;
1664         if( $num_failed ) {
1665             $exit_code = $num_failed <= 254 ? $num_failed : 254;
1666         }
1667         elsif( $num_extra != 0 ) {
1668             $exit_code = 255;
1669         }
1670         else {
1671             $exit_code = 0;
1672         }
1673
1674         _my_exit( $exit_code ) && return;
1675     }
1676     elsif ( $self->{Skip_All} ) {
1677         _my_exit( 0 ) && return;
1678     }
1679     elsif ( $self->{Test_Died} ) {
1680         $self->diag(<<'FAIL');
1681 Looks like your test died before it could output anything.
1682 FAIL
1683         _my_exit( 255 ) && return;
1684     }
1685     else {
1686         $self->diag("No tests run!\n");
1687         _my_exit( 255 ) && return;
1688     }
1689 }
1690
1691 END {
1692     $Test->_ending if defined $Test and !$Test->no_ending;
1693 }
1694
1695 =head1 EXIT CODES
1696
1697 If all your tests passed, Test::Builder will exit with zero (which is
1698 normal).  If anything failed it will exit with how many failed.  If
1699 you run less (or more) tests than you planned, the missing (or extras)
1700 will be considered failures.  If no tests were ever run Test::Builder
1701 will throw a warning and exit with 255.  If the test died, even after
1702 having successfully completed all its tests, it will still be
1703 considered a failure and will exit with 255.
1704
1705 So the exit codes are...
1706
1707     0                   all tests successful
1708     255                 test died or all passed but wrong # of tests run
1709     any other number    how many failed (including missing or extras)
1710
1711 If you fail more than 254 tests, it will be reported as 254.
1712
1713
1714 =head1 THREADS
1715
1716 In perl 5.8.0 and later, Test::Builder is thread-safe.  The test
1717 number is shared amongst all threads.  This means if one thread sets
1718 the test number using current_test() they will all be effected.
1719
1720 Test::Builder is only thread-aware if threads.pm is loaded I<before>
1721 Test::Builder.
1722
1723 =head1 EXAMPLES
1724
1725 CPAN can provide the best examples.  Test::Simple, Test::More,
1726 Test::Exception and Test::Differences all use Test::Builder.
1727
1728 =head1 SEE ALSO
1729
1730 Test::Simple, Test::More, Test::Harness
1731
1732 =head1 AUTHORS
1733
1734 Original code by chromatic, maintained by Michael G Schwern
1735 E<lt>schwern@pobox.comE<gt>
1736
1737 =head1 COPYRIGHT
1738
1739 Copyright 2002, 2004 by chromatic E<lt>chromatic@wgz.orgE<gt> and
1740                         Michael G Schwern E<lt>schwern@pobox.comE<gt>.
1741
1742 This program is free software; you can redistribute it and/or
1743 modify it under the same terms as Perl itself.
1744
1745 See F<http://www.perl.com/perl/misc/Artistic.html>
1746
1747 =cut
1748
1749 1;