1 package TAP::Formatter::Base;
5 use POSIX qw(strftime);
7 use vars qw($VERSION @ISA);
16 directives => sub { shift; shift },
17 verbosity => sub { shift; shift },
18 normalize => sub { shift; shift },
19 timer => sub { shift; shift },
20 failures => sub { shift; shift },
21 comments => sub { shift; shift },
22 errors => sub { shift; shift },
23 color => sub { shift; shift },
24 jobs => sub { shift; shift },
25 show_count => sub { shift; shift },
27 my ( $self, $ref ) = @_;
28 $self->_croak("option 'stdout' needs a filehandle")
29 unless ( ref $ref || '' ) eq 'GLOB'
30 or eval { $ref->can('print') };
35 my @getter_setters = qw(
37 _printed_summary_header
41 __PACKAGE__->mk_methods( @getter_setters, keys %VALIDATION_FOR );
46 TAP::Formatter::Console - Harness output delegate for default console output
58 This provides console orientated output formatting for TAP::Harness.
62 use TAP::Formatter::Console;
63 my $harness = TAP::Formatter::Console->new( \%args );
68 my ( $self, $arg_for ) = @_;
71 $self->SUPER::_initialize($arg_for);
72 my %arg_for = %$arg_for; # force a shallow copy
76 for my $name ( keys %VALIDATION_FOR ) {
77 my $property = delete $arg_for{$name};
78 if ( defined $property ) {
79 my $validate = $VALIDATION_FOR{$name};
80 $self->$name( $self->$validate($property) );
84 if ( my @props = keys %arg_for ) {
86 "Unknown arguments to " . __PACKAGE__ . "::new (@props)" );
89 $self->stdout( \*STDOUT ) unless $self->stdout;
92 require TAP::Formatter::Color;
93 $self->_colorizer( TAP::Formatter::Color->new );
99 sub verbose { shift->verbosity >= 1 }
100 sub quiet { shift->verbosity <= -1 }
101 sub really_quiet { shift->verbosity <= -2 }
102 sub silent { shift->verbosity <= -3 }
113 my $harness = TAP::Formatter::Console->new( \%args );
115 The constructor returns a new C<TAP::Formatter::Console> object. If
116 a L<TAP::Harness> is created with no C<formatter> a
117 C<TAP::Formatter::Console> is automatically created. If any of the
118 following options were given to TAP::Harness->new they well be passed to
119 this constructor which accepts an optional hashref whose allowed keys are:
125 Set the verbosity level.
129 Printing individual test results to STDOUT.
133 Append run time for each test to output. Uses L<Time::HiRes> if available.
137 Show test failures (this is a no-op if C<verbose> is selected).
141 Show test comments (this is a no-op if C<verbose> is selected).
145 Suppressing some test output (mostly failures while tests are running).
147 =item * C<really_quiet>
149 Suppressing everything but the tests summary.
153 Suppressing all output.
157 If parse errors are found in the TAP output, a note of this will be made
158 in the summary report. To see all of the parse errors, set this argument to
163 =item * C<directives>
165 If set to a true value, only test results with directives will be displayed.
166 This overrides other settings such as C<verbose>, C<failures>, or C<comments>.
170 A filehandle for catching standard output.
174 If defined specifies whether color output is desired. If C<color> is not
175 defined it will default to color output if color support is available on
176 the current platform and output is not being redirected.
180 The number of concurrent jobs this formatter will handle.
182 =item * C<show_count>
184 Boolean value. If false, disables the C<X/Y> test count which shows up while
189 Any keys for which the value is C<undef> will be ignored.
193 # new supplied by TAP::Base
197 Called by Test::Harness before any test output is generated.
199 This is an advisory and may not be called in the case where tests are
200 being supplied to Test::Harness by an iterator.
205 my ( $self, @tests ) = @_;
209 foreach my $test (@tests) {
210 $longest = length $test if length $test > $longest;
213 $self->_longest($longest);
216 sub _format_now { strftime "[%H:%M:%S]", localtime }
219 my ( $self, $test ) = @_;
221 my $periods = '.' x ( $self->_longest + 2 - length $test );
222 $periods = " $periods ";
224 if ( $self->timer ) {
225 my $stamp = $self->_format_now();
226 return "$stamp $name$periods";
229 return "$name$periods";
236 Called to create a new test session. A test session looks like this:
238 my $session = $formatter->open_test( $test, $parser );
239 while ( defined( my $result = $parser->next ) ) {
240 $session->result($result);
241 exit 1 if $result->is_bailout;
243 $session->close_test;
248 die "Unimplemented.";
251 sub _output_success {
252 my ( $self, $msg ) = @_;
253 $self->_output($msg);
258 $harness->summary( $aggregate );
260 C<summary> prints the summary report after all tests are run. The argument is
266 my ( $self, $aggregate ) = @_;
268 return if $self->silent;
270 my @t = $aggregate->descriptions;
273 my $runtime = $aggregate->elapsed_timestr;
275 my $total = $aggregate->total;
276 my $passed = $aggregate->passed;
278 if ( $self->timer ) {
279 $self->_output( $self->_format_now(), "\n" );
282 # TODO: Check this condition still works when all subtests pass but
283 # the exit status is nonzero
285 if ( $aggregate->all_passed ) {
286 $self->_output_success("All tests successful.\n");
289 # ~TODO option where $aggregate->skipped generates reports
290 if ( $total != $passed or $aggregate->has_problems ) {
291 $self->_output("\nTest Summary Report");
292 $self->_output("\n-------------------\n");
293 foreach my $test (@$tests) {
294 $self->_printed_summary_header(0);
295 my ($parser) = $aggregate->parsers($test);
296 $self->_output_summary_failure(
298 [ ' Failed test: ', ' Failed tests: ' ],
301 $self->_output_summary_failure(
303 " TODO passed: ", $test, $parser
306 # ~TODO this cannot be the default
307 #$self->_output_summary_failure( 'skipped', " Tests skipped: " );
309 if ( my $exit = $parser->exit ) {
310 $self->_summary_test_header( $test, $parser );
311 $self->_failure_output(" Non-zero exit status: $exit\n");
313 elsif ( my $wait = $parser->wait ) {
314 $self->_summary_test_header( $test, $parser );
315 $self->_failure_output(" Non-zero wait status: $wait\n");
318 if ( my @errors = $parser->parse_errors ) {
320 if ( @errors > $MAX_ERRORS && !$self->errors ) {
322 = "Displayed the first $MAX_ERRORS of "
324 . " TAP syntax errors.\n"
325 . "Re-run prove with the -p option to see them all.\n";
326 splice @errors, $MAX_ERRORS;
328 $self->_summary_test_header( $test, $parser );
329 $self->_failure_output(
330 sprintf " Parse errors: %s\n",
333 foreach my $error (@errors) {
334 my $spaces = ' ' x 16;
335 $self->_failure_output("$spaces$error\n");
337 $self->_failure_output($explain) if $explain;
342 $self->_output("Files=$files, Tests=$total, $runtime\n");
343 my $status = $aggregate->get_status;
344 $self->_output("Result: $status\n");
347 sub _output_summary_failure {
348 my ( $self, $method, $name, $test, $parser ) = @_;
350 # ugly hack. Must rethink this :(
351 my $output = $method eq 'failed' ? '_failure_output' : '_output';
353 if ( my @r = $parser->$method() ) {
354 $self->_summary_test_header( $test, $parser );
355 my ( $singular, $plural )
356 = 'ARRAY' eq ref $name ? @$name : ( $name, $name );
357 $self->$output( @r == 1 ? $singular : $plural );
358 my @results = $self->_balanced_range( 40, @r );
359 $self->$output( sprintf "%s\n" => shift @results );
360 my $spaces = ' ' x 16;
362 $self->$output( sprintf "$spaces%s\n" => shift @results );
367 sub _summary_test_header {
368 my ( $self, $test, $parser ) = @_;
369 return if $self->_printed_summary_header;
370 my $spaces = ' ' x ( $self->_longest - length $test );
371 $spaces = ' ' unless $spaces;
372 my $output = $self->_get_output_method($parser);
374 sprintf "$test$spaces(Wstat: %d Tests: %d Failed: %d)\n",
375 $parser->wait, $parser->tests_run, scalar $parser->failed
377 $self->_printed_summary_header(1);
383 print { $self->stdout } @_;
386 sub _failure_output {
392 sub _balanced_range {
393 my ( $self, $limit, @range ) = @_;
394 @range = $self->_range(@range);
399 if ( $curr < $limit ) {
400 my $range = ( shift @range ) . ", ";
402 $curr += length $range;
406 push @lines => $line;
413 push @lines => $line;
419 my ( $self, @numbers ) = @_;
421 # shouldn't be needed, but subclasses might call this
422 @numbers = sort { $a <=> $b } @numbers;
425 foreach my $i ( 0 .. $#numbers ) {
426 my $num = $numbers[$i];
427 my $next = $numbers[ $i + 1 ];
428 if ( defined $next && $next == $num + 1 ) {
429 if ( !defined $min ) {
433 elsif ( defined $min ) {
434 push @range => "$min-$num";
444 sub _get_output_method {
445 my ( $self, $parser ) = @_;
446 return $parser->has_problems ? '_failure_output' : '_output';