Move Test::Simple from lib to ext.

[p5sagit/p5-mst-13.2.git] / ext / Test-Simple / t / lib / Test / Builder / NoOutput.pm

package Test::Builder::NoOutput;

use strict;
use warnings;

use base qw(Test::Builder);


=head1 NAME

Test::Builder::NoOutput - A subclass of Test::Builder which prints nothing

=head1 SYNOPSIS

    use Test::Builder::NoOutput;

    my $tb = Test::Builder::NoOutput->new;

    ...test as normal...

    my $output = $tb->read;

=head1 DESCRIPTION

This is a subclass of Test::Builder which traps all its output.
It is mostly useful for testing Test::Builder.

=head3 read

    my $all_output = $tb->read;
    my $output     = $tb->read($stream);

Returns all the output (including failure and todo output) collected
so far.  It is destructive, each call to read clears the output
buffer.

If $stream is given it will return just the output from that stream.
$stream's are...

    out         output()
    err         failure_output()
    todo        todo_output()
    all         all outputs

Defaults to 'all'.

=cut

my $Test = __PACKAGE__->new;

sub create {
    my $class = shift;
    my $self = $class->SUPER::create(@_);

    my %outputs = (
        all  => '',
        out  => '',
        err  => '',
        todo => '',
    );
    $self->{_outputs} = \%outputs;

    tie *OUT,  "Test::Builder::NoOutput::Tee", \$outputs{all}, \$outputs{out};
    tie *ERR,  "Test::Builder::NoOutput::Tee", \$outputs{all}, \$outputs{err};
    tie *TODO, "Test::Builder::NoOutput::Tee", \$outputs{all}, \$outputs{todo};

    $self->output(*OUT);
    $self->failure_output(*ERR);
    $self->todo_output(*TODO);

    return $self;
}

sub read {
    my $self = shift;
    my $stream = @_ ? shift : 'all';

    my $out = $self->{_outputs}{$stream};

    $self->{_outputs}{$stream} = '';

    # Clear all the streams if 'all' is read.
    if( $stream eq 'all' ) {
        my @keys = keys %{$self->{_outputs}};
        $self->{_outputs}{$_} = '' for @keys;
    }

    return $out;
}


package Test::Builder::NoOutput::Tee;

# A cheap implementation of IO::Tee.

sub TIEHANDLE {
    my($class, @refs) = @_;

    my @fhs;
    for my $ref (@refs) {
        my $fh = Test::Builder->_new_fh($ref);
        push @fhs, $fh;
    }

    my $self = [@fhs];
    return bless $self, $class;
}

sub PRINT {
    my $self = shift;

    print $_ @_ for @$self;
}

sub PRINTF {
    my $self   = shift;
    my $format = shift;

    printf $_ @_ for @$self;
}

1;