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