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