File Coverage

lib/Test/Tester/Capture.pm
Criterion Covered Total %
statement 87 91 95.6
branch 21 28 75.0
condition 2 4 50.0
subroutine 16 18 88.8
pod 10 11 90.9
total 136 152 89.4


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