1package Test::Builder::NoOutput; 2 3use strict; 4use warnings; 5 6use Symbol qw(gensym); 7use base qw(Test::Builder); 8 9 10=head1 NAME 11 12Test::Builder::NoOutput - A subclass of Test::Builder which prints nothing 13 14=head1 SYNOPSIS 15 16 use Test::Builder::NoOutput; 17 18 my $tb = Test::Builder::NoOutput->new; 19 20 ...test as normal... 21 22 my $output = $tb->read; 23 24=head1 DESCRIPTION 25 26This is a subclass of Test::Builder which traps all its output. 27It is mostly useful for testing Test::Builder. 28 29=head3 read 30 31 my $all_output = $tb->read; 32 my $output = $tb->read($stream); 33 34Returns all the output (including failure and todo output) collected 35so far. It is destructive, each call to read clears the output 36buffer. 37 38If $stream is given it will return just the output from that stream. 39$stream's are... 40 41 out output() 42 err failure_output() 43 todo todo_output() 44 all all outputs 45 46Defaults to 'all'. 47 48=cut 49 50my $Test = __PACKAGE__->new; 51 52sub create { 53 my $class = shift; 54 my $self = $class->SUPER::create(@_); 55 56 my %outputs = ( 57 all => '', 58 out => '', 59 err => '', 60 todo => '', 61 ); 62 $self->{_outputs} = \%outputs; 63 64 my($out, $err, $todo) = map { gensym() } 1..3; 65 tie *$out, "Test::Builder::NoOutput::Tee", \$outputs{all}, \$outputs{out}; 66 tie *$err, "Test::Builder::NoOutput::Tee", \$outputs{all}, \$outputs{err}; 67 tie *$todo, "Test::Builder::NoOutput::Tee", \$outputs{all}, \$outputs{todo}; 68 69 $self->output($out); 70 $self->failure_output($err); 71 $self->todo_output($todo); 72 73 return $self; 74} 75 76 77sub read { 78 my $self = shift; 79 my $stream = @_ ? shift : 'all'; 80 81 my $out = $self->{_outputs}{$stream}; 82 83 $self->{_outputs}{$stream} = ''; 84 85 # Clear all the streams if 'all' is read. 86 if( $stream eq 'all' ) { 87 my @keys = keys %{$self->{_outputs}}; 88 $self->{_outputs}{$_} = '' for @keys; 89 } 90 91 return $out; 92} 93 94 95package Test::Builder::NoOutput::Tee; 96 97# A cheap implementation of IO::Tee. 98 99sub TIEHANDLE { 100 my($class, @refs) = @_; 101 102 my @fhs; 103 for my $ref (@refs) { 104 my $fh = Test::Builder->_new_fh($ref); 105 push @fhs, $fh; 106 } 107 108 my $self = [@fhs]; 109 return bless $self, $class; 110} 111 112sub PRINT { 113 my $self = shift; 114 115 print $_ @_ for @$self; 116} 117 118sub PRINTF { 119 my $self = shift; 120 my $format = shift; 121 122 printf $_ @_ for @$self; 123} 124 1251; 126