File Coverage

inc/Test/Tester.pm
Criterion Covered Total %
statement 89 118 75.4
branch 13 32 40.6
condition 2 12 16.6
subroutine 18 22 81.8
pod 6 13 46.1
total 128 197 64.9


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