view release on metacpan or  search on metacpan

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

    my $fh = $self->todo ? $self->todo_output : $self->failure_output;
    print $fh @_;
}    

#line 1305

sub output {
    my($self, $fh) = @_;

    if( defined $fh ) {
        $self->{Out_FH} = $self->_new_fh($fh);
    }
    return $self->{Out_FH};
}

sub failure_output {
    my($self, $fh) = @_;

    if( defined $fh ) {
        $self->{Fail_FH} = $self->_new_fh($fh);
    }
    return $self->{Fail_FH};
}

sub todo_output {
    my($self, $fh) = @_;

    if( defined $fh ) {
        $self->{Todo_FH} = $self->_new_fh($fh);
    }
    return $self->{Todo_FH};
}


sub _new_fh {
    my $self = shift;
    my($file_or_fh) = shift;

    my $fh;
    if( $self->is_fh($file_or_fh) ) {
        $fh = $file_or_fh;
    }
    else {
        open $fh, ">", $file_or_fh or
            $self->croak("Can't open test output log $file_or_fh: $!");
        _autoflush($fh);
    }

    return $fh;
}


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


my($Testout, $Testerr);
sub _dup_stdhandles {
    my $self = shift;

    $self->_open_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);

    $self->output        ($Testout);
    $self->failure_output($Testerr);
    $self->todo_output   ($Testout);
}


my $Opened_Testhandles = 0;
sub _open_testhandles {
    my $self = shift;
    
    return if $Opened_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:  $!";

#    $self->_copy_io_layers( \*STDOUT, $Testout );
#    $self->_copy_io_layers( \*STDERR, $Testerr );
    
    $Opened_Testhandles = 1;
}


sub _copy_io_layers {
    my($self, $src, $dst) = @_;
    
    $self->_try(sub {
        require PerlIO;
        my @src_layers = PerlIO::get_layers($src);

        binmode $dst, join " ", map ":$_", @src_layers if @src_layers;
    });
}

#line 1423

sub _message_at_caller {
    my $self = shift;

    local $Level = $Level + 1;
    my($pack, $file, $line) = $self->caller;
    return join("", @_) . " at $file line $line.\n";
}

sub carp {
    my $self = shift;
    warn $self->_message_at_caller(@_);
}

sub croak {
    my $self = shift;
    die $self->_message_at_caller(@_);
}

sub _plan_check {
    my $self = shift;

    unless( $self->{Have_Plan} ) {
        local $Level = $Level + 2;
        $self->croak("You tried to run a test without a plan");
    }
}

#line 1471

sub current_test {
    my($self, $num) = @_;

    lock($self->{Curr_Test});
    if( defined $num ) {
        unless( $self->{Have_Plan} ) {
            $self->croak("Can't change the current test number without a plan!");
        }

        $self->{Curr_Test} = $num;

        # If the test counter is being pushed forward fill in the details.
        my $test_results = $self->{Test_Results};