File Coverage

blib/lib/Test/Run/Obj/CanonFailedObj.pm
Criterion Covered Total %
statement 70 78 89.7
branch 8 14 57.1
condition 3 3 100.0
subroutine 21 24 87.5
pod 10 10 100.0
total 112 129 86.8


line stmt bran cond sub pod time code
1             package Test::Run::Obj::CanonFailedObj;
2              
3 3     3   22 use strict;
  3         12  
  3         114  
4 3     3   16 use warnings;
  3         6  
  3         177  
5              
6             # TODO
7             # Refactor the hell out of this module.
8              
9             =head1 NAME
10              
11             Test::Run::Obj::CanonFailedObj - the failed tests canon object.
12              
13             =head1 METHODS
14              
15             =cut
16              
17 3     3   23 use Moose;
  3         5  
  3         44  
18              
19             extends('Test::Run::Base::Struct');
20              
21 3     3   23781 use MRO::Compat;
  3         8  
  3         35  
22              
23 3     3   136 use vars qw(@fields);
  3         7  
  3         2909  
24              
25             has 'failed' => (is => "rw", isa => "ArrayRef");
26             has '_more_results' => (is => "rw", isa => "ArrayRef",
27             lazy => 1, default => sub { [] },
28             );
29              
30             sub _get_more_results
31             {
32 12     12   37 my $self = shift;
33              
34 12         449 return $self->_more_results();
35             }
36              
37             =head2 $self->add_result($result)
38              
39             Pushes $result to the result() slot.
40              
41             =cut
42              
43             sub add_result
44             {
45 48     48 1 127 my $self = shift;
46 48         76 push @{$self->_more_results()}, @_;
  48         1384  
47             }
48              
49             =head2 $self->get_ser_results()
50              
51             Returns the serialized results.
52              
53             =cut
54              
55             sub get_ser_results
56             {
57 12     12 1 35 my $self = shift;
58 12         28 return join("", @{$self->result()});
  12         63  
59             }
60              
61             =head2 $self->add_Failed($test)
62              
63             Add a failed test $test to the diagnostics.
64              
65             =cut
66              
67             sub _add_Failed_summary
68             {
69 24     24   61 my ($self, $test) = @_;
70              
71 24         94 $self->add_result(
72             sprintf(
73             "\tFailed %s/%s tests, ",
74             $self->failed_num(),
75             $test->max()
76             )
77             );
78             }
79              
80             sub _add_Failed_percent_okay
81             {
82 24     24   71 my ($self, $test) = @_;
83              
84 24         94 $self->add_result(
85             $self->_calc_Failed_percent_okay($test)
86             );
87             }
88              
89             sub _calc_Failed_percent_okay
90             {
91 24     24   62 my ($self, $test) = @_;
92              
93             return
94 24 50       566 $test->max()
95             ? sprintf("%.2f%% okay", 100*(1-$self->failed_num()/$test->max()))
96             : "?% okay"
97             ;
98             }
99              
100             sub add_Failed
101             {
102 24     24 1 67 my ($self, $test) = @_;
103              
104 24         638 my $max = $test->max();
105 24         651 my $failed_num = $self->failed_num();
106              
107 24         343 $self->_add_Failed_summary($test);
108 24         124 $self->_add_Failed_percent_okay($test);
109             }
110              
111             =head2 $self->add_skipped($test)
112              
113             Add a skipped test.
114              
115             =cut
116              
117             sub add_skipped
118             {
119 24     24 1 65 my ($self, $test) = @_;
120              
121 24 50       727 if ($test->skipped())
122             {
123 0         0 $self->_add_actual_skipped($test);
124             }
125             }
126              
127             sub _add_actual_skipped
128             {
129 0     0   0 my ($self, $test) = @_;
130              
131 0 0       0 my $tests_string = (($test->skipped() > 1) ? "tests" : "test");
132              
133 0         0 $self->add_result(
134             sprintf(
135             " (less %s skipped %s: %s okay, %s%%)",
136             $test->skipped(),
137             $tests_string,
138             $self->_calc_skipped_percent($test),
139             )
140             );
141             }
142              
143             sub _calc_skipped_percent
144             {
145 0     0   0 my ($self, $test) = @_;
146              
147             return
148 0 0       0 $test->max()
149             ? sprintf("%.2f", 100*($self->good($test)/$test->max()))
150             : "?"
151             ;
152             }
153              
154             =head2 $self->good()
155              
156             Returns the number of good (non failing or skipped) tests.
157              
158             =cut
159              
160             sub good
161             {
162 0     0 1 0 my ($self, $test) = @_;
163              
164 0         0 return $test->max() - $self->failed_num() - $test->skipped();
165             }
166              
167             =head2 $self->add_Failed_and_skipped($test)
168              
169             Adds a test as both failed and skipped.
170              
171             =cut
172              
173             sub add_Failed_and_skipped
174             {
175 24     24 1 78 my ($self, $t) = @_;
176              
177 24         186 $self->add_Failed($t);
178 24         145 $self->add_skipped($t);
179              
180 24         57 return;
181             }
182              
183             =head2 $self->canon_list()
184              
185             Returns the the failed tests as a list of ranges.
186              
187             =cut
188              
189             sub canon_list
190             {
191 24     24 1 56 my $self = shift;
192              
193 24         656 return (@{$self->failed()} == 1)
194 24 100       42 ? [ @{$self->failed()} ]
  10         295  
195             : $self->_get_canon_ranges()
196             ;
197             }
198              
199             sub _get_canon_ranges
200             {
201 14     14   35 my $self = shift;
202              
203 14         26 my @failed = @{$self->failed()};
  14         355  
204              
205             # Assign the first number in the range.
206 14         46 my $min = shift(@failed);
207              
208 14         34 my $last = $min;
209              
210 14         31 my @ranges;
211              
212 14         308 foreach my $number (@failed, $failed[-1]) # Don't forget the last one
213             {
214 200024 100 100     368899 if (($number > $last+1) || ($number == $last))
215             {
216 24 100       93 push @ranges, +($min == $last) ? $min : "$min-$last";
217 24         47 $min = $last = $number;
218             }
219             else
220             {
221 200000         219182 $last = $number;
222             }
223             }
224              
225 14         3353 return \@ranges;
226             }
227              
228             =head2 my $string = $self->canon()
229              
230             Returns the canon as a space-delimited string.
231              
232             =cut
233              
234             sub canon
235             {
236 12     12 1 31 my $self = shift;
237              
238 12         34 return join(' ', @{$self->canon_list()});
  12         57  
239             }
240              
241              
242             sub _get_failed_string
243             {
244 12     12   29 my $self = shift;
245              
246 12         91 my $canon = $self->canon_list;
247              
248             return
249 12         120 sprintf("FAILED %s %s",
250             $self->_list_pluralize("test", $canon),
251             join(", ", @$canon)
252             );
253             }
254              
255             sub _get_failed_string_line
256             {
257 12     12   27 my $self = shift;
258              
259 12         64 return $self->_get_failed_string() . "\n";
260             }
261              
262             =head2 $self->result()
263              
264             The non-serialized result of the test.
265              
266             =cut
267              
268             sub result
269             {
270 12     12 1 30 my $self = shift;
271              
272 12         78 return [ $self->_get_failed_string_line(), @{$self->_get_more_results()} ];
  12         129  
273             }
274              
275             =head2 $self->failed_num()
276              
277             Returns the number of failed tests.
278              
279             =cut
280              
281             sub failed_num
282             {
283 72     72 1 146 my $self = shift;
284              
285 72         115 return scalar(@{$self->failed()});
  72         2183  
286             }
287              
288             =head2 $self->add_skipped($test)
289              
290             Add a skipped test.
291              
292             =cut
293              
294              
295             =head1 LICENSE
296              
297             This file is licensed under the MIT X11 License:
298              
299             http://www.opensource.org/licenses/mit-license.php
300              
301             =head1 AUTHOR
302              
303             Shlomi Fish, L<http://www.shlomifish.org/>
304              
305             =head1 SEE ALSO
306              
307             L<Test::Run::Obj>, L<Test::Run::Core>.
308              
309             =cut
310              
311             1;