[p5sagit/p5-mst-13.2.git] / ext / Test / Harness / lib / TAP / Parser / Aggregator.pm

package TAP::Parser::Aggregator;

use strict;
use Benchmark;
use vars qw($VERSION @ISA);

use TAP::Object ();

@ISA = qw(TAP::Object);

=head1 NAME

TAP::Parser::Aggregator - Aggregate TAP::Parser results

=head1 VERSION

Version 3.14

=cut

$VERSION = '3.14';

=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';

    foreach 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} = [];
    foreach my $summary ( keys %SUMMARY_METHOD_FOR ) {
        $self->{$summary} = 0;
        next if 'total' eq $summary;
        $self->{"descriptions_for_$summary"} = [];
    }
    return $self;
}

##############################################################################

=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;
}

##############################################################################

=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;
    foreach 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;
}

=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} || [] } }

=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;
}

=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;
}

=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} );
}

=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);
}

=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;
}

=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';
}

##############################################################################

=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 * 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

##############################################################################

=head3 C<total>

  my $tests_run = $aggregate->total;

Returns the total number of tests run.

=cut

sub total { shift->{total} }

##############################################################################

=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;
}

##############################################################################

=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 erros

=item * Bad exit or wait status

=back

=cut

sub has_errors {
    my $self = shift;
    return
         $self->failed
      || $self->parse_errors
      || $self->exit
      || $self->wait;
}

##############################################################################

=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;
}

=head1 See Also

L<TAP::Parser>

L<TAP::Harness>

=cut

1;
Commit	Line	Data
b965d173	1	package TAP::Parser::Aggregator;
	2
	3	use strict;
	4	use Benchmark;
f7c69158	5	use vars qw($VERSION @ISA);
	6
	7	use TAP::Object ();
	8
	9	@ISA = qw(TAP::Object);
b965d173	10
	11	=head1 NAME
	12
	13	TAP::Parser::Aggregator - Aggregate TAP::Parser results
	14
	15	=head1 VERSION
	16
27fc0087	17	Version 3.14
b965d173	18
	19	=cut
	20
27fc0087	21	$VERSION = '3.14';
b965d173	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
f7c69158	58	# new() implementation supplied by TAP::Object
f7c69158	59
b965d173	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
b965d173	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 ) {
f7c69158	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
b965d173	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;
69f36734	258	return
69f36734	259	$self->total
b965d173	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;
69f36734	380	return
69f36734	381	$self->failed
b965d173	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
b965d173	404	=head1 See Also
	405
	406	L<TAP::Parser>
	407
	408	L<TAP::Harness>
	409
	410	=cut
	411
	412	1;