1 package TAP::Formatter::Console;
5 use POSIX qw(strftime);
7 use vars qw($VERSION @ISA);
16 directives => sub { shift; shift },
17 verbosity => sub { shift; shift },
18 timer => sub { shift; shift },
19 failures => sub { shift; shift },
20 errors => sub { shift; shift },
21 color => sub { shift; shift },
22 jobs => sub { shift; shift },
24 my ( $self, $ref ) = @_;
25 $self->_croak("option 'stdout' needs a filehandle")
26 unless ( ref $ref || '' ) eq 'GLOB'
27 or eval { $ref->can('print') };
32 my @getter_setters = qw(
34 _printed_summary_header
38 for my $method ( @getter_setters, keys %VALIDATION_FOR ) {
42 return $self->{$method} unless @_;
43 $self->{$method} = shift;
50 TAP::Formatter::Console - Harness output delegate for default console output
62 This provides console orientated output formatting for TAP::Harness.
66 use TAP::Formatter::Console;
67 my $harness = TAP::Formatter::Console->new( \%args );
72 my ( $self, $arg_for ) = @_;
75 $self->SUPER::_initialize($arg_for);
76 my %arg_for = %$arg_for; # force a shallow copy
80 for my $name ( keys %VALIDATION_FOR ) {
81 my $property = delete $arg_for{$name};
82 if ( defined $property ) {
83 my $validate = $VALIDATION_FOR{$name};
84 $self->$name( $self->$validate($property) );
88 if ( my @props = keys %arg_for ) {
90 "Unknown arguments to " . __PACKAGE__ . "::new (@props)" );
93 $self->stdout( \*STDOUT ) unless $self->stdout;
96 require TAP::Formatter::Color;
97 $self->_colorizer( TAP::Formatter::Color->new );
103 sub verbose { shift->verbosity >= 1 }
104 sub quiet { shift->verbosity <= -1 }
105 sub really_quiet { shift->verbosity <= -2 }
106 sub silent { shift->verbosity <= -3 }
117 my $harness = TAP::Formatter::Console->new( \%args );
119 The constructor returns a new C<TAP::Formatter::Console> object. If
120 a L<TAP::Harness> is created with no C<formatter> a
121 C<TAP::Formatter::Console> is automatically created. If any of the
122 following options were given to TAP::Harness->new they well be passed to
123 this constructor which accepts an optional hashref whose allowed keys are:
129 Set the verbosity level.
133 Printing individual test results to STDOUT.
137 Append run time for each test to output. Uses L<Time::HiRes> if available.
141 Only show test failures (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> or C<failures>.
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.
184 Any keys for which the value is C<undef> will be ignored.
188 # new supplied by TAP::Base
192 Called by Test::Harness before any test output is generated.
194 This is an advisory and may not be called in the case where tests are
195 being supplied to Test::Harness by an iterator.
200 my ( $self, @tests ) = @_;
204 foreach my $test (@tests) {
205 $longest = length $test if length $test > $longest;
208 $self->_longest($longest);
211 sub _format_now { strftime "[%H:%M:%S]", localtime }
214 my ( $self, $test ) = @_;
216 my $periods = '.' x ( $self->_longest + 4 - length $test );
218 if ( $self->timer ) {
219 my $stamp = $self->_format_now();
220 return "$stamp $name$periods";
223 return "$name$periods";
230 Called to create a new test session. A test session looks like this:
232 my $session = $formatter->open_test( $test, $parser );
233 while ( defined( my $result = $parser->next ) ) {
234 $session->result($result);
235 exit 1 if $result->is_bailout;
237 $session->close_test;
242 my ( $self, $test, $parser ) = @_;
246 ? 'TAP::Formatter::Console::ParallelSession'
247 : 'TAP::Formatter::Console::Session';
249 eval "require $class";
250 $self->_croak($@) if $@;
252 my $session = $class->new(
266 $harness->summary( $aggregate );
268 C<summary> prints the summary report after all tests are run. The argument is
274 my ( $self, $aggregate ) = @_;
276 return if $self->silent;
278 my @t = $aggregate->descriptions;
281 my $runtime = $aggregate->elapsed_timestr;
283 my $total = $aggregate->total;
284 my $passed = $aggregate->passed;
286 if ( $self->timer ) {
287 $self->_output( $self->_format_now(), "\n" );
290 # TODO: Check this condition still works when all subtests pass but
291 # the exit status is nonzero
293 if ( $aggregate->all_passed ) {
294 $self->_output("All tests successful.\n");
297 # ~TODO option where $aggregate->skipped generates reports
298 if ( $total != $passed or $aggregate->has_problems ) {
299 $self->_output("\nTest Summary Report");
300 $self->_output("\n-------------------\n");
301 foreach my $test (@$tests) {
302 $self->_printed_summary_header(0);
303 my ($parser) = $aggregate->parsers($test);
304 $self->_output_summary_failure(
306 [ ' Failed test: ', ' Failed tests: ' ],
309 $self->_output_summary_failure(
311 " TODO passed: ", $test, $parser
314 # ~TODO this cannot be the default
315 #$self->_output_summary_failure( 'skipped', " Tests skipped: " );
317 if ( my $exit = $parser->exit ) {
318 $self->_summary_test_header( $test, $parser );
319 $self->_failure_output(" Non-zero exit status: $exit\n");
322 if ( my @errors = $parser->parse_errors ) {
324 if ( @errors > $MAX_ERRORS && !$self->errors ) {
326 = "Displayed the first $MAX_ERRORS of "
328 . " TAP syntax errors.\n"
329 . "Re-run prove with the -p option to see them all.\n";
330 splice @errors, $MAX_ERRORS;
332 $self->_summary_test_header( $test, $parser );
333 $self->_failure_output(
334 sprintf " Parse errors: %s\n",
337 foreach my $error (@errors) {
338 my $spaces = ' ' x 16;
339 $self->_failure_output("$spaces$error\n");
341 $self->_failure_output($explain) if $explain;
346 $self->_output("Files=$files, Tests=$total, $runtime\n");
347 my $status = $aggregate->get_status;
348 $self->_output("Result: $status\n");
351 sub _output_summary_failure {
352 my ( $self, $method, $name, $test, $parser ) = @_;
354 # ugly hack. Must rethink this :(
355 my $output = $method eq 'failed' ? '_failure_output' : '_output';
357 if ( my @r = $parser->$method() ) {
358 $self->_summary_test_header( $test, $parser );
359 my ( $singular, $plural )
360 = 'ARRAY' eq ref $name ? @$name : ( $name, $name );
361 $self->$output( @r == 1 ? $singular : $plural );
362 my @results = $self->_balanced_range( 40, @r );
363 $self->$output( sprintf "%s\n" => shift @results );
364 my $spaces = ' ' x 16;
366 $self->$output( sprintf "$spaces%s\n" => shift @results );
371 sub _summary_test_header {
372 my ( $self, $test, $parser ) = @_;
373 return if $self->_printed_summary_header;
374 my $spaces = ' ' x ( $self->_longest - length $test );
375 $spaces = ' ' unless $spaces;
376 my $output = $self->_get_output_method($parser);
378 sprintf "$test$spaces(Wstat: %d Tests: %d Failed: %d)\n",
379 $parser->wait, $parser->tests_run, scalar $parser->failed
381 $self->_printed_summary_header(1);
387 print { $self->stdout } @_;
390 # Use _colorizer delegate to set output color. NOP if we have no delegate
392 my ( $self, @colors ) = @_;
393 if ( my $colorizer = $self->_colorizer ) {
394 my $output_func = $self->{_output_func} ||= sub {
397 $colorizer->set_color( $output_func, $_ ) for @colors;
401 sub _failure_output {
403 $self->_set_colors('red');
404 my $out = join '', @_;
405 my $has_newline = chomp $out;
406 $self->_output($out);
407 $self->_set_colors('reset');
412 sub _balanced_range {
413 my ( $self, $limit, @range ) = @_;
414 @range = $self->_range(@range);
419 if ( $curr < $limit ) {
420 my $range = ( shift @range ) . ", ";
422 $curr += length $range;
426 push @lines => $line;
433 push @lines => $line;
439 my ( $self, @numbers ) = @_;
441 # shouldn't be needed, but subclasses might call this
442 @numbers = sort { $a <=> $b } @numbers;
445 foreach my $i ( 0 .. $#numbers ) {
446 my $num = $numbers[$i];
447 my $next = $numbers[ $i + 1 ];
448 if ( defined $next && $next == $num + 1 ) {
449 if ( !defined $min ) {
453 elsif ( defined $min ) {
454 push @range => "$min-$num";
464 sub _get_output_method {
465 my ( $self, $parser ) = @_;
466 return $parser->has_problems ? '_failure_output' : '_output';