lib/Test/Builder.pm

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