lib/TAP/Formatter/Console.pm

   1 package TAP::Formatter::Console;
   2
   3 use strict;
   4 use TAP::Base ();
   5 use POSIX qw(strftime);
   6
   7 use vars qw($VERSION @ISA);
   8
   9 @ISA = qw(TAP::Base);
  10
  11 my $MAX_ERRORS = 5;
  12 my %VALIDATION_FOR;
  13
  14 BEGIN {
  15     %VALIDATION_FOR = (
  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 },
  23         stdout     => sub {
  24             my ( $self, $ref ) = @_;
  25             $self->_croak("option 'stdout' needs a filehandle")
  26               unless ( ref $ref || '' ) eq 'GLOB'
  27               or eval { $ref->can('print') };
  28             return $ref;
  29         },
  30     );
  31
  32     my @getter_setters = qw(
  33       _longest
  34       _tests_without_extensions
  35       _printed_summary_header
  36       _colorizer
  37     );
  38
  39     for my $method ( @getter_setters, keys %VALIDATION_FOR ) {
  40         no strict 'refs';
  41         *$method = sub {
  42             my $self = shift;
  43             return $self->{$method} unless @_;
  44             $self->{$method} = shift;
  45         };
  46     }
  47 }
  48
  49 =head1 NAME
  50
  51 TAP::Formatter::Console - Harness output delegate for default console output
  52
  53 =head1 VERSION
  54
  55 Version 3.06
  56
  57 =cut
  58
  59 $VERSION = '3.06';
  60
  61 =head1 DESCRIPTION
  62
  63 This provides console orientated output formatting for TAP::Harness.
  64
  65 =head1 SYNOPSIS
  66
  67  use TAP::Formatter::Console;
  68  my $harness = TAP::Formatter::Console->new( \%args );
  69
  70 =cut
  71
  72 sub _initialize {
  73     my ( $self, $arg_for ) = @_;
  74     $arg_for ||= {};
  75
  76     $self->SUPER::_initialize($arg_for);
  77     my %arg_for = %$arg_for;    # force a shallow copy
  78
  79     $self->verbosity(0);
  80
  81     for my $name ( keys %VALIDATION_FOR ) {
  82         my $property = delete $arg_for{$name};
  83         if ( defined $property ) {
  84             my $validate = $VALIDATION_FOR{$name};
  85             $self->$name( $self->$validate($property) );
  86         }
  87     }
  88
  89     if ( my @props = keys %arg_for ) {
  90         $self->_croak(
  91             "Unknown arguments to " . __PACKAGE__ . "::new (@props)" );
  92     }
  93
  94     $self->stdout( \*STDOUT ) unless $self->stdout;
  95
  96     if ( $self->color ) {
  97         require TAP::Formatter::Color;
  98         $self->_colorizer( TAP::Formatter::Color->new );
  99     }
 100
 101     return $self;
 102 }
 103
 104 sub verbose      { shift->verbosity >= 1 }
 105 sub quiet        { shift->verbosity <= -1 }
 106 sub really_quiet { shift->verbosity <= -2 }
 107 sub silent       { shift->verbosity <= -3 }
 108
 109 =head1 METHODS
 110
 111 =head2 Class Methods
 112
 113 =head3 C<new>
 114
 115  my %args = (
 116     verbose => 1,
 117  )
 118  my $harness = TAP::Formatter::Console->new( \%args );
 119
 120 The constructor returns a new C<TAP::Formatter::Console> object. If
 121 a L<TAP::Harness> is created with no C<formatter> a
 122 C<TAP::Formatter::Console> is automatically created. If any of the
 123 following options were given to TAP::Harness->new they well be passed to
 124 this constructor which accepts an optional hashref whose allowed keys are:
 125
 126 =over 4
 127
 128 =item * C<verbosity>
 129
 130 Set the verbosity level.
 131
 132 =item * C<verbose>
 133
 134 Printing individual test results to STDOUT.
 135
 136 =item * C<timer>
 137
 138 Append run time for each test to output. Uses L<Time::HiRes> if available.
 139
 140 =item * C<failures>
 141
 142 Only show test failures (this is a no-op if C<verbose> is selected).
 143
 144 =item * C<quiet>
 145
 146 Suppressing some test output (mostly failures while tests are running).
 147
 148 =item * C<really_quiet>
 149
 150 Suppressing everything but the tests summary.
 151
 152 =item * C<silent>
 153
 154 Suppressing all output.
 155
 156 =item * C<errors>
 157
 158 If parse errors are found in the TAP output, a note of this will be made
 159 in the summary report.  To see all of the parse errors, set this argument to
 160 true:
 161
 162   errors => 1
 163
 164 =item * C<directives>
 165
 166 If set to a true value, only test results with directives will be displayed.
 167 This overrides other settings such as C<verbose> or C<failures>.
 168
 169 =item * C<stdout>
 170
 171 A filehandle for catching standard output.
 172
 173 =item * C<color>
 174
 175 If defined specifies whether color output is desired. If C<color> is not
 176 defined it will default to color output if color support is available on
 177 the current platform and output is not being redirected.
 178
 179 =item * C<jobs>
 180
 181 The number of concurrent jobs this formatter will handle.
 182
 183 =back
 184
 185 Any keys for which the value is C<undef> will be ignored.
 186
 187 =cut
 188
 189 # new supplied by TAP::Base
 190
 191 =head3 C<prepare>
 192
 193 Called by Test::Harness before any test output is generated.
 194
 195 =cut
 196
 197 sub prepare {
 198     my ( $self, @tests ) = @_;
 199
 200     my $longest = 0;
 201
 202     my $tests_without_extensions = 0;
 203     foreach my $test (@tests) {
 204         $longest = length $test if length $test > $longest;
 205         if ( $test !~ /\.\w+$/ ) {
 206
 207             # TODO: Coverage?
 208             $tests_without_extensions = 1;
 209         }
 210     }
 211
 212     $self->_tests_without_extensions($tests_without_extensions);
 213     $self->_longest($longest);
 214 }
 215
 216 sub _format_now { strftime "[%H:%M:%S]", localtime }
 217
 218 sub _format_name {
 219     my ( $self, $test ) = @_;
 220     my $name  = $test;
 221     my $extra = 0;
 222     unless ( $self->_tests_without_extensions ) {
 223         $name =~ s/(\.\w+)$//;    # strip the .t or .pm
 224         $extra = length $1;
 225     }
 226     my $periods = '.' x ( $self->_longest + $extra + 4 - length $test );
 227
 228     if ( $self->timer ) {
 229         my $stamp = $self->_format_now();
 230         return "$stamp $name$periods";
 231     }
 232     else {
 233         return "$name$periods";
 234     }
 235
 236 }
 237
 238 =head3 C<open_test>
 239
 240 Called to create a new test session. A test session looks like this:
 241
 242     my $session = $formatter->open_test( $test, $parser );
 243     while ( defined( my $result = $parser->next ) ) {
 244         $session->result($result);
 245         exit 1 if $result->is_bailout;
 246     }
 247     $session->close_test;
 248
 249 =cut
 250
 251 sub open_test {
 252     my ( $self, $test, $parser ) = @_;
 253
 254     my $class
 255       = $self->jobs > 1
 256       ? 'TAP::Formatter::Console::ParallelSession'
 257       : 'TAP::Formatter::Console::Session';
 258
 259     eval "require $class";
 260     $self->_croak($@) if $@;
 261
 262     my $session = $class->new(
 263         {   name      => $test,
 264             formatter => $self,
 265             parser    => $parser
 266         }
 267     );
 268
 269     $session->header;
 270
 271     return $session;
 272 }
 273
 274 =head3 C<summary>
 275
 276   $harness->summary( $aggregate );
 277
 278 C<summary> prints the summary report after all tests are run.  The argument is
 279 an aggregate.
 280
 281 =cut
 282
 283 sub summary {
 284     my ( $self, $aggregate ) = @_;
 285
 286     return if $self->silent;
 287
 288     my @t     = $aggregate->descriptions;
 289     my $tests = \@t;
 290
 291     my $runtime = $aggregate->elapsed_timestr;
 292
 293     my $total  = $aggregate->total;
 294     my $passed = $aggregate->passed;
 295
 296     if ( $self->timer ) {
 297         $self->_output( $self->_format_now(), "\n" );
 298     }
 299
 300     # TODO: Check this condition still works when all subtests pass but
 301     # the exit status is nonzero
 302
 303     if ( $aggregate->all_passed ) {
 304         $self->_output("All tests successful.\n");
 305     }
 306
 307     # ~TODO option where $aggregate->skipped generates reports
 308     if ( $total != $passed or $aggregate->has_problems ) {
 309         $self->_output("\nTest Summary Report");
 310         $self->_output("\n-------------------\n");
 311         foreach my $test (@$tests) {
 312             $self->_printed_summary_header(0);
 313             my ($parser) = $aggregate->parsers($test);
 314             $self->_output_summary_failure(
 315                 'failed',
 316                 [ '  Failed test:  ', '  Failed tests:  ' ],
 317                 $test, $parser
 318             );
 319             $self->_output_summary_failure(
 320                 'todo_passed',
 321                 "  TODO passed:   ", $test, $parser
 322             );
 323
 324             # ~TODO this cannot be the default
 325             #$self->_output_summary_failure( 'skipped', "  Tests skipped: " );
 326
 327             if ( my $exit = $parser->exit ) {
 328                 $self->_summary_test_header( $test, $parser );
 329                 $self->_failure_output("  Non-zero exit status: $exit\n");
 330             }
 331
 332             if ( my @errors = $parser->parse_errors ) {
 333                 my $explain;
 334                 if ( @errors > $MAX_ERRORS && !$self->errors ) {
 335                     $explain
 336                       = "Displayed the first $MAX_ERRORS of "
 337                       . scalar(@errors)
 338                       . " TAP syntax errors.\n"
 339                       . "Re-run prove with the -p option to see them all.\n";
 340                     splice @errors, $MAX_ERRORS;
 341                 }
 342                 $self->_summary_test_header( $test, $parser );
 343                 $self->_failure_output(
 344                     sprintf "  Parse errors: %s\n",
 345                     shift @errors
 346                 );
 347                 foreach my $error (@errors) {
 348                     my $spaces = ' ' x 16;
 349                     $self->_failure_output("$spaces$error\n");
 350                 }
 351                 $self->_failure_output($explain) if $explain;
 352             }
 353         }
 354     }
 355     my $files = @$tests;
 356     $self->_output("Files=$files, Tests=$total, $runtime\n");
 357     my $status = $aggregate->get_status;
 358     $self->_output("Result: $status\n");
 359 }
 360
 361 sub _output_summary_failure {
 362     my ( $self, $method, $name, $test, $parser ) = @_;
 363
 364     # ugly hack.  Must rethink this :(
 365     my $output = $method eq 'failed' ? '_failure_output' : '_output';
 366
 367     if ( my @r = $parser->$method() ) {
 368         $self->_summary_test_header( $test, $parser );
 369         my ( $singular, $plural )
 370           = 'ARRAY' eq ref $name ? @$name : ( $name, $name );
 371         $self->$output( @r == 1 ? $singular : $plural );
 372         my @results = $self->_balanced_range( 40, @r );
 373         $self->$output( sprintf "%s\n" => shift @results );
 374         my $spaces = ' ' x 16;
 375         while (@results) {
 376             $self->$output( sprintf "$spaces%s\n" => shift @results );
 377         }
 378     }
 379 }
 380
 381 sub _summary_test_header {
 382     my ( $self, $test, $parser ) = @_;
 383     return if $self->_printed_summary_header;
 384     my $spaces = ' ' x ( $self->_longest - length $test );
 385     $spaces = ' ' unless $spaces;
 386     my $output = $self->_get_output_method($parser);
 387     $self->$output(
 388         sprintf "$test$spaces(Wstat: %d Tests: %d Failed: %d)\n",
 389         $parser->wait, $parser->tests_run, scalar $parser->failed
 390     );
 391     $self->_printed_summary_header(1);
 392 }
 393
 394 sub _output {
 395     my $self = shift;
 396
 397     print { $self->stdout } @_;
 398 }
 399
 400 # Use _colorizer delegate to set output color. NOP if we have no delegate
 401 sub _set_colors {
 402     my ( $self, @colors ) = @_;
 403     if ( my $colorizer = $self->_colorizer ) {
 404         my $output_func = $self->{_output_func} ||= sub {
 405             $self->_output(@_);
 406         };
 407         $colorizer->set_color( $output_func, $_ ) for @colors;
 408     }
 409 }
 410
 411 sub _failure_output {
 412     my $self = shift;
 413     $self->_set_colors('red');
 414     my $out = join '', @_;
 415     my $has_newline = chomp $out;
 416     $self->_output($out);
 417     $self->_set_colors('reset');
 418     $self->_output($/)
 419       if $has_newline;
 420 }
 421
 422 sub _balanced_range {
 423     my ( $self, $limit, @range ) = @_;
 424     @range = $self->_range(@range);
 425     my $line = "";
 426     my @lines;
 427     my $curr = 0;
 428     while (@range) {
 429         if ( $curr < $limit ) {
 430             my $range = ( shift @range ) . ", ";
 431             $line .= $range;
 432             $curr += length $range;
 433         }
 434         elsif (@range) {
 435             $line =~ s/, $//;
 436             push @lines => $line;
 437             $line = '';
 438             $curr = 0;
 439         }
 440     }
 441     if ($line) {
 442         $line =~ s/, $//;
 443         push @lines => $line;
 444     }
 445     return @lines;
 446 }
 447
 448 sub _range {
 449     my ( $self, @numbers ) = @_;
 450
 451     # shouldn't be needed, but subclasses might call this
 452     @numbers = sort { $a <=> $b } @numbers;
 453     my ( $min, @range );
 454
 455     foreach my $i ( 0 .. $#numbers ) {
 456         my $num  = $numbers[$i];
 457         my $next = $numbers[ $i + 1 ];
 458         if ( defined $next && $next == $num + 1 ) {
 459             if ( !defined $min ) {
 460                 $min = $num;
 461             }
 462         }
 463         elsif ( defined $min ) {
 464             push @range => "$min-$num";
 465             undef $min;
 466         }
 467         else {
 468             push @range => $num;
 469         }
 470     }
 471     return @range;
 472 }
 473
 474 sub _get_output_method {
 475     my ( $self, $parser ) = @_;
 476     return $parser->has_problems ? '_failure_output' : '_output';
 477 }
 478
 479 1;