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