File Coverage

blib/lib/Test/Run/Obj/TotObj.pm
Criterion Covered Total %
statement 99 100 99.0
branch 10 12 83.3
condition 3 3 100.0
subroutine 36 36 100.0
pod 12 12 100.0
total 160 163 98.1


line stmt bran cond sub pod time code
1             package Test::Run::Obj::TotObj;
2              
3 8     8   764 use strict;
  8         15  
  8         251  
4 8     8   42 use warnings;
  8         19  
  8         312  
5              
6             =head1 NAME
7              
8             Test::Run::Obj::TotObj - totals encountered for the entire Test::Run session
9              
10             =head1 DESCRIPTION
11              
12             Inherits from L<Test::Run::Base::Struct>.
13              
14             =head1 METHODS
15              
16             =cut
17              
18 8     8   43 use vars qw(@fields @counter_fields %counter_fields_map);
  8         12  
  8         498  
19              
20 8     8   51 use Benchmark qw();
  8         18  
  8         152  
21              
22 8     8   39 use Moose;
  8         15  
  8         59  
23 8     8   35979 use MRO::Compat;
  8         18  
  8         86  
24              
25             extends("Test::Run::Base::Struct");
26              
27             @counter_fields = (qw(
28             bad
29             bench
30             bonus
31             files
32             good
33             max
34             ok
35             skipped
36             sub_skipped
37             todo
38             ));
39              
40             %counter_fields_map = (map { $_ => 1 } @counter_fields);
41              
42             has 'bad' => (is => "rw", isa => "Num");
43             has 'bench' => (is => "rw", isa => "Any");
44             has 'bonus' => (is => "rw", isa => "Str");
45             # TODO : Should this be removed?
46             has 'files' => (is => "rw");
47             has 'good' => (is => "rw", isa => "Num");
48             has 'max' => (is => "rw", isa => "Num");
49             has 'ok' => (is => "rw", isa => "Num");
50             has 'skipped' => (is => "rw", isa => "Num");
51             has 'sub_skipped' => (is => "rw", isa => "Num");
52             has 'todo' => (is => "rw", isa => "Num");
53             has 'tests' => (is => "rw", isa => "Num");
54              
55             sub _pre_init
56             {
57 51     51   121 my $self = shift;
58 51         225 foreach my $f (@counter_fields)
59             {
60 510         14684 $self->$f(0);
61             }
62 51         162 return 0;
63             }
64              
65             =head2 BUILD
66              
67             For Moose.
68              
69             =cut
70              
71             sub BUILD
72             {
73 51     51 1 660 my $self = shift;
74              
75 51         497 $self->_register_obj_formatter(
76             {
77             name => "fail_no_tests_output",
78             format => "FAILED--%(tests)d test %(_num_scripts)s could be run, alas--no output ever seen\n",
79             },
80             );
81              
82 51         304 $self->_register_obj_formatter(
83             {
84             name => "sub_skipped_msg",
85             format => "%(sub_skipped)d %(_skipped_subtests)s",
86             },
87             );
88              
89 51         259 $self->_register_obj_formatter(
90             {
91             name => "skipped_bonusmsg_on_skipped",
92             format => ", %(skipped)d %(_skipped_tests_str)s%(_and_skipped_msg)s skipped",
93             },
94             );
95              
96 51         256 $self->_register_obj_formatter(
97             {
98             name => "skipped_bonusmsg_on_sub_skipped",
99             format => ", %(_sub_skipped_msg)s skipped",
100             },
101             );
102              
103 51         261 $self->_register_obj_formatter(
104             {
105             name => "sub_percent_msg",
106             format => " %(_not_ok)s/%(max)s subtests failed, %(_percent_ok).2f%% okay.",
107             },
108             );
109              
110 51         282 $self->_register_obj_formatter(
111             {
112             name => "good_percent_msg",
113             format => "%(_good_percent).2f",
114             },
115             );
116              
117 51         243 $self->_register_obj_formatter(
118             {
119             name => "fail_tests_good_percent_string",
120             format => ", %(good_percent_msg)s%% okay",
121             },
122             );
123              
124 51         231 $self->_register_obj_formatter(
125             {
126             name => "positive_bonusmsg",
127             format => " (%(bonus)s %(_bonus_subtests_str)s UNEXPECTEDLY SUCCEEDED)",
128             },
129             );
130              
131 51         172 return $self;
132             }
133              
134             sub _good_percent
135             {
136 7     7   21 my $self = shift;
137              
138 7         54 return $self->_percent("good", "tests");
139             }
140              
141             sub _percent
142             {
143 7     7   35 my ($self, $num, $denom) = @_;
144              
145 7         236 return ($self->$num() * 100 / $self->$denom());
146             }
147              
148             =head2 $self->add($field, $diff)
149              
150             Adds the difference $diff to the slot $field, assuming it is a counter field.
151              
152             =cut
153              
154             sub add
155             {
156 390     390 1 1525 my ($self, $field, $diff) = @_;
157 390 50       1222 if (!exists($counter_fields_map{$field}))
158             {
159 0         0 Carp::confess "Cannot add to field \"$field\"!";
160             }
161 390         12555 $self->$field($self->$field() + $diff);
162 390         10192 return $self->$field();
163             }
164              
165             =head2 $self->inc($field)
166              
167             Increments the field $field by 1.
168              
169             =cut
170              
171             sub inc
172             {
173 115     115 1 368 my ($self, $field) = @_;
174              
175 115         455 return $self->add($field, 1);
176             }
177              
178             =head2 $self->bench_timestr()
179              
180             Retrieves the timestr() "nop" according to Benchmark.pm of the bench() field.
181              
182             =cut
183              
184             sub bench_timestr
185             {
186 15     15 1 39 my $self = shift;
187              
188 15         424 return Benchmark::timestr($self->bench(), 'nop');
189             }
190              
191             =head2 $self->all_ok()
192              
193             Returns a boolean value - 0 or 1 if all tests were OK.
194              
195             =cut
196              
197             sub all_ok
198             {
199 88     88 1 225 my $self = shift;
200              
201 88   100     2425 return $self->_normalize_cond(
202             ($self->bad() == 0)
203             && ($self->max() || $self->skipped())
204             );
205             }
206              
207             sub _normalize_cond
208             {
209 88     88   300 my ($self, $cond) = @_;
210 88 100       670 return ($cond ? 1 : 0);
211             }
212              
213             =head2 $self->fail_test_scripts_string()
214              
215             Internal use.
216              
217             =cut
218              
219             sub fail_test_scripts_string
220             {
221 7     7 1 21 my $self = shift;
222              
223 7         30 return $self->_get_obj_formatter(
224             "%(bad)s/%(tests)s test scripts",
225             )->obj_format($self);
226             }
227              
228             =head2 $self->add_results($results)
229              
230             Adds the sums from a results object.
231              
232             =cut
233              
234             sub add_results
235             {
236 55     55 1 254 my ($self, $results) = @_;
237              
238 55         405 foreach my $type (qw(bonus max ok todo))
239             {
240 220         6567 $self->add($type, $results->$type());
241             }
242              
243 55         1636 $self->add("sub_skipped", $results->skip())
244             }
245              
246             sub _num_scripts
247             {
248 1     1   5 my $self = shift;
249              
250 1         41 return $self->_pluralize("script", $self->tests());
251             }
252              
253             sub _get_fail_no_tests_output_text
254             {
255 1     1   8 my $self = shift;
256              
257 1         9 return $self->_format_self(
258             "fail_no_tests_output",
259             );
260             }
261              
262             sub _skipped_subtests
263             {
264 3     3   14 my $self = shift;
265              
266 3         97 return $self->_pluralize("subtest", $self->sub_skipped());
267             }
268              
269             =head2 $self->get_sub_skipped_msg()
270              
271             Calculates the sub-skipped message ("X subtest/s")
272              
273             =cut
274              
275             sub _sub_skipped_msg
276             {
277 3     3   14 my $self = shift;
278              
279 3         22 return $self->_format_self(
280             "sub_skipped_msg",
281             );
282             }
283              
284             sub _skipped_tests_str
285             {
286 1     1   2 my $self = shift;
287              
288 1         32 return $self->_pluralize("test", $self->skipped());
289             }
290              
291             sub _and_skipped_msg
292             {
293 1     1   8 my $self = shift;
294              
295 1 50       37 return $self->sub_skipped()
296             ? ( " and " . $self->_sub_skipped_msg() )
297             : ""
298             ;
299             }
300              
301             sub _get_skipped_bonusmsg_on_skipped
302             {
303 1     1   8 my $self = shift;
304              
305 1         9 return $self->_format_self(
306             "skipped_bonusmsg_on_skipped"
307             );
308             }
309              
310             sub _get_skipped_bonusmsg_on_sub_skipped
311             {
312 3     3   10 my $self = shift;
313              
314 3         26 return $self->_format_self(
315             "skipped_bonusmsg_on_sub_skipped",
316             );
317             }
318              
319             sub _get_skipped_bonusmsg
320             {
321 15     15   119 my $self = shift;
322              
323 15 100       468 if ($self->skipped())
    100          
324             {
325 1         18 return $self->_get_skipped_bonusmsg_on_skipped();
326             }
327             elsif ($self->sub_skipped())
328             {
329 3         36 return $self->_get_skipped_bonusmsg_on_sub_skipped();
330             }
331             else
332             {
333 11         456 return "";
334             }
335             }
336              
337             sub _bonus_subtests_str
338             {
339 4     4   9 my $self = shift;
340              
341 4         122 return $self->_pluralize("subtest", $self->bonus());
342             }
343              
344             sub _get_positive_bonusmsg
345             {
346 4     4   12 my $self = shift;
347              
348 4         34 return $self->_format_self(
349             "positive_bonusmsg"
350             );
351             }
352              
353             sub _get_subtests_bonusmsg
354             {
355 15     15   52 my $self = shift;
356 15 100       463 return ($self->bonus() ? $self->_get_positive_bonusmsg() : "");
357             }
358              
359             =head2 $self->get_bonusmsg()
360              
361             Internal use.
362              
363             =cut
364              
365             sub get_bonusmsg
366             {
367 15     15 1 44 my $self = shift;
368              
369 15         143 return $self->_get_subtests_bonusmsg() . $self->_get_skipped_bonusmsg();
370             }
371              
372             sub _percent_ok
373             {
374 7     7   17 my $self = shift;
375              
376 7         171 return 100*$self->ok()/$self->max();
377             }
378              
379             sub _not_ok
380             {
381 7     7   17 my $self = shift;
382              
383 7         191 return $self->max() - $self->ok();
384             }
385              
386             =head2 $self->get_sub_percent_msg()
387              
388             Internal use.
389              
390             =cut
391              
392             sub get_sub_percent_msg
393             {
394 7     7 1 18 my $self = shift;
395              
396 7         25 return $self->_format_self(
397             "sub_percent_msg",
398             );
399             }
400              
401             =head2 $self->good_percent_msg()
402              
403             Internal use.
404              
405             =cut
406              
407             sub good_percent_msg
408             {
409 7     7 1 29 my $self = shift;
410              
411 7         51 return $self->_format_self(
412             "good_percent_msg",
413             );
414             }
415              
416             =head2 $self->fail_tests_good_percent_string()
417              
418             Internal use.
419              
420             =cut
421              
422             sub fail_tests_good_percent_string
423             {
424 7     7 1 15 my $self = shift;
425              
426 7         70 return $self->_format_self(
427             "fail_tests_good_percent_string",
428             );
429             }
430              
431             =head2 $self->benchmark_callback(\&callback)
432              
433             Benchmarks the callback C<&callback> using the Benchmark module and puts the
434             result in the C<bench()> slot.
435              
436             =cut
437              
438             sub benchmark_callback
439             {
440 51     51 1 211 my ($self, $cb) = @_;
441              
442 51         381 my $start_time = new Benchmark;
443 51         1261 $cb->();
444 49         1062 my $end_time = new Benchmark;
445              
446 49         1857 $self->bench(Benchmark::timediff($end_time, $start_time));
447              
448 49         1270 return;
449             }
450              
451             1;
452              
453             __END__
454              
455             =head1 SEE ALSO
456              
457             L<Test::Run::Base::Struct>, L<Test::Run::Obj>, L<Test::Run::Core>
458              
459             =head1 LICENSE
460              
461             This file is freely distributable under the MIT X11 license.
462              
463             L<http://www.opensource.org/licenses/mit-license.php>
464              
465             =head1 AUTHOR
466              
467             Shlomi Fish, L<http://www.shlomifish.org/>.
468              
469             =cut
470