SecurityTests/regressions/inc/Test/Builder.pm

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