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