view release on metacpan or  search on metacpan

src/inc/Test/Builder.pm  view on Meta::CPAN

    # 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:  $!";

    # 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);

    $CLASS->output(\*TESTOUT);
    $CLASS->failure_output(\*TESTERR);
    $CLASS->todo_output(\*TESTOUT);
}

sub _autoflush {
    my($fh) = shift;
    my $old_fh = select $fh;
    $| = 1;
    select $old_fh;
}



sub 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( $num > @Test_Results ) {
            my $start = @Test_Results ? $#Test_Results + 1 : 0;
            for ($start..$num-1) {
                my %result;
                share(%result);
                %result = ( ok        => 1, 
                            actual_ok => undef, 
                            reason    => 'incrementing test number', 
                            type      => 'unknown', 
                            name      => undef 
                          );
                $Test_Results[$_] = \%result;
            }
        }
    }
    return $Curr_Test;
}



sub summary {
    my($self) = shift;

    return map { $_->{'ok'} } @Test_Results;
}


sub details {
    return @Test_Results;
}


sub todo {
    my($self, $pack) = @_;

    $pack = $pack || $self->exported_to || $self->caller(1);

    no strict 'refs';
    return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
                                     : 0;
}


sub caller {
    my($self, $height) = @_;
    $height ||= 0;

    my @caller = CORE::caller($self->level + $height + 1);
    return wantarray ? @caller : $caller[0];
}

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!');
}


sub _whoa {
    my($check, $desc) = @_;
    if( $check ) {
        die <<WHOA;
WHOA!  $desc
This should never happen!  Please contact the author immediately!
WHOA
    }
}


sub _my_exit {
    $? = $_[0];

    return 1;
}



$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!