File Coverage

blib/lib/TAP/Parser/Aggregator.pm
Criterion Covered Total %
statement 84 84 100.0
branch 22 26 84.6
condition 16 21 76.1
subroutine 22 22 100.0
pod 13 13 100.0
total 157 166 94.5


line stmt bran cond sub pod time code
1             package TAP::Parser::Aggregator;
2              
3 19     19   3732 use strict;
  19         24  
  19         515  
4 19     19   65 use warnings;
  19         21  
  19         507  
5 19     19   9186 use Benchmark;
  19         70123  
  19         118  
6              
7 19     19   2085 use base 'TAP::Object';
  19         24  
  19         2768  
8              
9             =head1 NAME
10              
11             TAP::Parser::Aggregator - Aggregate TAP::Parser results
12              
13             =head1 VERSION
14              
15             Version 3.39
16              
17             =cut
18              
19             our $VERSION = '3.39';
20              
21             =head1 SYNOPSIS
22              
23             use TAP::Parser::Aggregator;
24              
25             my $aggregate = TAP::Parser::Aggregator->new;
26             $aggregate->add( 't/00-load.t', $load_parser );
27             $aggregate->add( 't/10-lex.t', $lex_parser );
28              
29             my $summary = <<'END_SUMMARY';
30             Passed: %s
31             Failed: %s
32             Unexpectedly succeeded: %s
33             END_SUMMARY
34             printf $summary,
35             scalar $aggregate->passed,
36             scalar $aggregate->failed,
37             scalar $aggregate->todo_passed;
38              
39             =head1 DESCRIPTION
40              
41             C collects parser objects and allows
42             reporting/querying their aggregate results.
43              
44             =head1 METHODS
45              
46             =head2 Class Methods
47              
48             =head3 C
49              
50             my $aggregate = TAP::Parser::Aggregator->new;
51              
52             Returns a new C object.
53              
54             =cut
55              
56             # new() implementation supplied by TAP::Object
57              
58             my %SUMMARY_METHOD_FOR;
59              
60             BEGIN { # install summary methods
61 19     19   35 %SUMMARY_METHOD_FOR = map { $_ => $_ } qw(
  171         324  
62             failed
63             parse_errors
64             passed
65             skipped
66             todo
67             todo_passed
68             total
69             wait
70             exit
71             );
72 19         47 $SUMMARY_METHOD_FOR{total} = 'tests_run';
73 19         30 $SUMMARY_METHOD_FOR{planned} = 'tests_planned';
74              
75 19         70 for my $method ( keys %SUMMARY_METHOD_FOR ) {
76 190 100       361 next if 'total' eq $method;
77 19     19   89 no strict 'refs';
  19         27  
  19         1496  
78             *$method = sub {
79 528     528   452 my $self = shift;
80             return wantarray
81 8         52 ? @{ $self->{"descriptions_for_$method"} }
82 528 100       2331 : $self->{$method};
83 171         13554 };
84             }
85             } # end install summary methods
86              
87             sub _initialize {
88 84     84   131 my ($self) = @_;
89 84         228 $self->{parser_for} = {};
90 84         145 $self->{parse_order} = [];
91 84         299 for my $summary ( keys %SUMMARY_METHOD_FOR ) {
92 840         798 $self->{$summary} = 0;
93 840 100       1214 next if 'total' eq $summary;
94 756         1330 $self->{"descriptions_for_$summary"} = [];
95             }
96 84         256 return $self;
97             }
98              
99             ##############################################################################
100              
101             =head2 Instance Methods
102              
103             =head3 C
104              
105             $aggregate->add( $description => $parser );
106              
107             The C<$description> is usually a test file name (but only by
108             convention.) It is used as a unique identifier (see e.g.
109             L<"parsers">.) Reusing a description is a fatal error.
110              
111             The C<$parser> is a L object.
112              
113             =cut
114              
115             sub add {
116 112     112 1 671 my ( $self, $description, $parser ) = @_;
117 112 100       320 if ( exists $self->{parser_for}{$description} ) {
118 1         9 $self->_croak( "You already have a parser for ($description)."
119             . " Perhaps you have run the same test twice." );
120             }
121 111         130 push @{ $self->{parse_order} } => $description;
  111         281  
122 111         311 $self->{parser_for}{$description} = $parser;
123              
124 111         534 while ( my ( $summary, $method ) = each %SUMMARY_METHOD_FOR ) {
125              
126             # Slightly nasty. Instead we should maybe have 'cooked' accessors
127             # for results that may be masked by the parser.
128             next
129 1110 50 100     3715 if ( $method eq 'exit' || $method eq 'wait' )
      66        
130             && $parser->ignore_exit;
131              
132 1110 100       2279 if ( my $count = $parser->$method() ) {
133 383         429 $self->{$summary} += $count;
134 383         295 push @{ $self->{"descriptions_for_$summary"} } => $description;
  383         1865  
135             }
136             }
137              
138 111         211 return $self;
139             }
140              
141             ##############################################################################
142              
143             =head3 C
144              
145             my $count = $aggregate->parsers;
146             my @parsers = $aggregate->parsers;
147             my @parsers = $aggregate->parsers(@descriptions);
148              
149             In scalar context without arguments, this method returns the number of parsers
150             aggregated. In list context without arguments, returns the parsers in the
151             order they were added.
152              
153             If C<@descriptions> is given, these correspond to the keys used in each
154             call to the add() method. Returns an array of the requested parsers (in
155             the requested order) in list context or an array reference in scalar
156             context.
157              
158             Requesting an unknown identifier is a fatal error.
159              
160             =cut
161              
162             sub parsers {
163 79     79 1 737 my $self = shift;
164 79 100       247 return $self->_get_parsers(@_) if @_;
165 4         6 my $descriptions = $self->{parse_order};
166 4         6 my @parsers = @{ $self->{parser_for} }{@$descriptions};
  4         12  
167              
168             # Note: Because of the way context works, we must assign the parsers to
169             # the @parsers array or else this method does not work as documented.
170 4         16 return @parsers;
171             }
172              
173             sub _get_parsers {
174 77     77   772 my ( $self, @descriptions ) = @_;
175 77         75 my @parsers;
176 77         119 for my $description (@descriptions) {
177             $self->_croak("A parser for ($description) could not be found")
178 79 100       205 unless exists $self->{parser_for}{$description};
179 78         135 push @parsers => $self->{parser_for}{$description};
180             }
181 76 100       242 return wantarray ? @parsers : \@parsers;
182             }
183              
184             =head3 C
185              
186             Get an array of descriptions in the order in which they were added to
187             the aggregator.
188              
189             =cut
190              
191 71 50   71 1 87 sub descriptions { @{ shift->{parse_order} || [] } }
  71         359  
