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