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