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