[catagits/Gitalist.git] / local-lib5 / lib / perl5 / 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.17

=cut

$VERSION = '3.17';

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

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

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

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

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

=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
3fea05b9	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.17
	18
	19	=cut
	20
	21	$VERSION = '3.17';
	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	foreach 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	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
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	foreach 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;