1use strict;
2
3package Test::Tester::Capture;
4
5our $VERSION = '1.302175';
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	*share = sub { 0 };
17	*lock  = sub { 0 };
18}
19
20my $Curr_Test = 0;      share($Curr_Test);
21my @Test_Results = ();  share(@Test_Results);
22my $Prem_Diag = {diag => ""};	 share($Curr_Test);
23
24sub 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  my $class = shift;
36  return bless {}, $class;
37}
38
39sub ok {
40	my($self, $test, $name) = @_;
41
42	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	$test = $test ? 1 : 0;
47
48	lock $Curr_Test;
49	$Curr_Test++;
50
51	my($pack, $file, $line) = $self->caller;
52
53	my $todo = $self->todo();
54
55	my $result = {};
56	share($result);
57
58	unless( $test ) {
59		@$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
60	}
61	else {
62		@$result{ 'ok', 'actual_ok' } = ( 1, $test );
63	}
64
65	if( defined $name ) {
66		$name =~ s|#|\\#|g;	 # # in a name can confuse Test::Harness.
67		$result->{name} = $name;
68	}
69	else {
70		$result->{name} = '';
71	}
72
73	if( $todo ) {
74		my $what_todo = $todo;
75		$result->{reason} = $what_todo;
76		$result->{type}   = 'todo';
77	}
78	else {
79		$result->{reason} = '';
80		$result->{type}   = '';
81	}
82
83	$Test_Results[$Curr_Test-1] = $result;
84
85	unless( $test ) {
86		my $msg = $todo ? "Failed (TODO)" : "Failed";
87		$result->{fail_diag} = ("	$msg test ($file at line $line)\n");
88	}
89
90	$result->{diag} = "";
91	$result->{_level} = $Test::Builder::Level;
92	$result->{_depth} = Test::Tester::find_run_tests();
93
94	$ctx->release;
95
96	return $test ? 1 : 0;
97}
98
99sub skip {
100	my($self, $why) = @_;
101	$why ||= '';
102
103	my $ctx = $self->ctx;
104
105	lock($Curr_Test);
106	$Curr_Test++;
107
108	my %result;
109	share(%result);
110	%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	$Test_Results[$Curr_Test-1] = \%result;
121
122	$ctx->release;
123	return 1;
124}
125
126sub todo_skip {
127	my($self, $why) = @_;
128	$why ||= '';
129
130	my $ctx = $self->ctx;
131
132	lock($Curr_Test);
133	$Curr_Test++;
134
135	my %result;
136	share(%result);
137	%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	$Test_Results[$Curr_Test-1] = \%result;
149
150	$ctx->release;
151	return 1;
152}
153
154sub diag {
155	my($self, @msgs) = @_;
156	return unless @msgs;
157
158	# Prevent printing headers when compiling (i.e. -c)
159	return if $^C;
160
161	my $ctx = $self->ctx;
162
163	# Escape each line with a #.
164	foreach (@msgs) {
165		$_ = 'undef' unless defined;
166	}
167
168	push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/;
169
170	my $result = $Curr_Test ? $Test_Results[$Curr_Test - 1] : $Prem_Diag;
171
172	$result->{diag} .= join("", @msgs);
173
174	$ctx->release;
175	return 0;
176}
177
178sub details {
179	return @Test_Results;
180}
181
182
183# Stub. Feel free to send me a patch to implement this.
184sub note {
185}
186
187sub explain {
188	return Test::Builder::explain(@_);
189}
190
191sub premature
192{
193	return $Prem_Diag->{diag};
194}
195
196sub current_test
197{
198	if (@_ > 1)
199	{
200		die "Don't try to change the test number!";
201	}
202	else
203	{
204		return $Curr_Test;
205	}
206}
207
208sub reset
209{
210	$Curr_Test = 0;
211	@Test_Results = ();
212	$Prem_Diag = {diag => ""};
213}
214
2151;
216
217__END__
218
219=head1 NAME
220
221Test::Tester::Capture - Help testing test modules built with Test::Builder
222
223=head1 DESCRIPTION
224
225This is a subclass of Test::Builder that overrides many of the methods so
226that they don't output anything. It also keeps track of its own set of test
227results so that you can use Test::Builder based modules to perform tests on
228other Test::Builder based modules.
229
230=head1 AUTHOR
231
232Most of the code here was lifted straight from Test::Builder and then had
233chunks removed by Fergal Daly <fergal@esatclear.ie>.
234
235=head1 LICENSE
236
237Under the same license as Perl itself
238
239See http://www.perl.com/perl/misc/Artistic.html
240
241=cut
242