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