—
—
—
—
—
—
—
—
—
—
—
—
—
—
—
—
—

              
package TAP::Parser::Aggregator;
use strict;
use warnings;
use Benchmark;
use base 'TAP::Object';
HideShow 10 lines of Pod
=head1 NAME
TAP::Parser::Aggregator - Aggregate TAP::Parser results
=head1 VERSION
Version 3.50
=cut
our $VERSION = '3.50';
HideShow 35 lines of Pod
=head1 SYNOPSIS
    use TAP::Parser::Aggregator;
    my $aggregate = TAP::Parser::Aggregator->new;
    $aggregate->add( 't/00-load.t', $load_parser );
    $aggregate->add( 't/10-lex.t',  $lex_parser  );
    my $summary = <<'END_SUMMARY';
    Passed:  %s
    Failed:  %s
    Unexpectedly succeeded: %s
    END_SUMMARY
    printf $summary,
           scalar $aggregate->passed,
           scalar $aggregate->failed,
           scalar $aggregate->todo_passed;
=head1 DESCRIPTION
C<TAP::Parser::Aggregator> collects parser objects and allows
reporting/querying their aggregate results.
=head1 METHODS
=head2 Class Methods
=head3 C<new>
 my $aggregate = TAP::Parser::Aggregator->new;
Returns a new C<TAP::Parser::Aggregator> object.
=cut
# new() implementation supplied by TAP::Object
my %SUMMARY_METHOD_FOR;
BEGIN {    # install summary methods
    %SUMMARY_METHOD_FOR = map { $_ => $_ } qw(
      failed
      parse_errors
      passed
      skipped
      todo
      todo_passed
      total
      wait
      exit
    );
    $SUMMARY_METHOD_FOR{total}   = 'tests_run';
    $SUMMARY_METHOD_FOR{planned} = 'tests_planned';
    for my $method ( keys %SUMMARY_METHOD_FOR ) {
        next if 'total' eq $method;
        no strict 'refs';
        *$method = sub {
            my $self = shift;
            return wantarray
              ? @{ $self->{"descriptions_for_$method"} }
              : $self->{$method};
        };
    }
}    # end install summary methods
sub _initialize {
    my ($self) = @_;
    $self->{parser_for}  = {};
    $self->{parse_order} = [];
    for my $summary ( keys %SUMMARY_METHOD_FOR ) {
        $self->{$summary} = 0;
        next if 'total' eq $summary;
        $self->{"descriptions_for_$summary"} = [];
    }
    return $self;
}
##############################################################################
HideShow 14 lines of Pod
=head2 Instance Methods
=head3 C<add>
  $aggregate->add( $description => $parser );
The C<$description> is usually a test file name (but only by
convention.)  It is used as a unique identifier (see e.g.
L<"parsers">.)  Reusing a description is a fatal error.
The C<$parser> is a L<TAP::Parser|TAP::Parser> object.
=cut
sub add {
    my ( $self, $description, $parser ) = @_;
    if ( exists $self->{parser_for}{$description} ) {
        $self->_croak( "You already have a parser for ($description)."
              . " Perhaps you have run the same test twice." );
    }
    push @{ $self->{parse_order} } => $description;
    $self->{parser_for}{$description} = $parser;
    while ( my ( $summary, $method ) = each %SUMMARY_METHOD_FOR ) {
        # Slightly nasty. Instead we should maybe have 'cooked' accessors
        # for results that may be masked by the parser.
        next
          if ( $method eq 'exit' || $method eq 'wait' )
          && $parser->ignore_exit;
        if ( my $count = $parser->$method() ) {
            $self->{$summary} += $count;
            push @{ $self->{"descriptions_for_$summary"} } => $description;
        }
    }
    return $self;
}
##############################################################################
HideShow 19 lines of Pod
=head3 C<parsers>
  my $count   = $aggregate->parsers;
  my @parsers = $aggregate->parsers;
  my @parsers = $aggregate->parsers(@descriptions);
