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