Update Test-Harness to CPAN version 3.39
[perl.git] / cpan / Test-Harness / lib / TAP / Parser / Aggregator.pm
1 package TAP::Parser::Aggregator;
2
3 use strict;
4 use warnings;
5 use Benchmark;
6
7 use base 'TAP::Object';
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<TAP::Parser::Aggregator> collects parser objects and allows
42 reporting/querying their aggregate results.
43
44 =head1 METHODS
45
46 =head2 Class Methods
47
48 =head3 C<new>
49
50  my $aggregate = TAP::Parser::Aggregator->new;
51
52 Returns a new C<TAP::Parser::Aggregator> 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     %SUMMARY_METHOD_FOR = map { $_ => $_ } qw(
62       failed
63       parse_errors
64       passed
65       skipped
66       todo
67       todo_passed
68       total
69       wait
70       exit
71     );
72     $SUMMARY_METHOD_FOR{total}   = 'tests_run';
73     $SUMMARY_METHOD_FOR{planned} = 'tests_planned';
74
75     for my $method ( keys %SUMMARY_METHOD_FOR ) {
76         next if 'total' eq $method;
77         no strict 'refs';
78         *$method = sub {
79             my $self = shift;
80             return wantarray
81               ? @{ $self->{"descriptions_for_$method"} }
82               : $self->{$method};
83         };
84     }
85 }    # end install summary methods
86
87 sub _initialize {
88     my ($self) = @_;
89     $self->{parser_for}  = {};
90     $self->{parse_order} = [];
91     for my $summary ( keys %SUMMARY_METHOD_FOR ) {
92         $self->{$summary} = 0;
93         next if 'total' eq $summary;
94         $self->{"descriptions_for_$summary"} = [];
95     }
96     return $self;
97 }
98
99 ##############################################################################
100
101 =head2 Instance Methods
102
103 =head3 C<add>
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<TAP::Parser|TAP::Parser> object.
112
113 =cut
114
115 sub add {
116     my ( $self, $description, $parser ) = @_;
117     if ( exists $self->{parser_for}{$description} ) {
118         $self->_croak( "You already have a parser for ($description)."
119               . " Perhaps you have run the same test twice." );
120     }
121     push @{ $self->{parse_order} } => $description;
122     $self->{parser_for}{$description} = $parser;
123
124     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           if ( $method eq 'exit' || $method eq 'wait' )
130           && $parser->ignore_exit;
131
132         if ( my $count = $parser->$method() ) {
133             $self->{$summary} += $count;
134             push @{ $self->{"descriptions_for_$summary"} } => $description;
135         }
136     }
137
138     return $self;
139 }
140
141 ##############################################################################
142
143 =head3 C<parsers>
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     my $self = shift;
164     return $self->_get_parsers(@_) if @_;
165     my $descriptions = $self->{parse_order};
166     my @parsers      = @{ $self->{parser_for} }{@$descriptions};
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     return @parsers;
171 }
172
173 sub _get_parsers {
174     my ( $self, @descriptions ) = @_;
175     my @parsers;
176     for my $description (@descriptions) {
177         $self->_croak("A parser for ($description) could not be found")
178           unless exists $self->{parser_for}{$description};
179         push @parsers => $self->{parser_for}{$description};
180     }
181     return wantarray ? @parsers : \@parsers;
182 }
183
184 =head3 C<descriptions>
185
186 Get an array of descriptions in the order in which they were added to
187 the aggregator.
188
189 =cut
190
191 sub descriptions { @{ shift->{parse_order} || [] } }
192
193 =head3 C<start>
194
195 Call C<start> 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     my $self = shift;
202     $self->{start_time} = Benchmark->new;
203 }
204
205 =head3 C<stop>
206
207 Call C<stop> immediately after adding all test results to the aggregator.
208
209 =cut
210
211 sub stop {
212     my $self = shift;
213     $self->{end_time} = Benchmark->new;
214 }
215
216 =head3 C<elapsed>
217
218 Elapsed returns a L<Benchmark> object that represents the running time
219 of the aggregated tests. In order for C<elapsed> to be valid you must
220 call C<start> before running the tests and C<stop> immediately
221 afterwards.
222
223 =cut
224
225 sub elapsed {
226     my $self = shift;
227
228     require Carp;
229     Carp::croak
230       q{Can't call elapsed without first calling start and then stop}
231       unless defined $self->{start_time} && defined $self->{end_time};
232     return timediff( $self->{end_time}, $self->{start_time} );
233 }
234
235 =head3 C<elapsed_timestr>
236
237 Returns a formatted string representing the runtime returned by
238 C<elapsed()>.  This lets the caller not worry about Benchmark.
239
240 =cut
241
242 sub elapsed_timestr {
243     my $self = shift;
244
245     my $elapsed = $self->elapsed;
246
247     return timestr($elapsed);
248 }
249
250 =head3 C<all_passed>
251
252 Return true if all the tests passed and no parse errors were detected.
253
254 =cut
255
256 sub all_passed {
257     my $self = shift;
258     return
259          $self->total
260       && $self->total == $self->passed
261       && !$self->has_errors;
262 }
263
264 =head3 C<get_status>
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<CPAN::Reporter>.
269
270 =cut
271
272 sub get_status {
273     my $self = shift;
274
275     my $total  = $self->total;
276     my $passed = $self->passed;
277
278     return
279         ( $self->has_errors || $total != $passed ) ? 'FAIL'
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<add>
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<wait> and C<exit> 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<total>
330
331   my $tests_run = $aggregate->total;
332
333 Returns the total number of tests run.
334
335 =cut
336
337 sub total { shift->{total} }
338
339 ##############################################################################
340
341 =head3 C<has_problems>
342
343   if ( $parser->has_problems ) {
344       ...
345   }
346
347 Identical to C<has_errors>, 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     my $self = shift;
354     return $self->todo_passed
355       || $self->has_errors;
356 }
357
358 ##############################################################################
359
360 =head3 C<has_errors>
361
362   if ( $parser->has_errors ) {
363       ...
364   }
365
366 Returns true if I<any> 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     my $self = shift;
382     return
383          $self->failed
384       || $self->parse_errors
385       || $self->exit
386       || $self->wait;
387 }
388
389 ##############################################################################
390
391 =head3 C<todo_failed>
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<todo_passed>.
397
398 =cut
399
400 sub todo_failed {
401     warn
402       '"todo_failed" is deprecated.  Please use "todo_passed".  See the docs.';
403     goto &todo_passed;
404 }
405
406 =head1 See Also
407
408 L<TAP::Parser>
409
410 L<TAP::Harness>
411
412 =cut
413
414 1;