lib/TAP/Parser/Aggregator.pm

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