view release on metacpan or  search on metacpan

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

sub _print {
    my($self, @msgs) = @_;

    # Prevent printing headers when only compiling.  Mostly for when
    # tests are deparsed with B::Deparse
    return if $^C;

    local($\, $", $,) = (undef, ' ', '');
    my $fh = $self->output;

    # Escape each line after the first with a # so we don't
    # confuse Test::Harness.
    foreach (@msgs) {
        s/\n(.)/\n# $1/sg;
    }

    push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/;

    print $fh @msgs;
}



my($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;
    unless( UNIVERSAL::isa($file_or_fh, 'GLOB') ) {
        $fh = do { local *FH };
        open $fh, ">$file_or_fh" or 
            die "Can't open test output log $file_or_fh: $!";
    }
    else {
        $fh = $file_or_fh;
    }

    return $fh;
}

unless( $^C ) {
    # 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;
            }
        }