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