view release on metacpan or  search on metacpan

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

    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;
}


#line 1014

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 : 0;
            for ($start..$num-1) {
                $Test_Results[$_] = 1;
            }
        }
    }
    return $Curr_Test;
}


#line 1047

sub summary {
    my($self) = shift;

    return @Test_Results;
}

#line 1087

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

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

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

#line 1107

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

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

#line 1119

#line 1133

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

#line 1152

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

#line 1173

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

    return 1;
}


#line 1186

$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();

    # Bailout if plan() was never called.  This is so
    # "require Test::Simple" doesn't puke.
    do{ _my_exit(0) && return } if !$Have_Plan;

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

        # 5.8.0 threads bug.  Shared arrays will not be auto-extended 
        # by a slice.
        $Test_Results[$Expected_Tests-1] = undef
          unless defined $Test_Results[$Expected_Tests-1];

        my $num_failed = grep !$_, @Test_Results[0..$Expected_Tests-1];
        $num_failed += abs($Expected_Tests - @Test_Results);

        if( $Curr_Test < $Expected_Tests ) {
            $self->diag(<<"FAIL");
Looks like you planned $Expected_Tests tests but only ran $Curr_Test.
FAIL
        }
        elsif( $Curr_Test > $Expected_Tests ) {
            my $num_extra = $Curr_Test - $Expected_Tests;
            $self->diag(<<"FAIL");
Looks like you planned $Expected_Tests tests but ran $num_extra extra.
FAIL
        }
        elsif ( $num_failed ) {
            $self->diag(<<"FAIL");
Looks like you failed $num_failed tests 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;
    }