ext/Test/Harness/lib/TAP/Parser/Aggregator.pm

   1 package TAP::Parser::Aggregator;
   2
   3 use strict;
   4 use Benchmark;
   5 use vars qw($VERSION @ISA);
   6
   7 use TAP::Object ();
   8
   9 @ISA = qw(TAP::Object);
  10
  11 =head1 NAME
  12
  13 TAP::Parser::Aggregator - Aggregate TAP::Parser results
  14
  15 =head1 VERSION
  16
  17 Version 3.13
  18
  19 =cut
  20
  21 $VERSION = '3.13';
  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
  43 C<TAP::Parser::Aggregator> collects parser objects and allows
  44 reporting/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
  54 Returns a new C<TAP::Parser::Aggregator> object.
  55
  56 =cut
  57
  58 # new() implementation supplied by TAP::Object
  59
  60 my %SUMMARY_METHOD_FOR;
  61
  62 BEGIN {    # 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
  76     foreach my $method ( keys %SUMMARY_METHOD_FOR ) {
  77         next if 'total' eq $method;
  78         no strict 'refs';
  79         *$method = sub {
  80             my $self = shift;
  81             return wantarray
  82               ? @{ $self->{"descriptions_for_$method"} }
  83               : $self->{$method};
  84         };
  85     }
  86 }    # end install summary methods
  87
  88 sub _initialize {
  89     my ($self) = @_;
  90     $self->{parser_for}  = {};
  91     $self->{parse_order} = [];
  92     foreach my $summary ( keys %SUMMARY_METHOD_FOR ) {
  93         $self->{$summary} = 0;
  94         next if 'total' eq $summary;
  95         $self->{"descriptions_for_$summary"} = [];
  96     }
  97     return $self;
  98 }
  99
 100 ##############################################################################
 101
 102 =head2 Instance Methods
 103
 104 =head3 C<add>
 105
 106   $aggregate->add( $description => $parser );
 107
 108 The C<$description> is usually a test file name (but only by
 109 convention.)  It is used as a unique identifier (see e.g.
 110 L<"parsers">.)  Reusing a description is a fatal error.
 111
 112 The C<$parser> is a L<TAP::Parser|TAP::Parser> object.
 113
 114 =cut
 115
 116 sub add {
 117     my ( $self, $description, $parser ) = @_;
 118     if ( exists $self->{parser_for}{$description} ) {
 119         $self->_croak( "You already have a parser for ($description)."
 120               . " Perhaps you have run the same test twice." );
 121     }
 122     push @{ $self->{parse_order} } => $description;
 123     $self->{parser_for}{$description} = $parser;
 124
 125     while ( my ( $summary, $method ) = each %SUMMARY_METHOD_FOR ) {
 126
 127         # Slightly nasty. Instead we should maybe have 'cooked' accessors
 128         # for results that may be masked by the parser.
 129         next
 130           if ( $method eq 'exit' || $method eq 'wait' )
 131           && $parser->ignore_exit;
 132
 133         if ( my $count = $parser->$method() ) {
 134             $self->{$summary} += $count;
 135             push @{ $self->{"descriptions_for_$summary"} } => $description;
 136         }
 137     }
 138
 139     return $self;
 140 }
 141
 142 ##############################################################################
 143
 144 =head3 C<parsers>
 145
 146   my $count   = $aggregate->parsers;
 147   my @parsers = $aggregate->parsers;
 148   my @parsers = $aggregate->parsers(@descriptions);
 149
 150 In scalar context without arguments, this method returns the number of parsers
 151 aggregated.  In list context without arguments, returns the parsers in the
 152 order they were added.
 153
 154 If C<@descriptions> is given, these correspond to the keys used in each
 155 call to the add() method.  Returns an array of the requested parsers (in
 156 the requested order) in list context or an array reference in scalar
 157 context.
 158
 159 Requesting an unknown identifier is a fatal error.
 160
 161 =cut
 162
 163 sub parsers {
 164     my $self = shift;
 165     return $self->_get_parsers(@_) if @_;
 166     my $descriptions = $self->{parse_order};
 167     my @parsers      = @{ $self->{parser_for} }{@$descriptions};
 168
 169     # Note:  Because of the way context works, we must assign the parsers to
 170     # the @parsers array or else this method does not work as documented.
 171     return @parsers;
 172 }
 173
 174 sub _get_parsers {
 175     my ( $self, @descriptions ) = @_;
 176     my @parsers;
 177     foreach my $description (@descriptions) {
 178         $self->_croak("A parser for ($description) could not be found")
 179           unless exists $self->{parser_for}{$description};
 180         push @parsers => $self->{parser_for}{$description};
 181     }
 182     return wantarray ? @parsers : \@parsers;
 183 }
 184
 185 =head3 C<descriptions>
 186
 187 Get an array of descriptions in the order in which they were added to 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 * skipped
 302
 303 =item * todo
 304
 305 =item * todo_passed
 306
 307 =item * wait
 308
 309 =item * exit
 310
 311 =back
 312
 313 For example, to find out how many tests unexpectedly succeeded (TODO tests
 314 which passed when they shouldn't):
 315
 316  my $count        = $aggregate->todo_passed;
 317  my @descriptions = $aggregate->todo_passed;
 318
 319 Note that C<wait> and C<exit> are the totals of the wait and exit
 320 statuses of each of the tests. These values are totalled only to provide
 321 a true value if any of them are non-zero.
 322
 323 =cut
 324
 325 ##############################################################################
 326
 327 =head3 C<total>
 328
 329   my $tests_run = $aggregate->total;
 330
 331 Returns the total number of tests run.
 332
 333 =cut
 334
 335 sub total { shift->{total} }
 336
 337 ##############################################################################
 338
 339 =head3 C<has_problems>
 340
 341   if ( $parser->has_problems ) {
 342       ...
 343   }
 344
 345 Identical to C<has_errors>, but also returns true if any TODO tests
 346 unexpectedly succeeded.  This is more akin to "warnings".
 347
 348 =cut
 349
 350 sub has_problems {
 351     my $self = shift;
 352     return $self->todo_passed
 353       || $self->has_errors;
 354 }
 355
 356 ##############################################################################
 357
 358 =head3 C<has_errors>
 359
 360   if ( $parser->has_errors ) {
 361       ...
 362   }
 363
 364 Returns true if I<any> of the parsers failed.  This includes:
 365
 366 =over 4
 367
 368 =item * Failed tests
 369
 370 =item * Parse erros
 371
 372 =item * Bad exit or wait status
 373
 374 =back
 375
 376 =cut
 377
 378 sub has_errors {
 379     my $self = shift;
 380     return
 381          $self->failed
 382       || $self->parse_errors
 383       || $self->exit
 384       || $self->wait;
 385 }
 386
 387 ##############################################################################
 388
 389 =head3 C<todo_failed>
 390
 391   # deprecated in favor of 'todo_passed'.  This method was horribly misnamed.
 392
 393 This was a badly misnamed method.  It indicates which TODO tests unexpectedly
 394 succeeded.  Will now issue a warning and call C<todo_passed>.
 395
 396 =cut
 397
 398 sub todo_failed {
 399     warn
 400       '"todo_failed" is deprecated.  Please use "todo_passed".  See the docs.';
 401     goto &todo_passed;
 402 }
 403
 404 =head1 See Also
 405
 406 L<TAP::Parser>
 407
 408 L<TAP::Harness>
 409
 410 =cut
 411
 412 1;