PageRenderTime 60ms CodeModel.GetById 12ms app.highlight 42ms RepoModel.GetById 1ms app.codeStats 0ms

/tags/rel-1-3-29/SWIG/Examples/test-suite/perl5/Test/Builder.pm

#
Perl | 1591 lines | 1277 code | 283 blank | 31 comment | 80 complexity | f76bc10c1aa69e373ab6f03ec7d69ceb MD5 | raw file
Possible License(s): LGPL-2.1, Cube, GPL-3.0, 0BSD, GPL-2.0
   1package Test::Builder;
   2
   3use 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
   9use strict;
  10use 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.
  15BEGIN {
  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
  70Test::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
 102Test::Simple and Test::More have proven to be popular testing modules,
 103but they're not always flexible enough.  Test::Builder provides the a
 104building block upon which to write your own test libraries I<which can
 105work together>.
 106
 107=head2 Construction
 108
 109=over 4
 110
 111=item B<new>
 112
 113  my $Test = Test::Builder->new;
 114
 115Returns a Test::Builder object representing the current state of the
 116test.
 117
 118Since you only run one test per program, there is B<one and only one>
 119Test::Builder object.  No matter how many times you call new(), you're
 120getting the same object.  (This is called a singleton).
 121
 122=cut
 123
 124my $Test = Test::Builder->new;
 125sub 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
 135Reinitializes the Test::Builder singleton to its original state.
 136Mostly useful for tests run in persistent environments where the same
 137test might be run multiple times in the same process.
 138
 139=cut
 140
 141my $Test_Died;
 142my $Have_Plan;
 143my $No_Plan;
 144my $Curr_Test;     share($Curr_Test);
 145use vars qw($Level);
 146my $Original_Pid;
 147my @Test_Results;  share(@Test_Results);
 148
 149my $Exported_To;
 150my $Expected_Tests;
 151
 152my $Skip_All;
 153
 154my $Use_Nums;
 155
 156my($No_Header, $No_Ending);
 157
 158$Test->reset;
 159
 160sub 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
 189These methods are for setting up tests and declaring how many there
 190are.  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
 199Tells Test::Builder what package you exported your functions to.
 200This is important for getting TODO tests right.
 201
 202=cut
 203
 204sub 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
 219A convenient way to set up your tests.  Call this and Test::Builder
 220will print the appropriate headers and take the appropriate actions.
 221
 222If you call plan(), don't call any of the other methods below.
 223
 224=cut
 225
 226sub 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
 268Gets/sets the # of tests we expect this test to run and prints out
 269the appropriate headers.
 270
 271=cut
 272
 273sub 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
 294Declares that this test will run an indeterminate # of tests.
 295
 296=cut
 297
 298sub no_plan {
 299    $No_Plan    = 1;
 300    $Have_Plan  = 1;
 301}
 302
 303=item B<has_plan>
 304
 305  $plan = $Test->has_plan
 306  
 307Find 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
 311sub 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
 323Skips all the tests, using the given $reason.  Exits immediately with 0.
 324
 325=cut
 326
 327sub 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
 344These actually run the tests, analogous to the functions in
 345Test::More.
 346
 347$name is always optional.
 348
 349=over 4
 350
 351=item B<ok>
 352
 353  $Test->ok($test, $name);
 354
 355Your basic test.  Pass if $test is true, fail if $test is false.  Just
 356like Test::Simple's ok().
 357
 358=cut
 359
 360sub 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.
 381ERR
 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
 436sub _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
 459Like Test::More's is().  Checks if $got eq $expected.  This is the
 460string version.
 461
 462=item B<is_num>
 463
 464  $Test->is_num($got, $expected, $name);
 465
 466Like Test::More's is().  Checks if $got == $expected.  This is the
 467numeric version.
 468
 469=cut
 470
 471sub 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
 487sub 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
 503sub _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
 525DIAGNOSTIC
 526
 527}    
 528
 529=item B<isnt_eq>
 530
 531  $Test->isnt_eq($got, $dont_expect, $name);
 532
 533Like Test::More's isnt().  Checks if $got ne $dont_expect.  This is
 534the string version.
 535
 536=item B<isnt_num>
 537
 538  $Test->is_num($got, $dont_expect, $name);
 539
 540Like Test::More's isnt().  Checks if $got ne $dont_expect.  This is
 541the numeric version.
 542
 543=cut
 544
 545sub 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
 561sub 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
 583Like Test::More's like().  Checks if $this matches the given $regex.
 584
 585You'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
 592Like Test::More's unlike().  Checks if $this B<does not match> the
 593given $regex.
 594
 595=cut
 596
 597sub like {
 598    my($self, $this, $regex, $name) = @_;
 599
 600    local $Level = $Level + 1;
 601    $self->_regex_ok($this, $regex, '=~', $name);
 602}
 603
 604sub 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
 616Convenience method for building testing functions that take regular
 617expressions as arguments, but need to work before perl 5.005.
 618
 619Takes a quoted regular expression produced by qr//, or a string
 620representing a regular expression.
 621
 622Returns a Perl value which may be used instead of the corresponding
 623regular expression, or undef if it's argument is not recognised.
 624
 625For example, a version of like(), sans the useful diagnostic messages,
 626could 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
 639sub 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
 662sub _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'
 688DIAGNOSTIC
 689
 690    }
 691
 692    return $ok;
 693}
 694
 695=item B<cmp_ok>
 696
 697  $Test->cmp_ok($this, $type, $that, $name);
 698
 699Works just like Test::More's cmp_ok().
 700
 701    $Test->cmp_ok($big_num, '!=', $other_big_num);
 702
 703=cut
 704
 705sub 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
 729sub _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
 738DIAGNOSTIC
 739}
 740
 741=item B<BAILOUT>
 742
 743    $Test->BAILOUT($reason);
 744
 745Indicates to the Test::Harness that things are going so badly all
 746testing should terminate.  This includes running any additional test
 747scripts.
 748
 749It will exit with 255.
 750
 751=cut
 752
 753sub 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
 765Skips the current test, reporting $why.
 766
 767=cut
 768
 769sub 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
 807Like skip(), only it will declare the test as failing and TODO.  Similar
 808to
 809
 810    print "not ok $tnum # TODO $why\n";
 811
 812=cut
 813
 814sub 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
 851Like skip(), only it skips all the rest of the tests you plan to run
 852and terminates the test.
 853
 854If you're running under no_plan, it skips once and terminates the
 855test.
 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
 870How far up the call stack should $Test look when reporting where the
 871test failed.
 872
 873Defaults to 1.
 874
 875Setting $Test::Builder::Level overrides.  This is typically useful
 876localized:
 877
 878    {
 879        local $Test::Builder::Level = 2;
 880        $Test->ok($test);
 881    }
 882
 883=cut
 884
 885sub 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
 899Whether or not the test should output numbers.  That is, this if true:
 900
 901  ok 1
 902  ok 2
 903  ok 3
 904
 905or this if false
 906
 907  ok
 908  ok
 909  ok
 910
 911Most useful when you can't depend on the test output order, such as
 912when threads or forking is involved.
 913
 914Test::Harness will accept either, but avoid mixing the two styles.
 915
 916Defaults to on.
 917
 918=cut
 919
 920sub 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
 933If set to true, no "1..N" header will be printed.
 934
 935=item B<no_ending>
 936
 937    $Test->no_ending($no_ending);
 938
 939Normally, Test::Builder does some extra diagnostics when the test
 940ends.  It also changes the exit code as described below.
 941
 942If this is true, none of that will be done.
 943
 944=cut
 945
 946sub 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
 955sub 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
 969Controlling where the test output goes.
 970
 971It's ok for your test to change where STDOUT and STDERR point to,
 972Test::Builder's default output settings will not be affected.
 973
 974=over 4
 975
 976=item B<diag>
 977
 978    $Test->diag(@msgs);
 979
 980Prints out the given @msgs.  Like C<print>, arguments are simply
 981appended together.
 982
 983Normally, it uses the failure_output() handle, but if this is for a
 984TODO test, the todo_output() handle is used.
 985
 986Output will be indented and marked with a # so as not to interfere
 987with test output.  A newline will be put on the end if there isn't one
 988already.
 989
 990We encourage using this rather than calling print directly.
 991
 992Returns false.  Why?  Because diag() is often used in conjunction with
 993a failing test (C<ok() || diag()>) it "passes through" the failure.
 994
 995    return ok(...) || diag(...);
 996
 997=for blame transfer
 998Mark Fowler <mark@twoshortplanks.com>
 999
