Like _print, but prints to the current diagnostic filehandle.=cutsub _print_diag {    my $self = shift;    local($\, $", $,) = (undef, ' ', '');    my $fh = $self->todo ? $self->todo_output : $self->failure_output;    print $fh @_;}    =item B<output>    $Test->output($fh);    $Test->output($file);Where normal "ok/not ok" test output should go.Defaults to STDOUT.=item B<failure_output>    $Test->failure_output($fh);    $Test->failure_output($file);Where diagnostic output on test failures and diag() should go.Defaults to STDERR.=item B<todo_output>    $Test->todo_output($fh);    $Test->todo_output($file);Where diagnostics about todo test failures and diag() should go.Defaults to STDOUT.=cutmy($Out_FH, $Fail_FH, $Todo_FH);sub output {    my($self, $fh) = @_;    if( defined $fh ) {        $Out_FH = _new_fh($fh);    }    return $Out_FH;}sub failure_output {    my($self, $fh) = @_;    if( defined $fh ) {        $Fail_FH = _new_fh($fh);    }    return $Fail_FH;}sub todo_output {    my($self, $fh) = @_;    if( defined $fh ) {        $Todo_FH = _new_fh($fh);    }    return $Todo_FH;}sub _new_fh {    my($file_or_fh) = shift;    my $fh;    if( _is_fh($file_or_fh) ) {        $fh = $file_or_fh;    }    else {        $fh = do { local *FH };        open $fh, ">$file_or_fh" or             die "Can't open test output log $file_or_fh: $!";    }    return $fh;}sub _is_fh {    my $maybe_fh = shift;    return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob    return UNIVERSAL::isa($maybe_fh,               'GLOB')       ||           UNIVERSAL::isa($maybe_fh,               'IO::Handle') ||           # 5.5.4's tied() and can() doesn't like getting undef           UNIVERSAL::can((tied($maybe_fh) || ''), 'TIEHANDLE');}sub _autoflush {    my($fh) = shift;    my $old_fh = select $fh;    $| = 1;    select $old_fh;}my $Opened_Testhandles = 0;sub _dup_stdhandles {    my $self = shift;    $self->_open_testhandles unless $Opened_Testhandles;    # Set everything to unbuffered else plain prints to STDOUT will    # come out in the wrong order from our own prints.    _autoflush(\*TESTOUT);    _autoflush(\*STDOUT);    _autoflush(\*TESTERR);    _autoflush(\*STDERR);    $Test->output(\*TESTOUT);    $Test->failure_output(\*TESTERR);    $Test->todo_output(\*TESTOUT);}sub _open_testhandles {    # We dup STDOUT and STDERR so people can change them in their    # test suites while still getting normal test output.    open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT:  $!";    open(TESTERR, ">&STDERR") or die "Can't dup STDERR:  $!";    $Opened_Testhandles = 1;}=back=head2 Test Status and Info=over 4=item B<current_test>    my $curr_test = $Test->current_test;    $Test->current_test($num);Gets/sets the current test number we're on.  You usually shouldn'thave to set this.If set forward, the details of the missing tests are filled in as 'unknown'.if set backward, the details of the intervening tests are deleted.  Youcan erase history if you really want to.=cutsub current_test {    my($self, $num) = @_;    lock($Curr_Test);    if( defined $num ) {        unless( $Have_Plan ) {            require Carp;            Carp::croak("Can't change the current test number without a plan!");        }        $Curr_Test = $num;        # If the test counter is being pushed forward fill in the details.        if( $num > @Test_Results ) {            my $start = @Test_Results ? $#Test_Results + 1 : 0;            for ($start..$num-1) {                $Test_Results[$_] = &share({                    'ok'      => 1,                     actual_ok => undef,                     reason    => 'incrementing test number',                     type      => 'unknown',                     name      => undef                 });            }        }        # If backward, wipe history.  Its their funeral.        elsif( $num < @Test_Results ) {            $#Test_Results = $num - 1;        }    }    return $Curr_Test;}=item B<summary>    my @tests = $Test->summary;A simple summary of the tests so far.  True for pass, false for fail.This is a logical pass/fail, so todos are passes.Of course, test #1 is $tests[0], etc...=cutsub summary {    my($self) = shift;    return map { $_->{'ok'} } @Test_Results;}=item B<details>    my @tests = $Test->details;Like summary(), but with a lot more detail.    $tests[$test_num - 1] =             { 'ok'       => is the test considered a pass?              actual_ok  => did it literally say 'ok'?              name       => name of the test (if any)              type       => type of test (if any, see below).              reason     => reason for the above (if any)            };'ok' is true if Test::Harness will consider the test to be a pass.'actual_ok' is a reflection of whether or not the test literallyprinted 'ok' or 'not ok'.  This is for examining the result of 'todo'tests.  'name' is the name of the test.'type' indicates if it was a special test.  Normal tests have a typeof ''.  Type can be one of the following:    skip        see skip()    todo        see todo()    todo_skip   see todo_skip()    unknown     see belowSometimes the Test::Builder test counter is incremented without itprinting any test output, for example, when current_test() is changed.In these cases, Test::Builder doesn't know the result of the test, soit's type is 'unkown'.  These details for these tests are filled in.They are considered ok, but the name and actual_ok is left undef.For example "not ok 23 - hole count # TODO insufficient donuts" wouldresult in this structure:    $tests[22] =    # 23 - 1, since arrays start from 0.      { ok        => 1,   # logically, the test passed since it's todo        actual_ok => 0,   # in absolute terms, it failed        name      => 'hole count',        type      => 'todo',        reason    => 'insufficient donuts'      };=cutsub details {    return @Test_Results;}=item B<todo>    my $todo_reason = $Test->todo;    my $todo_reason = $Test->todo($pack);todo() looks for a $TODO variable in your tests.  If set, all testswill be considered 'todo' (see Test::More and Test::Harness fordetails).  Returns the reason (ie. the value of $TODO) if running astodo tests, false otherwise.todo() is pretty part about finding the right package to look for$TODO in.  It uses the exported_to() package to find it.  If that'snot set, it's pretty good at guessing the right package to look at.Sometimes there is some confusion about where todo() should be lookingfor the $TODO variable.  If you want to be sure, tell it explicitlywhat $pack to use.=cutsub todo {    my($self, $pack) = @_;    $pack = $pack || $self->exported_to || $self->caller(1);    no strict 'refs';    return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}                                     : 0;}=item B<caller>    my $package = $Test->caller;    my($pack, $file, $line) = $Test->caller;    my($pack, $file, $line) = $Test->caller($height);Like the normal caller(), except it reports according to your level().=cutsub caller {    my($self, $height) = @_;    $height ||= 0;    my @caller = CORE::caller($self->level + $height + 1);    return wantarray ? @caller : $caller[0];}=back=cut=begin _private=over 4=item B<_sanity_check>  _sanity_check();Runs a bunch of end of test sanity checks to make sure reality camethrough ok.  If anything is wrong it will die with a fairly friendlyerror message.=cut#'#sub _sanity_check {    _whoa($Curr_Test < 0,  'Says here you ran a negative number of tests!');    _whoa(!$Have_Plan and $Curr_Test,           'Somehow your tests ran without a plan!');    _whoa($Curr_Test != @Test_Results,          'Somehow you got a different number of results than tests ran!');}=item B<_whoa>  _whoa($check, $description);A sanity check, similar to assert().  If the $check is true, somethinghas gone horribly wrong.  It will die with the given $description anda note to contact the author.=cutsub _whoa {    my($check, $desc) = @_;    if( $check ) {        die <<WHOA;WHOA!  $descThis should never happen!  Please contact the author immediately!WHOA    }}=item B<_my_exit>  _my_exit($exit_num);Perl seems to have some trouble with exiting inside an END block.  5.005_03and 5.6.1 both seem to do odd things.  Instead, this function edits $?directly.  It should ONLY be called from inside an END block.  Itdoesn't actually exit, that's your job.=cutsub _my_exit {    $? = $_[0];    return 1;}=back=end _private=cut$SIG{__DIE__} = sub {    # We don't want to muck with death in an eval, but $^S isn't    # totally reliable.  5.005_03 and 5.6.1 both do the wrong thing    # with it.  Instead, we use caller.  This also means it runs under    # 5.004!    my $in_eval = 0;    for( my $stack = 1;  my $sub = (CORE::caller($stack))[3];  $stack++ ) {        $in_eval = 1 if $sub =~ /^\(eval\)/;    }    $Test_Died = 1 unless $in_eval;};sub _ending {    my $self = shift;    _sanity_check();    # Don't bother with an ending if this is a forked copy.  Only the parent    # should do the ending.    do{ _my_exit($?) && return } if $Original_Pid != $$;    # Bailout if plan() was never called.  This is so    # "require Test::Simple" doesn't puke.    do{ _my_exit(0) && return } if !$Have_Plan && !$Test_Died;    # Figure out if we passed or failed and print helpful messages.    if( @Test_Results ) {        # The plan?  We have no plan.        if( $No_Plan ) {            $self->_print("1..$Curr_Test\n") unless $self->no_header;            $Expected_Tests = $Curr_Test;        }        # Auto-extended arrays and elements which aren't explicitly        # filled in with a shared reference will puke under 5.8.0        # ithreads.  So we have to fill them in by hand. :(        my $empty_result = &share({});        for my $idx ( 0..$Expected_Tests-1 ) {            $Test_Results[$idx] = $empty_result              unless defined $Test_Results[$idx];        }        my $num_failed = grep !$_->{'ok'}, @Test_Results[0..$Expected_Tests-1];        $num_failed += abs($Expected_Tests - @Test_Results);        if( $Curr_Test < $Expected_Tests ) {            my $s = $Expected_Tests == 1 ? '' : 's';            $self->diag(<<"FAIL");Looks like you planned $Expected_Tests test$s but only ran $Curr_Test.FAIL        }        elsif( $Curr_Test > $Expected_Tests ) {            my $num_extra = $Curr_Test - $Expected_Tests;            my $s = $Expected_Tests == 1 ? '' : 's';            $self->diag(<<"FAIL");Looks like you planned $Expected_Tests test$s but ran $num_extra extra.FAIL        }        elsif ( $num_failed ) {            my $s = $num_failed == 1 ? '' : 's';            $self->diag(<<"FAIL");Looks like you failed $num_failed test$s of $Expected_Tests.FAIL        }        if( $Test_Died ) {            $self->diag(<<"FAIL");Looks like your test died just after $Curr_Test.FAIL            _my_exit( 255 ) && return;        }        _my_exit( $num_failed <= 254 ? $num_failed : 254  ) && return;    }    elsif ( $Skip_All ) {        _my_exit( 0 ) && return;    }    elsif ( $Test_Died ) {        $self->diag(<<'FAIL');Looks like your test died before it could output anything.FAIL        _my_exit( 255 ) && return;    }    else {        $self->diag("No tests run!\n");        _my_exit( 255 ) && return;    }}END {    $Test->_ending if defined $Test and !$Test->no_ending;}=head1 EXIT CODESIf all your tests passed, Test::Builder will exit with zero (which isnormal).  If anything failed it will exit with how many failed.  Ifyou run less (or more) tests than you planned, the missing (or extras)will be considered failures.  If no tests were ever run Test::Builderwill throw a warning and exit with 255.  If the test died, even afterhaving successfully completed all its tests, it will still beconsidered a failure and will exit with 255.So the exit codes are...    0                   all tests successful    255                 test died    any other number    how many failed (including missing or extras)If you fail more than 254 tests, it will be reported as 254.=head1 THREADSIn perl 5.8.0 and later, Test::Builder is thread-safe.  The testnumber is shared amongst all threads.  This means if one thread setsthe test number using current_test() they will all be effected.Test::Builder is only thread-aware if threads.pm is loaded I<before>Test::Builder.=head1 EXAMPLESCPAN can provide the best examples.  Test::Simple, Test::More,Test::Exception and Test::Differences all use Test::Builder.=head1 SEE ALSOTest::Simple, Test::More, Test::Harness=head1 AUTHORSOriginal code by chromatic, maintained by Michael G SchwernE<lt>schwern@pobox.comE<gt>=head1 COPYRIGHTCopyright 2002, 2004 by chromatic E<lt>chromatic@wgz.orgE<gt> and                        Michael G Schwern E<lt>schwern@pobox.comE<gt>.This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.See F<http://www.perl.com/perl/misc/Artistic.html>=cut1;