lib/Test/Builder.pm

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