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 |