In scalar context without arguments, this method returns the number of parsers
aggregated.  In list context without arguments, returns the parsers in the
order they were added.
If C<@descriptions> is given, these correspond to the keys used in each
call to the add() method.  Returns an array of the requested parsers (in
the requested order) in list context or an array reference in scalar
context.
Requesting an unknown identifier is a fatal error.
=cut
sub parsers {
    my $self = shift;
    return $self->_get_parsers(@_) if @_;
    my $descriptions = $self->{parse_order};
    my @parsers      = @{ $self->{parser_for} }{@$descriptions};
    # Note:  Because of the way context works, we must assign the parsers to
    # the @parsers array or else this method does not work as documented.
    return @parsers;
}
sub _get_parsers {
    my ( $self, @descriptions ) = @_;
    my @parsers;
    for my $description (@descriptions) {
        $self->_croak("A parser for ($description) could not be found")
          unless exists $self->{parser_for}{$description};
        push @parsers => $self->{parser_for}{$description};
    }
    return wantarray ? @parsers : \@parsers;
}
sub total_files {
    my $self = shift;
    return scalar $self->parsers;
}
sub failed_files {
    my $self = shift;
    my $num_bad = grep { $_->has_problems } $self->parsers;
    return $num_bad;
}
HideShow 7 lines of Pod
=head3 C<descriptions>
Get an array of descriptions in the order in which they were added to
the aggregator.
=cut
sub descriptions { @{ shift->{parse_order} || [] } }
HideShow 7 lines of Pod
=head3 C<start>
Call C<start> immediately before adding any results to the aggregator.
Among other times it records the start time for the test run.
=cut
sub start {
    my $self = shift;
    $self->{start_time} = Benchmark->new;
}
HideShow 6 lines of Pod
=head3 C<stop>
Call C<stop> immediately after adding all test results to the aggregator.
=cut
sub stop {
    my $self = shift;
    $self->{end_time} = Benchmark->new;
}
HideShow 9 lines of Pod
=head3 C<elapsed>
Elapsed returns a L<Benchmark> object that represents the running time
of the aggregated tests. In order for C<elapsed> to be valid you must
call C<start> before running the tests and C<stop> immediately
afterwards.
=cut
sub elapsed {
    my $self = shift;
    require Carp;
    Carp::croak
      q{Can't call elapsed without first calling start and then stop}
      unless defined $self->{start_time} && defined $self->{end_time};
    return timediff( $self->{end_time}, $self->{start_time} );
}
HideShow 7 lines of Pod
=head3 C<elapsed_timestr>
Returns a formatted string representing the runtime returned by
C<elapsed()>.  This lets the caller not worry about Benchmark.
=cut
sub elapsed_timestr {
    my $self = shift;
    my $elapsed = $self->elapsed;
    return timestr($elapsed);
}
HideShow 6 lines of Pod
=head3 C<all_passed>
Return true if all the tests passed and no parse errors were detected.
=cut
sub all_passed {
    my $self = shift;
    return
         $self->total
      && $self->total == $self->passed
      && !$self->has_errors;
}
HideShow 8 lines of Pod
=head3 C<get_status>
Get a single word describing the status of the aggregated tests.
Depending on the outcome of the tests returns 'PASS', 'FAIL' or
'NOTESTS'. This token is understood by L<CPAN::Reporter>.
=cut
sub get_status {
    my $self = shift;
    my $total  = $self->total;
    my $passed = $self->passed;
    return
        ( $self->has_errors || $total != $passed ) ? 'FAIL'
      : $total ? 'PASS'
      :          'NOTESTS';
}
##############################################################################
HideShow 41 lines of Pod
=head2 Summary methods
Each of the following methods will return the total number of corresponding
tests if called in scalar context.  If called in list context, returns the
descriptions of the parsers which contain the corresponding tests (see C<add>
for an explanation of description.
=over 4
=item * failed
=item * parse_errors
=item * passed
=item * planned
=item * skipped
=item * todo
=item * todo_passed
=item * wait
=item * exit
=back
For example, to find out how many tests unexpectedly succeeded (TODO tests
which passed when they shouldn't):
 my $count        = $aggregate->todo_passed;
 my @descriptions = $aggregate->todo_passed;
Note that C<wait> and C<exit> are the totals of the wait and exit
statuses of each of the tests. These values are totalled only to provide
a true value if any of them are non-zero.
=cut
##############################################################################
HideShow 8 lines of Pod
=head3 C<total>
  my $tests_run = $aggregate->total;
Returns the total number of tests run.
=cut
sub total { shift->{total} }
##############################################################################
HideShow 11 lines of Pod
=head3 C<has_problems>
  if ( $parser->has_problems ) {
      ...
  }
Identical to C<has_errors>, but also returns true if any TODO tests
unexpectedly succeeded.  This is more akin to "warnings".
=cut
sub has_problems {
    my $self = shift;
    return $self->todo_passed
      || $self->has_errors;
}
##############################################################################
HideShow 20 lines of Pod
=head3 C<has_errors>
  if ( $parser->has_errors ) {
      ...
  }
Returns true if I<any> of the parsers failed.  This includes:
=over 4
=item * Failed tests
=item * Parse errors
=item * Bad exit or wait status
=back
=cut
sub has_errors {
    my $self = shift;
    return
         $self->failed
      || $self->parse_errors
      || $self->exit
      || $self->wait;
}
##############################################################################
HideShow 9 lines of Pod
=head3 C<todo_failed>
  # deprecated in favor of 'todo_passed'.  This method was horribly misnamed.
This was a badly misnamed method.  It indicates which TODO tests unexpectedly
succeeded.  Will now issue a warning and call C<todo_passed>.
=cut
sub todo_failed {
    warn
      '"todo_failed" is deprecated.  Please use "todo_passed".  See the docs.';
    goto &todo_passed;
}
HideShow 8 lines of Pod
=head1 See Also
L<TAP::Parser>
L<TAP::Harness>
=cut
1;