1use strict; 2 3package Test::Tester::Capture; 4 5use Test::Builder; 6 7use vars qw( @ISA ); 8@ISA = qw( Test::Builder ); 9 10# Make Test::Tester::Capture thread-safe for ithreads. 11BEGIN { 12 use Config; 13 if( $] >= 5.008 && $Config{useithreads} ) { 14 require threads; 15 require threads::shared; 16 threads::shared->import; 17 } 18 else { 19 *share = sub { 0 }; 20 *lock = sub { 0 }; 21 } 22} 23 24my $Curr_Test = 0; share($Curr_Test); 25my @Test_Results = (); share(@Test_Results); 26my $Prem_Diag = {diag => ""}; share($Curr_Test); 27 28sub new 29{ 30 # Test::Tester::Capgture::new used to just return __PACKAGE__ 31 # because Test::Builder::new enforced it's singleton nature by 32 # return __PACKAGE__. That has since changed, Test::Builder::new now 33 # returns a blessed has and around version 0.78, Test::Builder::todo 34 # started wanting to modify $self. To cope with this, we now return 35 # a blessed hash. This is a short-term hack, the correct thing to do 36 # is to detect which style of Test::Builder we're dealing with and 37 # act appropriately. 38 39 my $class = shift; 40 return bless {}, $class; 41} 42 43sub ok { 44 my($self, $test, $name) = @_; 45 46 # $test might contain an object which we don't want to accidentally 47 # store, so we turn it into a boolean. 48 $test = $test ? 1 : 0; 49 50 lock $Curr_Test; 51 $Curr_Test++; 52 53 my($pack, $file, $line) = $self->caller; 54 55 my $todo = $self->todo($pack); 56 57 my $result = {}; 58 share($result); 59 60 unless( $test ) { 61 @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 ); 62 } 63 else { 64 @$result{ 'ok', 'actual_ok' } = ( 1, $test ); 65 } 66 67 if( defined $name ) { 68 $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. 69 $result->{name} = $name; 70 } 71 else { 72 $result->{name} = ''; 73 } 74 75 if( $todo ) { 76 my $what_todo = $todo; 77 $result->{reason} = $what_todo; 78 $result->{type} = 'todo'; 79 } 80 else { 81 $result->{reason} = ''; 82 $result->{type} = ''; 83 } 84 85 $Test_Results[$Curr_Test-1] = $result; 86 87 unless( $test ) { 88 my $msg = $todo ? "Failed (TODO)" : "Failed"; 89 $result->{fail_diag} = (" $msg test ($file at line $line)\n"); 90 } 91 92 $result->{diag} = ""; 93 $result->{_level} = $Test::Builder::Level; 94 $result->{_depth} = Test::Tester::find_run_tests(); 95 96 return $test ? 1 : 0; 97} 98 99sub skip { 100 my($self, $why) = @_; 101 $why ||= ''; 102 103 lock($Curr_Test); 104 $Curr_Test++; 105 106 my %result; 107 share(%result); 108 %result = ( 109 'ok' => 1, 110 actual_ok => 1, 111 name => '', 112 type => 'skip', 113 reason => $why, 114 diag => "", 115 _level => $Test::Builder::Level, 116 _depth => Test::Tester::find_run_tests(), 117 ); 118 $Test_Results[$Curr_Test-1] = \%result; 119 120 return 1; 121} 122 123sub todo_skip { 124 my($self, $why) = @_; 125 $why ||= ''; 126 127 lock($Curr_Test); 128 $Curr_Test++; 129 130 my %result; 131 share(%result); 132 %result = ( 133 'ok' => 1, 134 actual_ok => 0, 135 name => '', 136 type => 'todo_skip', 137 reason => $why, 138 diag => "", 139 _level => $Test::Builder::Level, 140 _depth => Test::Tester::find_run_tests(), 141 ); 142 143 $Test_Results[$Curr_Test-1] = \%result; 144 145 return 1; 146} 147 148sub diag { 149 my($self, @msgs) = @_; 150 return unless @msgs; 151 152 # Prevent printing headers when compiling (i.e. -c) 153 return if $^C; 154 155 # Escape each line with a #. 156 foreach (@msgs) { 157 $_ = 'undef' unless defined; 158 } 159 160 push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/; 161 162 my $result = $Curr_Test ? $Test_Results[$Curr_Test - 1] : $Prem_Diag; 163 164 $result->{diag} .= join("", @msgs); 165 166 return 0; 167} 168 169sub details { 170 return @Test_Results; 171} 172 173sub premature 174{ 175 return $Prem_Diag->{diag}; 176} 177 178sub current_test 179{ 180 if (@_ > 1) 181 { 182 die "Don't try to change the test number!"; 183 } 184 else 185 { 186 return $Curr_Test; 187 } 188} 189 190sub reset 191{ 192 $Curr_Test = 0; 193 @Test_Results = (); 194 $Prem_Diag = {diag => ""}; 195} 196 1971; 198 199__END__ 200 201=head1 NAME 202 203Test::Tester::Capture - Help testing test modules built with Test::Builder 204 205=head1 DESCRIPTION 206 207This is a subclass of Test::Builder that overrides many of the methods so 208that they don't output anything. It also keeps track of it's own set of test 209results so that you can use Test::Builder based modules to perform tests on 210other Test::Builder based modules. 211 212=head1 AUTHOR 213 214Most of the code here was lifted straight from Test::Builder and then had 215chunks removed by Fergal Daly <fergal@esatclear.ie>. 216 217=head1 LICENSE 218 219Under the same license as Perl itself 220 221See http://www.perl.com/perl/misc/Artistic.html 222 223=cut 224