ext/Test/Harness/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         show_count => sub { shift; shift },
  24         stdout     => sub {
  25             my ( $self, $ref ) = @_;
  26             $self->_croak("option 'stdout' needs a filehandle")
  27               unless ( ref $ref || '' ) eq 'GLOB'
  28               or eval { $ref->can('print') };
  29             return $ref;
  30         },
  31     );
  32
  33     my @getter_setters = qw(
  34       _longest
  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.14
  56
  57 =cut
  58
  59 $VERSION = '3.14';
  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 =item * C<show_count>
 184
 185 Boolean value.  If false, disables the C<X/Y> test count which shows up while
 186 tests are running.
 187
 188 =back
 189
 190 Any keys for which the value is C<undef> will be ignored.
 191
 192 =cut
 193
 194 # new supplied by TAP::Base
 195
 196 =head3 C<prepare>
 197
 198 Called by Test::Harness before any test output is generated.
 199
 200 This is an advisory and may not be called in the case where tests are
 201 being supplied to Test::Harness by an iterator.
 202
 203 =cut
 204
 205 sub prepare {
 206     my ( $self, @tests ) = @_;
 207
 208     my $longest = 0;
 209
 210     foreach my $test (@tests) {
 211         $longest = length $test if length $test > $longest;
 212     }
 213
 214     $self->_longest($longest);
 215 }
 216
 217 sub _format_now { strftime "[%H:%M:%S]", localtime }
 218
 219 sub _format_name {
 220     my ( $self, $test ) = @_;
 221     my $name = $test;
 222     my $periods = '.' x ( $self->_longest + 4 - length $test );
 223
 224     if ( $self->timer ) {
 225         my $stamp = $self->_format_now();
 226         return "$stamp $name$periods";
 227     }
 228     else {
 229         return "$name$periods";
 230     }
 231
 232 }
 233
 234 =head3 C<open_test>
 235
 236 Called to create a new test session. A test session looks like this:
 237
 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;
 242     }
 243     $session->close_test;
 244
 245 =cut
 246
 247 sub open_test {
 248     my ( $self, $test, $parser ) = @_;
 249
 250     my $class
 251       = $self->jobs > 1
 252       ? 'TAP::Formatter::Console::ParallelSession'
 253       : 'TAP::Formatter::Console::Session';
 254
 255     eval "require $class";
 256     $self->_croak($@) if $@;
 257
 258     my $session = $class->new(
 259         {   name       => $test,
 260             formatter  => $self,
 261             parser     => $parser,
 262             show_count => $self->show_count,
 263         }
 264     );
 265
 266     $session->header;
 267
 268     return $session;
 269 }
 270
 271 =head3 C<summary>
 272
 273   $harness->summary( $aggregate );
 274
 275 C<summary> prints the summary report after all tests are run.  The argument is
 276 an aggregate.
 277
 278 =cut
 279
 280 sub summary {
 281     my ( $self, $aggregate ) = @_;
 282
 283     return if $self->silent;
 284
 285     my @t     = $aggregate->descriptions;
 286     my $tests = \@t;
 287
 288     my $runtime = $aggregate->elapsed_timestr;
 289
 290     my $total  = $aggregate->total;
 291     my $passed = $aggregate->passed;
 292
 293     if ( $self->timer ) {
 294         $self->_output( $self->_format_now(), "\n" );
 295     }
 296
 297     # TODO: Check this condition still works when all subtests pass but
 298     # the exit status is nonzero
 299
 300     if ( $aggregate->all_passed ) {
 301         $self->_output("All tests successful.\n");
 302     }
 303
 304     # ~TODO option where $aggregate->skipped generates reports
 305     if ( $total != $passed or $aggregate->has_problems ) {
 306         $self->_output("\nTest Summary Report");
 307         $self->_output("\n-------------------\n");
 308         foreach my $test (@$tests) {
 309             $self->_printed_summary_header(0);
 310             my ($parser) = $aggregate->parsers($test);
 311             $self->_output_summary_failure(
 312                 'failed',
 313                 [ '  Failed test:  ', '  Failed tests:  ' ],
 314                 $test, $parser
 315             );
 316             $self->_output_summary_failure(
 317                 'todo_passed',
 318                 "  TODO passed:   ", $test, $parser
 319             );
 320
 321             # ~TODO this cannot be the default
 322             #$self->_output_summary_failure( 'skipped', "  Tests skipped: " );
 323
 324             if ( my $exit = $parser->exit ) {
 325                 $self->_summary_test_header( $test, $parser );
 326                 $self->_failure_output("  Non-zero exit status: $exit\n");
 327             }
 328
 329             if ( my @errors = $parser->parse_errors ) {
 330                 my $explain;
 331                 if ( @errors > $MAX_ERRORS && !$self->errors ) {
 332                     $explain
 333                       = "Displayed the first $MAX_ERRORS of "
 334                       . scalar(@errors)
 335                       . " TAP syntax errors.\n"
 336                       . "Re-run prove with the -p option to see them all.\n";
 337                     splice @errors, $MAX_ERRORS;
 338                 }
 339                 $self->_summary_test_header( $test, $parser );
 340                 $self->_failure_output(
 341                     sprintf "  Parse errors: %s\n",
 342                     shift @errors
 343                 );
 344                 foreach my $error (@errors) {
 345                     my $spaces = ' ' x 16;
 346                     $self->_failure_output("$spaces$error\n");
 347                 }
 348                 $self->_failure_output($explain) if $explain;
 349             }
 350         }
 351     }
 352     my $files = @$tests;
 353     $self->_output("Files=$files, Tests=$total, $runtime\n");
 354     my $status = $aggregate->get_status;
 355     $self->_output("Result: $status\n");
 356 }
 357
 358 sub _output_summary_failure {
 359     my ( $self, $method, $name, $test, $parser ) = @_;
 360
 361     # ugly hack.  Must rethink this :(
 362     my $output = $method eq 'failed' ? '_failure_output' : '_output';
 363
 364     if ( my @r = $parser->$method() ) {
 365         $self->_summary_test_header( $test, $parser );
 366         my ( $singular, $plural )
 367           = 'ARRAY' eq ref $name ? @$name : ( $name, $name );
 368         $self->$output( @r == 1 ? $singular : $plural );
 369         my @results = $self->_balanced_range( 40, @r );
 370         $self->$output( sprintf "%s\n" => shift @results );
 371         my $spaces = ' ' x 16;
 372         while (@results) {
 373             $self->$output( sprintf "$spaces%s\n" => shift @results );
 374         }
 375     }
 376 }
 377
 378 sub _summary_test_header {
 379     my ( $self, $test, $parser ) = @_;
 380     return if $self->_printed_summary_header;
 381     my $spaces = ' ' x ( $self->_longest - length $test );
 382     $spaces = ' ' unless $spaces;
 383     my $output = $self->_get_output_method($parser);
 384     $self->$output(
 385         sprintf "$test$spaces(Wstat: %d Tests: %d Failed: %d)\n",
 386         $parser->wait, $parser->tests_run, scalar $parser->failed
 387     );
 388     $self->_printed_summary_header(1);
 389 }
 390
 391 sub _output {
 392     my $self = shift;
 393
 394     print { $self->stdout } @_;
 395 }
 396
 397 # Use _colorizer delegate to set output color. NOP if we have no delegate
 398 sub _set_colors {
 399     my ( $self, @colors ) = @_;
 400     if ( my $colorizer = $self->_colorizer ) {
 401         my $output_func = $self->{_output_func} ||= sub {
 402             $self->_output(@_);
 403         };
 404         $colorizer->set_color( $output_func, $_ ) for @colors;
 405     }
 406 }
 407
 408 sub _failure_output {
 409     my $self = shift;
 410     $self->_set_colors('red');
 411     my $out = join '', @_;
 412     my $has_newline = chomp $out;
 413     $self->_output($out);
 414     $self->_set_colors('reset');
 415     $self->_output($/)
 416       if $has_newline;
 417 }
 418
 419 sub _balanced_range {
 420     my ( $self, $limit, @range ) = @_;
 421     @range = $self->_range(@range);
 422     my $line = "";
 423     my @lines;
 424     my $curr = 0;
 425     while (@range) {
 426         if ( $curr < $limit ) {
 427             my $range = ( shift @range ) . ", ";
 428             $line .= $range;
 429             $curr += length $range;
 430         }
 431         elsif (@range) {
 432             $line =~ s/, $//;
 433             push @lines => $line;
 434             $line = '';
 435             $curr = 0;
 436         }
 437     }
 438     if ($line) {
 439         $line =~ s/, $//;
 440         push @lines => $line;
 441     }
 442     return @lines;
 443 }
 444
 445 sub _range {
 446     my ( $self, @numbers ) = @_;
 447
 448     # shouldn't be needed, but subclasses might call this
 449     @numbers = sort { $a <=> $b } @numbers;
 450     my ( $min, @range );
 451
 452     foreach my $i ( 0 .. $#numbers ) {
 453         my $num  = $numbers[$i];
 454         my $next = $numbers[ $i + 1 ];
 455         if ( defined $next && $next == $num + 1 ) {
 456             if ( !defined $min ) {
 457                 $min = $num;
 458             }
 459         }
 460         elsif ( defined $min ) {
 461             push @range => "$min-$num";
 462             undef $min;
 463         }
 464         else {
 465             push @range => $num;
 466         }
 467     }
 468     return @range;
 469 }
 470
 471 sub _get_output_method {
 472     my ( $self, $parser ) = @_;
 473     return $parser->has_problems ? '_failure_output' : '_output';
 474 }
 475
 476 1;