1000=cut
1001
1002sub 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
1031Prints to the output() filehandle.
1032
1033=end _private
1034
1035=cut
1036
1037sub _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
1064Like _print, but prints to the current diagnostic filehandle.
1065
1066=cut
1067
1068sub _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
1081Where normal "ok/not ok" test output should go.
1082
1083Defaults to STDOUT.
1084
1085=item B<failure_output>
1086
1087    $Test->failure_output($fh);
1088    $Test->failure_output($file);
1089
1090Where diagnostic output on test failures and diag() should go.
1091
1092Defaults to STDERR.
1093
1094=item B<todo_output>
1095
1096    $Test->todo_output($fh);
1097    $Test->todo_output($file);
1098
1099Where diagnostics about todo test failures and diag() should go.
1100
1101Defaults to STDOUT.
1102
1103=cut
1104
1105my($Out_FH, $Fail_FH, $Todo_FH);
1106sub output {
1107    my($self, $fh) = @_;
1108
1109    if( defined $fh ) {
1110        $Out_FH = _new_fh($fh);
1111    }
1112    return $Out_FH;
1113}
1114
1115sub failure_output {
1116    my($self, $fh) = @_;
1117
1118    if( defined $fh ) {
1119        $Fail_FH = _new_fh($fh);
1120    }
1121    return $Fail_FH;
1122}
1123
1124sub 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
1134sub _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
1151sub _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
1164sub _autoflush {
1165    my($fh) = shift;
1166    my $old_fh = select $fh;
1167    $| = 1;
1168    select $old_fh;
1169}
1170
1171
1172my $Opened_Testhandles = 0;
1173sub _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
1190sub _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
1211Gets/sets the current test number we're on.  You usually shouldn't
1212have to set this.
1213
1214If set forward, the details of the missing tests are filled in as 'unknown'.
1215if set backward, the details of the intervening tests are deleted.  You
1216can erase history if you really want to.
1217
1218=cut
1219
1220sub 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
1258A simple summary of the tests so far.  True for pass, false for fail.
1259This is a logical pass/fail, so todos are passes.
1260
1261Of course, test #1 is $tests[0], etc...
1262
1263=cut
1264
1265sub 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
1275Like 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
1288printed 'ok' or 'not ok'.  This is for examining the result of 'todo'
1289tests.  
1290
1291'name' is the name of the test.
1292
1293'type' indicates if it was a special test.  Normal tests have a type
1294of ''.  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
1301Sometimes the Test::Builder test counter is incremented without it
1302printing any test output, for example, when current_test() is changed.
1303In these cases, Test::Builder doesn't know the result of the test, so
1304it's type is 'unkown'.  These details for these tests are filled in.
1305They are considered ok, but the name and actual_ok is left undef.
1306
1307For example "not ok 23 - hole count # TODO insufficient donuts" would
1308result 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
1320sub 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
1329todo() looks for a $TODO variable in your tests.  If set, all tests
1330will be considered 'todo' (see Test::More and Test::Harness for
1331details).  Returns the reason (ie. the value of $TODO) if running as
1332todo tests, false otherwise.
1333
1334todo() 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
1336not set, it's pretty good at guessing the right package to look at.
1337
1338Sometimes there is some confusion about where todo() should be looking
1339for the $TODO variable.  If you want to be sure, tell it explicitly
1340what $pack to use.
1341
1342=cut
1343
1344sub 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
1360Like the normal caller(), except it reports according to your level().
1361
1362=cut
1363
1364sub 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
1384Runs a bunch of end of test sanity checks to make sure reality came
1385through ok.  If anything is wrong it will die with a fairly friendly
1386error message.
1387
1388=cut
1389
1390#'#
1391sub _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
1403A sanity check, similar to assert().  If the $check is true, something
1404has gone horribly wrong.  It will die with the given $description and
1405a note to contact the author.
1406
1407=cut
1408
1409sub _whoa {
1410    my($check, $desc) = @_;
1411    if( $check ) {
1412        die <<WHOA;
1413WHOA!  $desc
1414This should never happen!  Please contact the author immediately!
1415WHOA
1416    }
1417}
1418
1419=item B<_my_exit>
1420
1421  _my_exit($exit_num);
1422
1423Perl seems to have some trouble with exiting inside an END block.  5.005_03
1424and 5.6.1 both seem to do odd things.  Instead, this function edits $?
1425directly.  It should ONLY be called from inside an END block.  It
1426doesn't actually exit, that's your job.
1427
1428=cut
1429
1430sub _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
1455sub _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");
1491Looks like you planned $Expected_Tests test$s but only ran $Curr_Test.
1492FAIL
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");
1498Looks like you planned $Expected_Tests test$s but ran $num_extra extra.
1499FAIL
1500        }
1501        elsif ( $num_failed ) {
1502            my $s = $num_failed == 1 ? '' : 's';
1503            $self->diag(<<"FAIL");
1504Looks like you failed $num_failed test$s of $Expected_Tests.
1505FAIL
1506        }
1507
1508        if( $Test_Died ) {
1509            $self->diag(<<"FAIL");
1510Looks like your test died just after $Curr_Test.
1511FAIL
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');
1523Looks like your test died before it could output anything.
1524FAIL
1525        _my_exit( 255 ) && return;
1526    }
1527    else {
1528        $self->diag("No tests run!\n");
1529        _my_exit( 255 ) && return;
1530    }
1531}
1532
1533END {
1534    $Test->_ending if defined $Test and !$Test->no_ending;
1535}
1536
1537=head1 EXIT CODES
1538
1539If all your tests passed, Test::Builder will exit with zero (which is
1540normal).  If anything failed it will exit with how many failed.  If
1541you run less (or more) tests than you planned, the missing (or extras)
1542will be considered failures.  If no tests were ever run Test::Builder
1543will throw a warning and exit with 255.  If the test died, even after
1544having successfully completed all its tests, it will still be
1545considered a failure and will exit with 255.
1546
1547So 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
1553If you fail more than 254 tests, it will be reported as 254.
1554
1555
1556=head1 THREADS
1557
1558In perl 5.8.0 and later, Test::Builder is thread-safe.  The test
1559number is shared amongst all threads.  This means if one thread sets
1560the test number using current_test() they will all be effected.
1561
1562Test::Builder is only thread-aware if threads.pm is loaded I<before>
1563Test::Builder.
1564
1565=head1 EXAMPLES
1566
1567CPAN can provide the best examples.  Test::Simple, Test::More,
1568Test::Exception and Test::Differences all use Test::Builder.
1569
1570=head1 SEE ALSO
1571
1572Test::Simple, Test::More, Test::Harness
1573
1574=head1 AUTHORS
1575
1576Original code by chromatic, maintained by Michael G Schwern
1577E<lt>schwern@pobox.comE<gt>
1578
1579=head1 COPYRIGHT
1580
1581Copyright 2002, 2004 by chromatic E<lt>chromatic@wgz.orgE<gt> and
1582                        Michael G Schwern E<lt>schwern@pobox.comE<gt>.
1583
1584This program is free software; you can redistribute it and/or 
1585modify it under the same terms as Perl itself.
1586
1587See F<http://www.perl.com/perl/misc/Artistic.html>
1588
1589=cut
1590
15911;