1#line 1
2use strict;
3
4package Test::Tester;
5
6BEGIN
7{
8	if (*Test::Builder::new{CODE})
9	{
10		warn "You should load Test::Tester before Test::Builder (or anything that loads Test::Builder)"
11	}
12}
13
14use Test::Builder;
15use Test::Tester::CaptureRunner;
16use Test::Tester::Delegate;
17
18require Exporter;
19
20use vars qw( @ISA @EXPORT $VERSION );
21
22$VERSION = "0.107";
23@EXPORT = qw( run_tests check_tests check_test cmp_results show_space );
24@ISA = qw( Exporter );
25
26my $Test = Test::Builder->new;
27my $Capture = Test::Tester::Capture->new;
28my $Delegator = Test::Tester::Delegate->new;
29$Delegator->{Object} = $Test;
30
31my $runner = Test::Tester::CaptureRunner->new;
32
33my $want_space = $ENV{TESTTESTERSPACE};
34
35sub show_space
36{
37	$want_space = 1;
38}
39
40my $colour = '';
41my $reset = '';
42
43if (my $want_colour = $ENV{TESTTESTERCOLOUR} || $ENV{TESTTESTERCOLOUR})
44{
45	if (eval "require Term::ANSIColor")
46	{
47		my ($f, $b) = split(",", $want_colour);
48		$colour = Term::ANSIColor::color($f).Term::ANSIColor::color("on_$b");
49		$reset = Term::ANSIColor::color("reset");
50	}
51
52}
53
54sub new_new
55{
56	return $Delegator;
57}
58
59sub capture
60{
61	return Test::Tester::Capture->new;
62}
63
64sub fh
65{
66	# experiment with capturing output, I don't like it
67	$runner = Test::Tester::FHRunner->new;
68
69	return $Test;
70}
71
72sub find_run_tests
73{
74	my $d = 1;
75	my $found = 0;
76	while ((not $found) and (my ($sub) = (caller($d))[3]) )
77	{
78#		print "$d: $sub\n";
79		$found = ($sub eq "Test::Tester::run_tests");
80		$d++;
81	}
82
83#	die "Didn't find 'run_tests' in caller stack" unless $found;
84	return $d;
85}
86
87sub run_tests
88{
89	local($Delegator->{Object}) = $Capture;
90
91	$runner->run_tests(@_);
92
93	return ($runner->get_premature, $runner->get_results);
94}
95
96sub check_test
97{
98	my $test = shift;
99	my $expect = shift;
100	my $name = shift;
101	$name = "" unless defined($name);
102
103	@_ = ($test, [$expect], $name);
104	goto &check_tests;
105}
106
107sub check_tests
108{
109	my $test = shift;
110	my $expects = shift;
111	my $name = shift;
112	$name = "" unless defined($name);
113
114	my ($prem, @results) = eval { run_tests($test, $name) };
115
116	$Test->ok(! $@, "Test '$name' completed") || $Test->diag($@);
117	$Test->ok(! length($prem), "Test '$name' no premature diagnostication") ||
118		$Test->diag("Before any testing anything, your tests said\n$prem");
119
120	local $Test::Builder::Level = $Test::Builder::Level + 1;
121	cmp_results(\@results, $expects, $name);
122	return ($prem, @results);
123}
124
125sub cmp_field
126{
127	my ($result, $expect, $field, $desc) = @_;
128
129	if (defined $expect->{$field})
130	{
131		$Test->is_eq($result->{$field}, $expect->{$field},
132			"$desc compare $field");
133	}
134}
135
136sub cmp_result
137{
138	my ($result, $expect, $name) = @_;
139
140	my $sub_name = $result->{name};
141	$sub_name = "" unless defined($name);
142
143	my $desc = "subtest '$sub_name' of '$name'";
144
145	{
146		local $Test::Builder::Level = $Test::Builder::Level + 1;
147
148		cmp_field($result, $expect, "ok", $desc);
149
150		cmp_field($result, $expect, "actual_ok", $desc);
151
152		cmp_field($result, $expect, "type", $desc);
153
154		cmp_field($result, $expect, "reason", $desc);
155
156		cmp_field($result, $expect, "name", $desc);
157	}
158
159	# if we got no depth then default to 1
160	my $depth = 1;
161	if (exists $expect->{depth})
162	{
163		$depth = $expect->{depth};
164	}
165
166	# if depth was explicitly undef then don't test it
167	if (defined $depth)
168	{
169		$Test->is_eq($result->{depth}, $depth, "checking depth") ||
170			$Test->diag('You need to change $Test::Builder::Level');
171	}
172
173	if (defined(my $exp = $expect->{diag}))
174	{
175		# if there actually is some diag then put a \n on the end if it's not
176		# there already
177
178		$exp .= "\n" if (length($exp) and $exp !~ /\n$/);
179		if (not $Test->ok($result->{diag} eq $exp,
180			"subtest '$sub_name' of '$name' compare diag")
181		)
182		{
183			my $got = $result->{diag};
184			my $glen = length($got);
185			my $elen = length($exp);
186			for ($got, $exp)
187			{
188				my @lines = split("\n", $_);
189	 			$_ = join("\n", map {
190					if ($want_space)
191					{
192						$_ = $colour.escape($_).$reset;
193					}
194					else
195					{
196						"'$colour$_$reset'"
197					}
198				} @lines);
199			}
200
201			$Test->diag(<<EOM);
202Got diag ($glen bytes):
203$got
204Expected diag ($elen bytes):
205$exp
206EOM
207
208		}
209	}
210}
211
212sub escape
213{
214	my $str = shift;
215	my $res = '';
216	for my $char (split("", $str))
217	{
218		my $c = ord($char);
219		if(($c>32 and $c<125) or $c == 10)
220		{
221			$res .= $char;
222		}
223		else
224		{
225			$res .= sprintf('\x{%x}', $c)
226		}
227	}
228	return $res;
229}
230
231sub cmp_results
232{
233	my ($results, $expects, $name) = @_;
234
235	$Test->is_num(scalar @$results, scalar @$expects, "Test '$name' result count");
236
237	for (my $i = 0; $i < @$expects; $i++)
238	{
239		my $expect = $expects->[$i];
240		my $result = $results->[$i];
241
242		local $Test::Builder::Level = $Test::Builder::Level + 1;
243		cmp_result($result, $expect, $name);
244	}
245}
246
247######## nicked from Test::More
248sub plan {
249	my(@plan) = @_;
250
251	my $caller = caller;
252
253	$Test->exported_to($caller);
254
255	my @imports = ();
256	foreach my $idx (0..$#plan) {
257		if( $plan[$idx] eq 'import' ) {
258			my($tag, $imports) = splice @plan, $idx, 2;
259			@imports = @$imports;
260			last;
261		}
262	}
263
264	$Test->plan(@plan);
265
266	__PACKAGE__->_export_to_level(1, __PACKAGE__, @imports);
267}
268
269sub import {
270	my($class) = shift;
271		{
272			no warnings 'redefine';
273			*Test::Builder::new = \&new_new;
274		}
275	goto &plan;
276}
277
278sub _export_to_level
279{
280        my $pkg = shift;
281	my $level = shift;
282	(undef) = shift;	# redundant arg
283	my $callpkg = caller($level);
284	$pkg->export($callpkg, @_);
285}
286
287
288############
289
2901;
291
292__END__
293
294#line 645
295