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