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

package TAP::Parser::Aggregator;

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

=head1 NAME

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

=head1 VERSION

Version 3.06

=cut

$VERSION = '3.06';

=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

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 new {
    my ($class) = @_;
    my $self = bless {}, $class;
    $self->_initialize;
    return $self;
}

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

sub _croak {
    my $proto = shift;
    require Carp;
    Carp::croak(@_);
}

=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;
	5	use vars qw($VERSION);
	6
	7	=head1 NAME
	8
	9	TAP::Parser::Aggregator - Aggregate TAP::Parser results
	10
	11	=head1 VERSION
	12
69f36734	13	Version 3.06
b965d173	14
	15	=cut
	16
69f36734	17	$VERSION = '3.06';
b965d173	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;
69f36734	252	return
69f36734	253	$self->total
b965d173	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;
69f36734	374	return
69f36734	375	$self->failed
b965d173	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;