cpan/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.25_01
  18
  19 =cut
  20
  21 $VERSION = '3.25_01';
  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     $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
  89 sub _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
 109 The C<$description> is usually a test file name (but only by
 110 convention.)  It is used as a unique identifier (see e.g.
 111 L<"parsers">.)  Reusing a description is a fatal error.
 112
 113 The C<$parser> is a L<TAP::Parser|TAP::Parser> object.
 114
 115 =cut
 116
 117 sub 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
 151 In scalar context without arguments, this method returns the number of parsers
 152 aggregated.  In list context without arguments, returns the parsers in the
 153 order they were added.
 154
 155 If C<@descriptions> is given, these correspond to the keys used in each
 156 call to the add() method.  Returns an array of the requested parsers (in
 157 the requested order) in list context or an array reference in scalar
 158 context.
 159
 160 Requesting an unknown identifier is a fatal error.
 161
 162 =cut
 163
 164 sub 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
 175 sub _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
 188 Get an array of descriptions in the order in which they were added to
 189 the aggregator.
 190
 191 =cut
 192
 193 sub descriptions { @{ shift->{parse_order} || [] } }
 194
 195 =head3 C<start>
 196
 197 Call C<start> immediately before adding any results to the aggregator.
 198 Among other times it records the start time for the test run.
 199
 200 =cut
 201
 202 sub start {
 203     my $self = shift;
 204     $self->{start_time} = Benchmark->new;
 205 }
 206
 207 =head3 C<stop>
 208
 209 Call C<stop> immediately after adding all test results to the aggregator.
 210
 211 =cut
 212
 213 sub stop {
 214     my $self = shift;
 215     $self->{end_time} = Benchmark->new;
 216 }
 217
 218 =head3 C<elapsed>
 219
 220 Elapsed returns a L<Benchmark> object that represents the running time
 221 of the aggregated tests. In order for C<elapsed> to be valid you must
 222 call C<start> before running the tests and C<stop> immediately
 223 afterwards.
 224
 225 =cut
 226
 227 sub 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
 239 Returns a formatted string representing the runtime returned by
 240 C<elapsed()>.  This lets the caller not worry about Benchmark.
 241
 242 =cut
 243
 244 sub 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
 254 Return true if all the tests passed and no parse errors were detected.
 255
 256 =cut
 257
 258 sub 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
 268 Get a single word describing the status of the aggregated tests.
 269 Depending on the outcome of the tests returns 'PASS', 'FAIL' or
 270 'NOTESTS'. This token is understood by L<CPAN::Reporter>.
 271
 272 =cut
 273
 274 sub 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
 290 Each of the following methods will return the total number of corresponding
 291 tests if called in scalar context.  If called in list context, returns the
 292 descriptions of the parsers which contain the corresponding tests (see C<add>
 293 for 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
 317 For example, to find out how many tests unexpectedly succeeded (TODO tests
 318 which passed when they shouldn't):
 319
 320  my $count        = $aggregate->todo_passed;
 321  my @descriptions = $aggregate->todo_passed;
 322
 323 Note that C<wait> and C<exit> are the totals of the wait and exit
 324 statuses of each of the tests. These values are totalled only to provide
 325 a 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
 335 Returns the total number of tests run.
 336
 337 =cut
 338
 339 sub total { shift->{total} }
 340
 341 ##############################################################################
 342
 343 =head3 C<has_problems>
 344
 345   if ( $parser->has_problems ) {
 346       ...
 347   }
 348
 349 Identical to C<has_errors>, but also returns true if any TODO tests
 350 unexpectedly succeeded.  This is more akin to "warnings".
 351
 352 =cut
 353
 354 sub 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
 368 Returns 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
 382 sub 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
 397 This was a badly misnamed method.  It indicates which TODO tests unexpectedly
 398 succeeded.  Will now issue a warning and call C<todo_passed>.
 399
 400 =cut
 401
 402 sub 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
 410 L<TAP::Parser>
 411
 412 L<TAP::Harness>
 413
 414 =cut
 415
 416 1;