192              
193             =head3 C
194              
195             Call C immediately before adding any results to the aggregator.
196             Among other times it records the start time for the test run.
197              
198             =cut
199              
200             sub start {
201 79     79 1 93 my $self = shift;
202 79         300 $self->{start_time} = Benchmark->new;
203             }
204              
205             =head3 C
206              
207             Call C immediately after adding all test results to the aggregator.
208              
209             =cut
210              
211             sub stop {
212 77     77 1 100 my $self = shift;
213 77         644 $self->{end_time} = Benchmark->new;
214             }
215              
216             =head3 C
217              
218             Elapsed returns a L object that represents the running time
219             of the aggregated tests. In order for C to be valid you must
220             call C before running the tests and C immediately
221             afterwards.
222              
223             =cut
224              
225             sub elapsed {
226 71     71 1 83 my $self = shift;
227              
228 71         647 require Carp;
229             Carp::croak
230             q{Can't call elapsed without first calling start and then stop}
231 71 50 33     424 unless defined $self->{start_time} && defined $self->{end_time};
232 71         303 return timediff( $self->{end_time}, $self->{start_time} );
233             }
234              
235             =head3 C
236              
237             Returns a formatted string representing the runtime returned by
238             C. This lets the caller not worry about Benchmark.
239              
240             =cut
241              
242             sub elapsed_timestr {
243 38     38 1 44 my $self = shift;
244              
245 38         74 my $elapsed = $self->elapsed;
246              
247 38         741 return timestr($elapsed);
248             }
249              
250             =head3 C
251              
252             Return true if all the tests passed and no parse errors were detected.
253              
254             =cut
255              
256             sub all_passed {
257 40     40 1 48 my $self = shift;
258             return
259 40   66     67 $self->total
260             && $self->total == $self->passed
261             && !$self->has_errors;
262             }
263              
264             =head3 C
265              
266             Get a single word describing the status of the aggregated tests.
267             Depending on the outcome of the tests returns 'PASS', 'FAIL' or
268             'NOTESTS'. This token is understood by L.
269              
270             =cut
271              
272             sub get_status {
273 40     40 1 51 my $self = shift;
274              
275 40         82 my $total = $self->total;
276 40         68 my $passed = $self->passed;
277              
278             return
279 40 50 66     82 ( $self->has_errors || $total != $passed ) ? 'FAIL'
    100          
280             : $total ? 'PASS'
281             : 'NOTESTS';
282             }
283              
284             ##############################################################################
285              
286             =head2 Summary methods
287              
288             Each of the following methods will return the total number of corresponding
289             tests if called in scalar context. If called in list context, returns the
290             descriptions of the parsers which contain the corresponding tests (see C
291             for an explanation of description.
292              
293             =over 4
294              
295             =item * failed
296              
297             =item * parse_errors
298              
299             =item * passed
300              
301             =item * planned
302              
303             =item * skipped
304              
305             =item * todo
306              
307             =item * todo_passed
308              
309             =item * wait
310              
311             =item * exit
312              
313             =back
314              
315             For example, to find out how many tests unexpectedly succeeded (TODO tests
316             which passed when they shouldn't):
317              
318             my $count = $aggregate->todo_passed;
319             my @descriptions = $aggregate->todo_passed;
320              
321             Note that C and C are the totals of the wait and exit
322             statuses of each of the tests. These values are totalled only to provide
323             a true value if any of them are non-zero.
324              
325             =cut
326              
327             ##############################################################################
328              
329             =head3 C
330              
331             my $tests_run = $aggregate->total;
332              
333             Returns the total number of tests run.
334              
335             =cut
336              
337 161     161 1 378 sub total { shift->{total} }
338              
339             ##############################################################################
340              
341             =head3 C
342              
343             if ( $parser->has_problems ) {
344             ...
345             }
346              
347             Identical to C, but also returns true if any TODO tests
348             unexpectedly succeeded. This is more akin to "warnings".
349              
350             =cut
351              
352             sub has_problems {
353 31     31 1 1076 my $self = shift;
354 31   100     78 return $self->todo_passed
355             || $self->has_errors;
356             }
357              
358             ##############################################################################
359              
360             =head3 C
361              
362             if ( $parser->has_errors ) {
363             ...
364             }
365              
366             Returns true if I of the parsers failed. This includes:
367              
368             =over 4
369              
370             =item * Failed tests
371              
372             =item * Parse errors
373              
374             =item * Bad exit or wait status
375              
376             =back
377              
378             =cut
379              
380             sub has_errors {
381 98     98 1 97 my $self = shift;
382             return
383 98   100     146 $self->failed
384             || $self->parse_errors
385             || $self->exit
386             || $self->wait;
387             }
388              
389             ##############################################################################
390              
391             =head3 C
392              
393             # deprecated in favor of 'todo_passed'. This method was horribly misnamed.
394              
395             This was a badly misnamed method. It indicates which TODO tests unexpectedly
396             succeeded. Will now issue a warning and call C.
397              
398             =cut
399              
400             sub todo_failed {
401 1     1 1 740 warn
402             '"todo_failed" is deprecated. Please use "todo_passed". See the docs.';
403 1         7 goto &todo_passed;
404             }
405              
406             =head1 See Also
407              
408             L
409              
410             L
411              
412             =cut
413              
414             1;