1package TAP::Parser::Aggregator; 2 3use strict; 4use warnings; 5use Benchmark; 6 7use base 'TAP::Object'; 8 9=head1 NAME 10 11TAP::Parser::Aggregator - Aggregate TAP::Parser results 12 13=head1 VERSION 14 15Version 3.42 16 17=cut 18 19our $VERSION = '3.42'; 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 41C<TAP::Parser::Aggregator> collects parser objects and allows 42reporting/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 52Returns a new C<TAP::Parser::Aggregator> object. 53 54=cut 55 56# new() implementation supplied by TAP::Object 57 58my %SUMMARY_METHOD_FOR; 59 60BEGIN { # 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 87sub _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 107The C<$description> is usually a test file name (but only by 108convention.) It is used as a unique identifier (see e.g. 109L<"parsers">.) Reusing a description is a fatal error. 110 111The C<$parser> is a L<TAP::Parser|TAP::Parser> object. 112 113=cut 114 115sub 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 149In scalar context without arguments, this method returns the number of parsers 150aggregated. In list context without arguments, returns the parsers in the 151order they were added. 152 153If C<@descriptions> is given, these correspond to the keys used in each 154call to the add() method. Returns an array of the requested parsers (in 155the requested order) in list context or an array reference in scalar 156context. 157 158Requesting an unknown identifier is a fatal error. 159 160=cut 161 162sub 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 173sub _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 186Get an array of descriptions in the order in which they were added to 187the aggregator. 188 189=cut 190 191sub descriptions { @{ shift->{parse_order} || [] } } 192 193=head3 C<start> 194 195Call C<start> immediately before adding any results to the aggregator. 196Among other times it records the start time for the test run. 197 198=cut 199 200sub start { 201 my $self = shift; 202 $self->{start_time} = Benchmark->new; 203} 204 205=head3 C<stop> 206 207Call C<stop> immediately after adding all test results to the aggregator. 208 209=cut 210 211sub stop { 212 my $self = shift; 213 $self->{end_time} = Benchmark->new; 214} 215 216=head3 C<elapsed> 217 218Elapsed returns a L<Benchmark> object that represents the running time 219of the aggregated tests. In order for C<elapsed> to be valid you must 220call C<start> before running the tests and C<stop> immediately 221afterwards. 222 223=cut 224 225sub 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 237Returns a formatted string representing the runtime returned by 238C<elapsed()>. This lets the caller not worry about Benchmark. 239 240=cut 241 242sub 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 252Return true if all the tests passed and no parse errors were detected. 253 254=cut 255 256sub 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 266Get a single word describing the status of the aggregated tests. 267Depending on the outcome of the tests returns 'PASS', 'FAIL' or 268'NOTESTS'. This token is understood by L<CPAN::Reporter>. 269 270=cut 271 272sub 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 288Each of the following methods will return the total number of corresponding 289tests if called in scalar context. If called in list context, returns the 290descriptions of the parsers which contain the corresponding tests (see C<add> 291for 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 315For example, to find out how many tests unexpectedly succeeded (TODO tests 316which passed when they shouldn't): 317 318 my $count = $aggregate->todo_passed; 319 my @descriptions = $aggregate->todo_passed; 320 321Note that C<wait> and C<exit> are the totals of the wait and exit 322statuses of each of the tests. These values are totalled only to provide 323a 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 333Returns the total number of tests run. 334 335=cut 336 337sub total { shift->{total} } 338 339############################################################################## 340 341=head3 C<has_problems> 342 343 if ( $parser->has_problems ) { 344 ... 345 } 346 347Identical to C<has_errors>, but also returns true if any TODO tests 348unexpectedly succeeded. This is more akin to "warnings". 349 350=cut 351 352sub 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 366Returns 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 380sub 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 395This was a badly misnamed method. It indicates which TODO tests unexpectedly 396succeeded. Will now issue a warning and call C<todo_passed>. 397 398=cut 399 400sub 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 408L<TAP::Parser> 409 410L<TAP::Harness> 411 412=cut 413 4141; 415