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 $CLASS);
  11 $VERSION = '0.12';
  12 $CLASS = __PACKAGE__;
  13
  14 my $IsVMS = $^O eq 'VMS';
  15
  16 use vars qw($Level);
  17 my @Test_Results = ();
  18 my @Test_Details = ();
  19 my($Test_Died) = 0;
  20 my($Have_Plan) = 0;
  21 my $Curr_Test = 0;
  22
  23
  24 =head1 NAME
  25
  26 Test::Builder - Backend for building test libraries
  27
  28 =head1 SYNOPSIS
  29
  30   package My::Test::Module;
  31   use Test::Builder;
  32   require Exporter;
  33   @ISA = qw(Exporter);
  34   @EXPORT = qw(ok);
  35
  36   my $Test = Test::Builder->new;
  37   $Test->output('my_logfile');
  38
  39   sub import {
  40       my($self) = shift;
  41       my $pack = caller;
  42
  43       $Test->exported_to($pack);
  44       $Test->plan(@_);
  45
  46       $self->export_to_level(1, $self, 'ok');
  47   }
  48
  49   sub ok {
  50       my($test, $name) = @_;
  51
  52       $Test->ok($test, $name);
  53   }
  54
  55
  56 =head1 DESCRIPTION
  57
  58 I<THIS IS ALPHA GRADE SOFTWARE>  Meaning the underlying code is well
  59 tested, yet the interface is subject to change.
  60
  61 Test::Simple and Test::More have proven to be popular testing modules,
  62 but they're not always flexible enough.  Test::Builder provides the a
  63 building block upon which to write your own test libraries I<which can
  64 work together>.
  65
  66 =head2 Construction
  67
  68 =over 4
  69
  70 =item B<new>
  71
  72   my $Test = Test::Builder->new;
  73
  74 Returns a Test::Builder object representing the current state of the
  75 test.
  76
  77 Since you only run one test per program, there is B<one and only one>
  78 Test::Builder object.  No matter how many times you call new(), you're
  79 getting the same object.  (This is called a singleton).
  80
  81 =cut
  82
  83 my $Test;
  84 sub new {
  85     my($class) = shift;
  86     $Test ||= bless ['Move along, nothing to see here'], $class;
  87     return $Test;
  88 }
  89
  90 =back
  91
  92 =head2 Setting up tests
  93
  94 These methods are for setting up tests and declaring how many there
  95 are.  You usually only want to call one of these methods.
  96
  97 =over 4
  98
  99 =item B<exported_to>
 100
 101   my $pack = $Test->exported_to;
 102   $Test->exported_to($pack);
 103
 104 Tells Test::Builder what package you exported your functions to.
 105 This is important for getting TODO tests right.
 106
 107 =cut
 108
 109 my $Exported_To;
 110 sub exported_to {
 111     my($self, $pack) = @_;
 112
 113     if( defined $pack ) {
 114         $Exported_To = $pack;
 115     }
 116     return $Exported_To;
 117 }
 118
 119 =item B<plan>
 120
 121   $Test->plan('no_plan');
 122   $Test->plan( skip_all => $reason );
 123   $Test->plan( tests => $num_tests );
 124
 125 A convenient way to set up your tests.  Call this and Test::Builder
 126 will print the appropriate headers and take the appropriate actions.
 127
 128 If you call plan(), don't call any of the other methods below.
 129
 130 =cut
 131
 132 sub plan {
 133     my($self, $cmd, $arg) = @_;
 134
 135     return unless $cmd;
 136
 137     if( $cmd eq 'no_plan' ) {
 138         $self->no_plan;
 139     }
 140     elsif( $cmd eq 'skip_all' ) {
 141         return $self->skip_all($arg);
 142     }
 143     elsif( $cmd eq 'tests' ) {
 144         if( $arg ) {
 145             return $self->expected_tests($arg);
 146         }
 147         elsif( !defined $arg ) {
 148             die "Got an undefined number of tests.  Looks like you tried to ".
 149                 "say how many tests you plan to run but made a mistake.\n";
 150         }
 151         elsif( !$arg ) {
 152             die "You said to run 0 tests!  You've got to run something.\n";
 153         }
 154     }
 155 }
 156
 157 =item B<expected_tests>
 158
 159     my $max = $Test->expected_tests;
 160     $Test->expected_tests($max);
 161
 162 Gets/sets the # of tests we expect this test to run and prints out
 163 the appropriate headers.
 164
 165 =cut
 166
 167 my $Expected_Tests = 0;
 168 sub expected_tests {
 169     my($self, $max) = @_;
 170
 171     if( defined $max ) {
 172         $Expected_Tests = $max;
 173         $Have_Plan      = 1;
 174
 175         $self->_print("1..$max\n") unless $self->no_header;
 176     }
 177     return $Expected_Tests;
 178 }
 179
 180
 181 =item B<no_plan>
 182
 183   $Test->no_plan;
 184
 185 Declares that this test will run an indeterminate # of tests.
 186
 187 =cut
 188
 189 my($No_Plan) = 0;
 190 sub no_plan {
 191     $No_Plan    = 1;
 192     $Have_Plan  = 1;
 193 }
 194
 195 =item B<skip_all>
 196
 197   $Test->skip_all;
 198   $Test->skip_all($reason);
 199
 200 Skips all the tests, using the given $reason.  Exits immediately with 0.
 201
 202 =cut
 203
 204 my $Skip_All = 0;
 205 sub skip_all {
 206     my($self, $reason) = @_;
 207
 208     my $out = "1..0";
 209     $out .= " # Skip $reason" if $reason;
 210     $out .= "\n";
 211
 212     $Skip_All = 1;
 213
 214     $self->_print($out) unless $self->no_header;
 215     exit(0);
 216 }
 217
 218 =back
 219
 220 =head2 Running tests
 221
 222 These actually run the tests, analogous to the functions in
 223 Test::More.
 224
 225 $name is always optional.
 226
 227 =over 4
 228
 229 =item B<ok>
 230
 231   $Test->ok($test, $name);
 232
 233 Your basic test.  Pass if $test is true, fail if $test is false.  Just
 234 like Test::Simple's ok().
 235
 236 =cut
 237
 238 sub ok {
 239     my($self, $test, $name) = @_;
 240
 241     unless( $Have_Plan ) {
 242         die "You tried to run a test without a plan!  Gotta have a plan.\n";
 243     }
 244
 245     $Curr_Test++;
 246
 247     $self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/;
 248     You named your test '$name'.  You shouldn't use numbers for your test names.
 249     Very confusing.
 250 ERR
 251
 252     my($pack, $file, $line) = $self->caller;
 253
 254     my $todo = $self->todo($pack);
 255
 256     my $out;
 257     unless( $test ) {
 258         $out .= "not ";
 259         $Test_Results[$Curr_Test-1] = $todo ? 1 : 0;
 260     }
 261     else {
 262         $Test_Results[$Curr_Test-1] = 1;
 263     }
 264
 265     $out .= "ok";
 266     $out .= " $Curr_Test" if $self->use_numbers;
 267
 268     if( defined $name ) {
 269         $name =~ s|#|\\#|g;     # # in a name can confuse Test::Harness.
 270         $out   .= " - $name";
 271     }
 272
 273     if( $todo ) {
 274         my $what_todo = $todo;
 275         $out   .= " # TODO $what_todo";
 276     }
 277
 278     $out .= "\n";
 279
 280     $self->_print($out);
 281
 282     unless( $test ) {
 283         my $msg = $todo ? "Failed (TODO)" : "Failed";
 284         $self->diag("    $msg test ($file at line $line)\n");
 285     }
 286
 287     return $test ? 1 : 0;
 288 }
 289
 290 =item B<is_eq>
 291
 292   $Test->is_eq($got, $expected, $name);
 293
 294 Like Test::More's is().  Checks if $got eq $expected.  This is the
 295 string version.
 296
 297 =item B<is_num>
 298
 299   $Test->is_num($got, $expected, $name);
 300
 301 Like Test::More's is().  Checks if $got == $expected.  This is the
 302 numeric version.
 303
 304 =cut
 305
 306 sub is_eq {
 307     my($self, $got, $expect, $name) = @_;
 308     local $Level = $Level + 1;
 309
 310     if( !defined $got || !defined $expect ) {
 311         # undef only matches undef and nothing else
 312         my $test = !defined $got && !defined $expect;
 313
 314         $self->ok($test, $name);
 315         $self->_is_diag($got, 'eq', $expect) unless $test;
 316         return $test;
 317     }
 318
 319     return $self->cmp_ok($got, 'eq', $expect, $name);
 320 }
 321
 322 sub is_num {
 323     my($self, $got, $expect, $name) = @_;
 324     local $Level = $Level + 1;
 325
 326     if( !defined $got || !defined $expect ) {
 327         # undef only matches undef and nothing else
 328         my $test = !defined $got && !defined $expect;
 329
 330         $self->ok($test, $name);
 331         $self->_is_diag($got, '==', $expect) unless $test;
 332         return $test;
 333     }
 334
 335     return $self->cmp_ok($got, '==', $expect, $name);
 336 }
 337
 338 sub _is_diag {
 339     my($self, $got, $type, $expect) = @_;
 340
 341     foreach my $val (\$got, \$expect) {
 342         if( defined $$val ) {
 343             if( $type eq 'eq' ) {
 344                 # quote and force string context
 345                 $$val = "'$$val'"
 346             }
 347             else {
 348                 # force numeric context
 349                 $$val = $$val+0;
 350             }
 351         }
 352         else {
 353             $$val = 'undef';
 354         }
 355     }
 356
 357     $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
 358          got: %s
 359     expected: %s
 360 DIAGNOSTIC
 361
 362 }
 363
 364 =item B<isnt_eq>
 365
 366   $Test->isnt_eq($got, $dont_expect, $name);
 367
 368 Like Test::More's isnt().  Checks if $got ne $dont_expect.  This is
 369 the string version.
 370
 371 =item B<isnt_num>
 372
 373   $Test->is_num($got, $dont_expect, $name);
 374
 375 Like Test::More's isnt().  Checks if $got ne $dont_expect.  This is
 376 the numeric version.
 377
 378 =cut
 379
 380 sub isnt_eq {
 381     my($self, $got, $dont_expect, $name) = @_;
 382     local $Level = $Level + 1;
 383
 384     if( !defined $got || !defined $dont_expect ) {
 385         # undef only matches undef and nothing else
 386         my $test = defined $got || defined $dont_expect;
 387
 388         $self->ok($test, $name);
 389         $self->_cmp_diag('ne', $got, $dont_expect) unless $test;
 390         return $test;
 391     }
 392
 393     return $self->cmp_ok($got, 'ne', $dont_expect, $name);
 394 }
 395
 396 sub isnt_num {
 397     my($self, $got, $dont_expect, $name) = @_;
 398     local $Level = $Level + 1;
 399
 400     if( !defined $got || !defined $dont_expect ) {
 401         # undef only matches undef and nothing else
 402         my $test = defined $got || defined $dont_expect;
 403
 404         $self->ok($test, $name);
 405         $self->_cmp_diag('!=', $got, $dont_expect) unless $test;
 406         return $test;
 407     }
 408
 409     return $self->cmp_ok($got, '!=', $dont_expect, $name);
 410 }
 411
 412
 413 =item B<like>
 414
 415   $Test->like($this, qr/$regex/, $name);
 416   $Test->like($this, '/$regex/', $name);
 417
 418 Like Test::More's like().  Checks if $this matches the given $regex.
 419
 420 You'll want to avoid qr// if you want your tests to work before 5.005.
 421
 422 =item B<unlike>
 423
 424   $Test->unlike($this, qr/$regex/, $name);
 425   $Test->unlike($this, '/$regex/', $name);
 426
 427 Like Test::More's unlike().  Checks if $this B<does not match> the
 428 given $regex.
 429
 430 =cut
 431
 432 sub like {
 433     my($self, $this, $regex, $name) = @_;
 434
 435     local $Level = $Level + 1;
 436     $self->_regex_ok($this, $regex, '=~', $name);
 437 }
 438
 439 sub unlike {
 440     my($self, $this, $regex, $name) = @_;
 441
 442     local $Level = $Level + 1;
 443     $self->_regex_ok($this, $regex, '!~', $name);
 444 }
 445
 446 sub _regex_ok {
 447     my($self, $this, $regex, $cmp, $name) = @_;
 448
 449     local $Level = $Level + 1;
 450
 451     my $ok = 0;
 452     my $usable_regex;
 453     if( ref $regex eq 'Regexp' ) {
 454         $usable_regex = $regex;
 455     }
 456     # Check if it looks like '/foo/'
 457     elsif( my($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx ) {
 458         $usable_regex = "(?$opts)$re";
 459     }
 460     else {
 461         $ok = $self->ok( 0, $name );
 462
 463         $self->diag("    '$regex' doesn't look much like a regex to me.");
 464
 465         return $ok;
 466     }
 467
 468     {
 469         local $^W = 0;
 470         my $test = $this =~ /$usable_regex/ ? 1 : 0;
 471         $test = !$test if $cmp eq '!~';
 472         $ok = $self->ok( $test, $name );
 473     }
 474
 475     unless( $ok ) {
 476         $this = defined $this ? "'$this'" : 'undef';
 477         my $match = $cmp eq '=~' ? "doesn't match" : "matches";
 478         $self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
 479                   %s
 480     %13s '%s'
 481 DIAGNOSTIC
 482
 483     }
 484
 485     return $ok;
 486 }
 487
 488 =item B<cmp_ok>
 489
 490   $Test->cmp_ok($this, $type, $that, $name);
 491
 492 Works just like Test::More's cmp_ok().
 493
 494     $Test->cmp_ok($big_num, '!=', $other_big_num);
 495
 496 =cut
 497
 498 sub cmp_ok {
 499     my($self, $got, $type, $expect, $name) = @_;
 500
 501     my $test;
 502     {
 503         local $^W = 0;
 504         local($@,$!);   # don't interfere with $@
 505                         # eval() sometimes resets $!
 506         $test = eval "\$got $type \$expect";
 507     }
 508     local $Level = $Level + 1;
 509     my $ok = $self->ok($test, $name);
 510
 511     unless( $ok ) {
 512         if( $type =~ /^(eq|==)$/ ) {
 513             $self->_is_diag($got, $type, $expect);
 514         }
 515         else {
 516             $self->_cmp_diag($got, $type, $expect);
 517         }
 518     }
 519     return $ok;
 520 }
 521
 522 sub _cmp_diag {
 523     my($self, $got, $type, $expect) = @_;
 524
 525     $got    = defined $got    ? "'$got'"    : 'undef';
 526     $expect = defined $expect ? "'$expect'" : 'undef';
 527     $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
 528     %s
 529         %s
 530     %s
 531 DIAGNOSTIC
 532 }
 533
 534 =item B<BAILOUT>
 535
 536     $Test->BAILOUT($reason);
 537
 538 Indicates to the Test::Harness that things are going so badly all
 539 testing should terminate.  This includes running any additional test
 540 scripts.
 541
 542 It will exit with 255.
 543
 544 =cut
 545
 546 sub BAILOUT {
 547     my($self, $reason) = @_;
 548
 549     $self->_print("Bail out!  $reason");
 550     exit 255;
 551 }
 552
 553 =item B<skip>
 554
 555     $Test->skip;
 556     $Test->skip($why);
 557
 558 Skips the current test, reporting $why.
 559
 560 =cut
 561
 562 sub skip {
 563     my($self, $why) = @_;
 564     $why ||= '';
 565
 566     unless( $Have_Plan ) {
 567         die "You tried to run tests without a plan!  Gotta have a plan.\n";
 568     }
 569
 570     $Curr_Test++;
 571
 572     $Test_Results[$Curr_Test-1] = 1;
 573
 574     my $out = "ok";
 575     $out   .= " $Curr_Test" if $self->use_numbers;
 576     $out   .= " # skip $why\n";
 577
 578     $Test->_print($out);
 579
 580     return 1;
 581 }
 582
 583
 584 =item B<todo_skip>
 585
 586   $Test->todo_skip;
 587   $Test->todo_skip($why);
 588
 589 Like skip(), only it will declare the test as failing and TODO.  Similar
 590 to
 591
 592     print "not ok $tnum # TODO $why\n";
 593
 594 =cut
 595
 596 sub todo_skip {
 597     my($self, $why) = @_;
 598     $why ||= '';
 599
 600     unless( $Have_Plan ) {
 601         die "You tried to run tests without a plan!  Gotta have a plan.\n";
 602     }
 603
 604     $Curr_Test++;
 605
 606     $Test_Results[$Curr_Test-1] = 1;
 607
 608     my $out = "not ok";
 609     $out   .= " $Curr_Test" if $self->use_numbers;
 610     $out   .= " # TODO $why\n";
 611
 612     $Test->_print($out);
 613
 614     return 1;
 615 }
 616
 617
 618 =begin _unimplemented
 619
 620 =item B<skip_rest>
 621
 622   $Test->skip_rest;
 623   $Test->skip_rest($reason);
 624
 625 Like skip(), only it skips all the rest of the tests you plan to run
 626 and terminates the test.
 627
 628 If you're running under no_plan, it skips once and terminates the
 629 test.
 630
 631 =end _unimplemented
 632
 633 =back
 634
 635
 636 =head2 Test style
 637
 638 =over 4
 639
 640 =item B<level>
 641
 642     $Test->level($how_high);
 643
 644 How far up the call stack should $Test look when reporting where the
 645 test failed.
 646
 647 Defaults to 1.
 648
 649 Setting $Test::Builder::Level overrides.  This is typically useful
 650 localized:
 651
 652     {
 653         local $Test::Builder::Level = 2;
 654         $Test->ok($test);
 655     }
 656
 657 =cut
 658
 659 sub level {
 660     my($self, $level) = @_;
 661
 662     if( defined $level ) {
 663         $Level = $level;
 664     }
 665     return $Level;
 666 }
 667
 668 $CLASS->level(1);
 669
 670
 671 =item B<use_numbers>
 672
 673     $Test->use_numbers($on_or_off);
 674
 675 Whether or not the test should output numbers.  That is, this if true:
 676
 677   ok 1
 678   ok 2
 679   ok 3
 680
 681 or this if false
 682
 683   ok
 684   ok
 685   ok
 686
 687 Most useful when you can't depend on the test output order, such as
 688 when threads or forking is involved.
 689
 690 Test::Harness will accept either, but avoid mixing the two styles.
 691
 692 Defaults to on.
 693
 694 =cut
 695
 696 my $Use_Nums = 1;
 697 sub use_numbers {
 698     my($self, $use_nums) = @_;
 699
 700     if( defined $use_nums ) {
 701         $Use_Nums = $use_nums;
 702     }
 703     return $Use_Nums;
 704 }
 705
 706 =item B<no_header>
 707
 708     $Test->no_header($no_header);
 709
 710 If set to true, no "1..N" header will be printed.
 711
 712 =item B<no_ending>
 713
 714     $Test->no_ending($no_ending);
 715
 716 Normally, Test::Builder does some extra diagnostics when the test
 717 ends.  It also changes the exit code as described in Test::Simple.
 718
 719 If this is true, none of that will be done.
 720
 721 =cut
 722
 723 my($No_Header, $No_Ending) = (0,0);
 724 sub no_header {
 725     my($self, $no_header) = @_;
 726
 727     if( defined $no_header ) {
 728         $No_Header = $no_header;
 729     }
 730     return $No_Header;
 731 }
 732
 733 sub no_ending {
 734     my($self, $no_ending) = @_;
 735
 736     if( defined $no_ending ) {
 737         $No_Ending = $no_ending;
 738     }
 739     return $No_Ending;
 740 }
 741
 742
 743 =back
 744
 745 =head2 Output
 746
 747 Controlling where the test output goes.
 748
 749 It's ok for your test to change where STDOUT and STDERR point to,
 750 Test::Builder's default output settings will not be affected.
 751
 752 =over 4
 753
 754 =item B<diag>
 755
 756     $Test->diag(@msgs);
 757
 758 Prints out the given $message.  Normally, it uses the failure_output()
 759 handle, but if this is for a TODO test, the todo_output() handle is
 760 used.
 761
 762 Output will be indented and marked with a # so as not to interfere
 763 with test output.  A newline will be put on the end if there isn't one
 764 already.
 765
 766 We encourage using this rather than calling print directly.
 767
 768 =cut
 769
 770 sub diag {
 771     my($self, @msgs) = @_;
 772     return unless @msgs;
 773
 774     # Prevent printing headers when compiling (i.e. -c)
 775     return if $^C;
 776
 777     # Escape each line with a #.
 778     foreach (@msgs) {
 779         s/^/# /gms;
 780     }
 781
 782     push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/;
 783
 784     local $Level = $Level + 1;
 785     my $fh = $self->todo ? $self->todo_output : $self->failure_output;
 786     local($\, $", $,) = (undef, ' ', '');
 787     print $fh @msgs;
 788 }
 789
 790 =begin _private
 791
 792 =item B<_print>
 793
 794     $Test->_print(@msgs);
 795
 796 Prints to the output() filehandle.
 797
 798 =end _private
 799
 800 =cut
 801
 802 sub _print {
 803     my($self, @msgs) = @_;
 804
 805     # Prevent printing headers when only compiling.  Mostly for when
 806     # tests are deparsed with B::Deparse
 807     return if $^C;
 808
 809     local($\, $", $,) = (undef, ' ', '');
 810     my $fh = $self->output;
 811     print $fh @msgs;
 812 }
 813
 814
 815 =item B<output>
 816
 817     $Test->output($fh);
 818     $Test->output($file);
 819
 820 Where normal "ok/not ok" test output should go.
 821
 822 Defaults to STDOUT.
 823
 824 =item B<failure_output>
 825
 826     $Test->failure_output($fh);
 827     $Test->failure_output($file);
 828
 829 Where diagnostic output on test failures and diag() should go.
 830
 831 Defaults to STDERR.
 832
 833 =item B<todo_output>
 834
 835     $Test->todo_output($fh);
 836     $Test->todo_output($file);
 837
 838 Where diagnostics about todo test failures and diag() should go.
 839
 840 Defaults to STDOUT.
 841
 842 =cut
 843
 844 my($Out_FH, $Fail_FH, $Todo_FH);
 845 sub output {
 846     my($self, $fh) = @_;
 847
 848     if( defined $fh ) {
 849         $Out_FH = _new_fh($fh);
 850     }
 851     return $Out_FH;
 852 }
 853
 854 sub failure_output {
 855     my($self, $fh) = @_;
 856
 857     if( defined $fh ) {
 858         $Fail_FH = _new_fh($fh);
 859     }
 860     return $Fail_FH;
 861 }
 862
 863 sub todo_output {
 864     my($self, $fh) = @_;
 865
 866     if( defined $fh ) {
 867         $Todo_FH = _new_fh($fh);
 868     }
 869     return $Todo_FH;
 870 }
 871
 872 sub _new_fh {
 873     my($file_or_fh) = shift;
 874
 875     my $fh;
 876     unless( UNIVERSAL::isa($file_or_fh, 'GLOB') ) {
 877         $fh = do { local *FH };
 878         open $fh, ">$file_or_fh" or
 879             die "Can't open test output log $file_or_fh: $!";
 880     }
 881     else {
 882         $fh = $file_or_fh;
 883     }
 884
 885     return $fh;
 886 }
 887
 888 unless( $^C ) {
 889     # We dup STDOUT and STDERR so people can change them in their
 890     # test suites while still getting normal test output.
 891     open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT:  $!";
 892     open(TESTERR, ">&STDERR") or die "Can't dup STDERR:  $!";
 893
 894     # Set everything to unbuffered else plain prints to STDOUT will
 895     # come out in the wrong order from our own prints.
 896     _autoflush(\*TESTOUT);
 897     _autoflush(\*STDOUT);
 898     _autoflush(\*TESTERR);
 899     _autoflush(\*STDERR);
 900
 901     $CLASS->output(\*TESTOUT);
 902     $CLASS->failure_output(\*TESTERR);
 903     $CLASS->todo_output(\*TESTOUT);
 904 }
 905
 906 sub _autoflush {
 907     my($fh) = shift;
 908     my $old_fh = select $fh;
 909     $| = 1;
 910     select $old_fh;
 911 }
 912
 913
 914 =back
 915
 916
 917 =head2 Test Status and Info
 918
 919 =over 4
 920
 921 =item B<current_test>
 922
 923     my $curr_test = $Test->current_test;
 924     $Test->current_test($num);
 925
 926 Gets/sets the current test # we're on.
 927
 928 You usually shouldn't have to set this.
 929
 930 =cut
 931
 932 sub current_test {
 933     my($self, $num) = @_;
 934
 935     if( defined $num ) {
 936         $Curr_Test = $num;
 937         if( $num > @Test_Results ) {
 938             for ($#Test_Results..$num-1) {
 939                 $Test_Results[$_] = 1;
 940             }
 941         }
 942     }
 943     return $Curr_Test;
 944 }
 945
 946
 947 =item B<summary>
 948
 949     my @tests = $Test->summary;
 950
 951 A simple summary of the tests so far.  True for pass, false for fail.
 952 This is a logical pass/fail, so todos are passes.
 953
 954 Of course, test #1 is $tests[0], etc...
 955
 956 =cut
 957
 958 sub summary {
 959     my($self) = shift;
 960
 961     return @Test_Results;
 962 }
 963
 964 =item B<details>  I<UNIMPLEMENTED>
 965
 966     my @tests = $Test->details;
 967
 968 Like summary(), but with a lot more detail.
 969
 970     $tests[$test_num - 1] =
 971             { ok         => is the test considered ok?
 972               actual_ok  => did it literally say 'ok'?
 973               name       => name of the test (if any)
 974               type       => 'skip' or 'todo' (if any)
 975               reason     => reason for the above (if any)
 976             };
 977
 978 =item B<todo>
 979
 980     my $todo_reason = $Test->todo;
 981     my $todo_reason = $Test->todo($pack);
 982
 983 todo() looks for a $TODO variable in your tests.  If set, all tests
 984 will be considered 'todo' (see Test::More and Test::Harness for
 985 details).  Returns the reason (ie. the value of $TODO) if running as
 986 todo tests, false otherwise.
 987
 988 todo() is pretty part about finding the right package to look for
 989 $TODO in.  It uses the exported_to() package to find it.  If that's
 990 not set, it's pretty good at guessing the right package to look at.
 991
 992 Sometimes there is some confusion about where todo() should be looking
 993 for the $TODO variable.  If you want to be sure, tell it explicitly
 994 what $pack to use.
 995
 996 =cut
 997
 998 sub todo {
 999     my($self, $pack) = @_;
1000
1001     $pack = $pack || $self->exported_to || $self->caller(1);
1002
1003     no strict 'refs';
1004     return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
1005                                      : 0;
1006 }
1007
1008 =item B<caller>
1009
1010     my $package = $Test->caller;
1011     my($pack, $file, $line) = $Test->caller;
1012     my($pack, $file, $line) = $Test->caller($height);
1013
1014 Like the normal caller(), except it reports according to your level().
1015
1016 =cut
1017
1018 sub caller {
1019     my($self, $height) = @_;
1020     $height ||= 0;
1021
1022     my @caller = CORE::caller($self->level + $height + 1);
1023     return wantarray ? @caller : $caller[0];
1024 }
1025
1026 =back
1027
1028 =cut
1029
1030 =begin _private
1031
1032 =over 4
1033
1034 =item B<_sanity_check>
1035
1036   _sanity_check();
1037
1038 Runs a bunch of end of test sanity checks to make sure reality came
1039 through ok.  If anything is wrong it will die with a fairly friendly
1040 error message.
1041
1042 =cut
1043
1044 #'#
1045 sub _sanity_check {
1046     _whoa($Curr_Test < 0,  'Says here you ran a negative number of tests!');
1047     _whoa(!$Have_Plan and $Curr_Test,
1048           'Somehow your tests ran without a plan!');
1049     _whoa($Curr_Test != @Test_Results,
1050           'Somehow you got a different number of results than tests ran!');
1051 }
1052
1053 =item B<_whoa>
1054
1055   _whoa($check, $description);
1056
1057 A sanity check, similar to assert().  If the $check is true, something
1058 has gone horribly wrong.  It will die with the given $description and
1059 a note to contact the author.
1060
1061 =cut
1062
1063 sub _whoa {
1064     my($check, $desc) = @_;
1065     if( $check ) {
1066         die <<WHOA;
1067 WHOA!  $desc
1068 This should never happen!  Please contact the author immediately!
1069 WHOA
1070     }
1071 }
1072
1073 =item B<_my_exit>
1074
1075   _my_exit($exit_num);
1076
1077 Perl seems to have some trouble with exiting inside an END block.  5.005_03
1078 and 5.6.1 both seem to do odd things.  Instead, this function edits $?
1079 directly.  It should ONLY be called from inside an END block.  It
1080 doesn't actually exit, that's your job.
1081
1082 =cut
1083
1084 sub _my_exit {
1085     $? = $_[0];
1086
1087     return 1;
1088 }
1089
1090
1091 =back
1092
1093 =end _private
1094
1095 =cut
1096
1097 $SIG{__DIE__} = sub {
1098     # We don't want to muck with death in an eval, but $^S isn't
1099     # totally reliable.  5.005_03 and 5.6.1 both do the wrong thing
1100     # with it.  Instead, we use caller.  This also means it runs under
1101     # 5.004!
1102     my $in_eval = 0;
1103     for( my $stack = 1;  my $sub = (CORE::caller($stack))[3];  $stack++ ) {
1104         $in_eval = 1 if $sub =~ /^\(eval\)/;
1105     }
1106     $Test_Died = 1 unless $in_eval;
1107 };
1108
1109 sub _ending {
1110     my $self = shift;
1111
1112     _sanity_check();
1113
1114     # Bailout if plan() was never called.  This is so
1115     # "require Test::Simple" doesn't puke.
1116     do{ _my_exit(0) && return } if !$Have_Plan;
1117
1118     # Figure out if we passed or failed and print helpful messages.
1119     if( @Test_Results ) {
1120         # The plan?  We have no plan.
1121         if( $No_Plan ) {
1122             $self->_print("1..$Curr_Test\n") unless $self->no_header;
1123             $Expected_Tests = $Curr_Test;
1124         }
1125
1126         my $num_failed = grep !$_, @Test_Results[0..$Expected_Tests-1];
1127         $num_failed += abs($Expected_Tests - @Test_Results);
1128
1129         if( $Curr_Test < $Expected_Tests ) {
1130             $self->diag(<<"FAIL");
1131 Looks like you planned $Expected_Tests tests but only ran $Curr_Test.
1132 FAIL
1133         }
1134         elsif( $Curr_Test > $Expected_Tests ) {
1135             my $num_extra = $Curr_Test - $Expected_Tests;
1136             $self->diag(<<"FAIL");
1137 Looks like you planned $Expected_Tests tests but ran $num_extra extra.
1138 FAIL
1139         }
1140         elsif ( $num_failed ) {
1141             $self->diag(<<"FAIL");
1142 Looks like you failed $num_failed tests of $Expected_Tests.
1143 FAIL
1144         }
1145
1146         if( $Test_Died ) {
1147             $self->diag(<<"FAIL");
1148 Looks like your test died just after $Curr_Test.
1149 FAIL
1150
1151             _my_exit( 255 ) && return;
1152         }
1153
1154         _my_exit( $num_failed <= 254 ? $num_failed : 254  ) && return;
1155     }
1156     elsif ( $Skip_All ) {
1157         _my_exit( 0 ) && return;
1158     }
1159     else {
1160         $self->diag("No tests run!\n");
1161         _my_exit( 255 ) && return;
1162     }
1163 }
1164
1165 END {
1166     $Test->_ending if defined $Test and !$Test->no_ending;
1167 }
1168
1169 =head1 EXAMPLES
1170
1171 At this point, Test::Simple and Test::More are your best examples.
1172
1173 =head1 SEE ALSO
1174
1175 Test::Simple, Test::More, Test::Harness
1176
1177 =head1 AUTHORS
1178
1179 Original code by chromatic, maintained by Michael G Schwern
1180 E<lt>schwern@pobox.comE<gt>
1181
1182 =head1 COPYRIGHT
1183
1184 Copyright 2001 by chromatic E<lt>chromatic@wgz.orgE<gt>,
1185                   Michael G Schwern E<lt>schwern@pobox.comE<gt>.
1186
1187 This program is free software; you can redistribute it and/or
1188 modify it under the same terms as Perl itself.
1189
1190 See F<http://www.perl.com/perl/misc/Artistic.html>
1191
1192 =cut
1193
1194 1;