File Coverage

lib/Badger/Test/Manager.pm
Criterion Covered Total %
statement 96 167 57.4
branch 24 56 42.8
condition 15 48 31.2
subroutine 18 25 72.0
pod 21 21 100.0
total 174 317 54.8


line stmt bran cond sub pod time code
1             package Badger::Test::Manager;
2              
3             use Badger::Class
4 70         439 version => 0.01,
5             debug => 1,
6             base => 'Badger::Prototype',
7 70     70   486 import => 'class';
  70         168  
8              
9             use Badger::Rainbow
10 70     70   509 'ANSI_colours ANSI_escape';
  70         146  
  70         546  
11              
12 70     70   12593 eval "use Algorithm::Diff qw( diff )";
  0         0  
  0         0  
13             our $CAN_DIFF = $@ ? 0 : 1;
14             our $ESCAPES = qr/\e\[(.*?)m/; # remove ANSI escapes
15             our $REASON = 'No reason given';
16             our $MESSAGES = {
17             no_plan => "You haven't called plan() yet!\n",
18             dup_plan => "You called plan() twice!\n",
19             plan => "1..%s\n",
20             skip_all => "1..0 # skip %s\n",
21             skip_one => "ok %s # skip %s\n",
22             name => "test %s at %s line %s",
23             ok => "ok %s - %s\n",
24             not_ok => "not ok %s - %s\n%s",
25             not_eq => "# expect: [%s]\n# result: [%s]\n",
26             not_ne => "# unexpected match: [%s]\n",
27             not_like => "# expect: /%s/\n# result: [%s]\n",
28             not_unlike => "# expect: ! /%s/\n# result: [%s]\n",
29             too_few => "# Looks like you planned %s tests but only ran %s.\n",
30             too_many => "# Looks like you planned only %s tests but ran %s.\n",
31             no_result => "# result is undefined\n",
32             pass => "# PASS: All %d tests passed\n",
33             fail => "# FAIL: %d tests failed\n",
34             mess => "# FAIL: Inconsistent test results\n",
35             summary => "# %d/%d tests run, %d passed, %d failed, %d skipped\n",
36             hunk => "# -- diffs %s of %s --\n",
37             delta => "# %s %3d %s\n",
38            
39             };
40             our $SCHEME = {
41             green => 'ok pass',
42             red => 'not_ok too_few too_many fail mess',
43             cyan => 'skip_one skip_all hunk delta',
44             yellow => 'plan not_eq not_ne not_like not_unlike summary',
45             };
46              
47             # Sorry, English and American/Spanish only, no couleur, colori, farbe, etc.
48             *color = \&colour;
49              
50             # for nice cleanup in END block
51             our $INSTANCES = { };
52              
53              
54             #-----------------------------------------------------------------------
55             # constructor method
56             #-----------------------------------------------------------------------
57              
58             sub init {
59 70     70 1 200 my ($self, $config) = @_;
60 70   50     676 $self->{ plan } = $config->{ plan } || 0;
61 70   50     460 $self->{ count } = $config->{ count } || 1;
62 70   50     397 $self->{ results } = $config->{ results } || [ ];
63 70   50     427 $self->{ summary } = $config->{ summary } || 0;
64 70   33     438 $self->{ reason } = $config->{ reason } || $REASON;
65 70   50     684 $self->{ colour } = $config->{ colour } || $config->{ color } || 0;
66 70         291 $INSTANCES->{ $self } = $self;
67 70         287 return $self;
68             }
69              
70              
71             #------------------------------------------------------------------------
72             # plan($n)
73             #
74             # Declare how many (more) tests are expected to come. If ok() is called
75             # before plan() then the results are cached instead of being printed up
76             # front. When plan() is called, the total number of tests (including any
77             # cached) is known and the "1..$n" line can be printed along with any
78             # cached results. After that, calls to ok() generated output immediately.
79             #------------------------------------------------------------------------
80              
81             sub plan ($$;$) {
82 62     62 1 590 my $self = shift->prototype;
83 62         168 my ($tests, $reason) = @_;
84              
85             # calling plan() twice would be ambiguous
86             return $self->error_msg('dup_plan')
87 62 50       230 if $self->{ plan };
88              
89             # if $tests == 0 then skip all
90 62 50       188 return $self->skip_all($reason)
91             unless $tests;
92            
93             # update the plan to account for any tests that have already been run
94 62         98 my $results = $self->{ results };
95 62         133 $tests += @$results;
96 62         231 $self->test_msg( plan => $tests );
97 62         251 $self->{ plan } = $tests;
98 62         154 $self->{ tested } = 0;
99 62         235 $self->{ passed } = 0;
100 62         139 $self->{ failed } = 0;
101 62         134 $self->{ skipped } = 0;
102              
103             # now flush any cached test results
104 62         427 while (@$results) {
105 0         0 my $test = shift @$results;
106 0         0 $self->result(@$test);
107             }
108             }
109              
110             sub ok ($$;$$) {
111 1741     1741 1 3514 my $self = shift->prototype;
112 1741         3247 my ($ok, $name, $detail) = @_;
113 1741   50     5654 $detail ||= '';
114              
115 1741   66     3082 $name ||= $self->test_name;
116              
117 1741 50       2938 if ($self->{ plan }) {
118 1741         3416 $self->result($ok, $self->{ count }, $name, $detail);
119             }
120             else {
121             # cache results if plan() not yet called
122 0         0 push(@{ $self->{ results } }, [ $ok, $self->{ count }, $name, $detail ]);
  0         0  
123             }
124              
125 1741         3269 $self->{ count }++;
126 1741         2209 $self->{ tested }++;
127              
128 1741         10194 return $ok;
129             }
130              
131             sub pass ($;$) {
132 1227     1227 1 2282 shift->ok(1, @_);
133             }
134              
135             sub fail ($;$) {
136 0     0 1 0 shift->ok(0, @_);
137             }
138              
139             sub is ($$$;$) {
140 1157     1157 1 2705 my $self = shift->prototype;
141 1157         2573 my ($result, $expect, $msg) = @_;
142 1157   33     2293 $msg ||= $self->test_name();
143              
144 1157 50       2014 if (! defined $result) {
145 0         0 return $self->fail($msg, $self->message('no_result'));
146             }
147            
148             # force stringification of $result to avoid 'no eq method' overload errors
149 1157 100       2142 $result = "$result" if ref $result;
150              
151             # if we have coloured output enabled then the result might not match
152             # the expected because of embedded ANSI escapes, so we strip them out
153             my ($r, $e) = map {
154 1157 50       1924 s/$ESCAPES//g if $self->{ colour };
  2314         3712  
155 2314         4200 $_
156             } ($result, $expect);
157            
158 1157 50       2401 if ($r eq $e) {
159 1157         2471 return $self->pass($msg);
160             }
161             else {
162 0         0 return $self->fail($msg, $self->different($expect, $result));
163             }
164             }
165              
166             sub isnt ($$$;$) {
167 5     5 1 27 my $self = shift->prototype;
168 5         24 my ($result, $expect, $msg) = @_;
169 5   33     19 $msg ||= $self->test_name();
170              
171             # force stringification of $result to avoid 'no eq method' overload errors
172 5 100       24 $result = "$result" if ref $result;
173              
174             # if we have coloured output enabled then the result might not match
175             # the expected because of embedded ANSI escapes, so we strip them out
176             my ($r, $e) = map {
177 5 50       15 s/$ESCAPES//g if $self->{ colour };
  10         18  
178 10         25 $_
179             } ($result, $expect);
180            
181 5 50       29 if ($r ne $e) {
182 5         18 return $self->pass($msg);
183             }
184             else {
185 0         0 for ($expect, $result) {
186 0         0 s/\n/\n |/g;
187             }
188 0         0 return $self->fail($msg, $self->message( not_eq => $expect, $result ));
189             }
190             }
191              
192             sub like ($$$;$) {
193 41     41 1 144 my $self = shift->prototype;
194 41         134 my ($result, $expect, $name) = @_;
195 41   33     104 $name ||= $self->test_name();
196              
197             # strip ANSI escapes if necessary
198 41         74 my $r = $result;
199 41 50       126 $r =~ s/$ESCAPES//g if $self->{ colour };
200              
201 41 50       323 if ($r =~ $expect) {
202 41         129 $self->pass($name);
203             }
204             else {
205 0         0 return $self->fail($name, $self->message( not_like => $expect, $result ));
206             }
207             }
208              
209             sub unlike ($$$;$) {
210 2     2 1 8 my $self = shift->prototype;
211 2         7 my ($result, $expect, $name) = @_;
212 2   33     6 $name ||= $self->test_name();
213              
214             # strip ANSI escapes if necessary
215 2         6 my $r = $result;
216 2 50       8 $r =~ s/$ESCAPES//g if $self->{ colour };
217              
218 2 50       13 if ($r !~ $expect) {
219 2         7 $self->pass($name);
220             }
221             else {
222 0         0 return $self->fail($name, $self->message( not_unlike => $expect, $result ));
223             }
224             }
225              
226             sub skip ($;$) {
227 0     0 1 0 my $self = shift->prototype;
228 0   0     0 my $msg = shift || $self->test_name;
229              
230             return $self->error_msg('no_plan')
231 0 0       0 unless $self->{ plan };
232              
233 0         0 $self->{ tested }++;
234 0         0 $self->{ skipped }++;
235 0         0 return $self->test_msg( skip_one => $self->{ count }++, $msg );
236             }
237              
238             sub skip_some {
239 0     0 1 0 my ($self, $n, $msg) = @_;
240 0         0 $n = int $n;
241 0 0       0 return unless $n > 0;
242 0         0 while ($n--) {
243 0         0 $self->skip($msg);
244             }
245             }
246              
247             sub skip_rest {
248 0     0 1 0 my $self = shift->prototype;
249 0         0 my $msg = shift;
250 0         0 my $plan = $self->{ plan };
251 0         0 while ($self->{ tested } < $plan) {
252 0         0 $self->skip($msg);
253             }
254 0         0 exit;
255             }
256              
257             sub skip_all ($;$) {
258 8     8 1 74 my $self = shift->prototype;
259 8   33     103 $self->test_msg( skip_all => shift || $self->{ reason } );
260 8         3585 exit;
261             }
262              
263             sub result {
264 1741     1741 1 2925 my $self = shift->prototype;
265 1741         2362 my $ok = shift;
266              
267             return $self->error_msg('no_plan')
268 1741 50       3142 unless $self->{ plan };
269            
270 1741 50       2965 if ($ok) {
271 1741         2169 $self->{ passed }++;
272 1741         3052 return $self->test_msg( ok => @_ );
273             }
274             else {
275 0         0 $self->{ failed }++;
276 0         0 return $self->test_msg( not_ok => @_ );
277             }
278             }
279              
280             sub test_msg {
281 1811     1811 1 2244 my $self = shift;
282 1811         4415 print $self->message(@_);
283             }
284              
285             sub test_name ($) {
286 1     1 1 4 my $self = shift->prototype;
287 1         20 my ($pkg, $file, $line) = caller(2);
288 1         8 $self->message( name => $self->{ count }, $file, $line );
289             }
290              
291             sub different {
292 0     0 1 0 my ($self, $expect, $result) = @_;
293 0         0 my ($pad_exp, $pad_res) = ($expect, $result);
294 0         0 for ($pad_exp, $pad_res) {
295 0         0 s/\n/\n# |/g;
296             }
297 0         0 my $msg = $self->message( not_eq => $pad_exp, $pad_res );
298              
299 0 0       0 return $msg
300             unless $CAN_DIFF;
301              
302 0         0 my $diffs = diff( map { [ split(/\n/) ] } $expect, $result );
  0         0  
303 0         0 my $n = 0;
304 0         0 my $m = scalar @$diffs;
305            
306 0         0 foreach my $hunk (@$diffs) {
307 0         0 $msg .= $self->message( hunk => ++$n, $m );
308 0         0 foreach my $delta (@$hunk) {
309 0         0 $msg .= $self->message( delta => @$delta );
310             }
311             # $msg .= "\n";
312             }
313 0         0 return $msg;
314             }
315              
316             sub colour {
317 0     0 1 0 my $self = shift->prototype;
318 0         0 my $ansi = ANSI_colours;
319              
320             # enable colour mode by inserting ANSI escapes into $MESSAGES
321 0 0 0     0 if (@_ && ($self->{ colour } = shift)) {
322 0         0 foreach my $col (keys %$SCHEME) {
323 0   0     0 my $code = $ansi->{ $col }
324             || $self->error("Invalid colour name in \$SCHEME: $col\n");
325             $MESSAGES->{ $_ } = ANSI_escape($code, $MESSAGES->{ $_ })
326 0         0 for split(/\s+/, $SCHEME->{ $col });
327             }
328 0         0 Badger::Debug->enable_colour;
329             }
330              
331 0         0 return $self->{ colour };
332             }
333              
334             sub flush {
335 70     70 1 289 my $self = shift->prototype;
336 70   33     628 my $results = shift || $self->{ results };
337 70 50       355 return unless @$results;
338 0   0     0 $self->{ plan } ||= @$results;
339 0         0 while (@$results) {
340 0         0 my $test = shift @$results;
341 0         0 $self->result(@$test);
342             }
343             }
344              
345             sub summary {
346 0     0 1 0 my $self = shift->prototype;
347             return @_
348             ? ($self->{ summary } = shift)
349 0 0       0 : $self->{ summary };
350             }
351              
352             sub finish {
353 70     70 1 403 my $self = shift->prototype;
354              
355 70         448 $self->flush; # output any cached results
356              
357             my ($plan, $ran, $pass, $fail, $skip)
358 70         513 = @$self{ qw( plan tested passed failed skipped ) };
359            
360 70 100       240 return unless $plan;
361              
362             # mandatory warnings about too many/too few
363 62 50       443 if ($ran < $plan) {
    50          
364 0           $self->test_msg( too_few => $plan, $ran );
365             }
366             elsif ($ran > $plan) {
367 0           $self->test_msg( too_many => $plan, $ran );
368             }
369              
370             # optional summary follows for those who want it
371 62 50         return unless $self->{ summary };
372            
373 0           my $good = $pass + $skip;
374            
375 0 0         if ($fail) {
    0          
376 0           $self->test_msg( fail => $fail );
377             }
378             elsif ($good == $plan) {
379 0           $self->test_msg( pass => $plan );
380             }
381             else {
382 0           $self->test_msg('mess');
383             }
384 0           $self->test_msg( summary => $ran, $plan, $pass, $fail, $skip );
385              
386             # remove ourselves from the index
387 0           delete $INSTANCES->{ $self };
388            
389             }
390              
391             END {
392             # Cleanup test managers so they can report errors using test_msg(). If
393             # we leave it until global destruction (e.g. by using a DESTROY method to
394             # call finish() then there's a chance that the Badger::Class object that
395             # perform the $MESSAGE lookup will have already been cleaned up.
396 70     70   1632 $_->finish for values %$INSTANCES;
397             }
398              
399             1;
400              
401             __END__