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.05
  56
  57 =cut
  58
  59 $VERSION = '3.05';
  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', "  Failed test number(s):  ",
 316                 $test,    $parser
 317             );
 318             $self->_output_summary_failure(
 319                 'todo_passed',
 320                 "  TODO passed:   ", $test, $parser
 321             );
 322
 323             # ~TODO this cannot be the default
 324             #$self->_output_summary_failure( 'skipped', "  Tests skipped: " );
 325
 326             if ( my $exit = $parser->exit ) {
 327                 $self->_summary_test_header( $test, $parser );
 328                 $self->_failure_output("  Non-zero exit status: $exit\n");
 329             }
 330
 331             if ( my @errors = $parser->parse_errors ) {
 332                 my $explain;
 333                 if ( @errors > $MAX_ERRORS && !$self->errors ) {
 334                     $explain
 335                       = "Displayed the first $MAX_ERRORS of "
 336                       . scalar(@errors)
 337                       . " TAP syntax errors.\n"
 338                       . "Re-run prove with the -p option to see them all.\n";
 339                     splice @errors, $MAX_ERRORS;
 340                 }
 341                 $self->_summary_test_header( $test, $parser );
 342                 $self->_failure_output(
 343                     sprintf "  Parse errors: %s\n",
 344                     shift @errors
 345                 );
 346                 foreach my $error (@errors) {
 347                     my $spaces = ' ' x 16;
 348                     $self->_failure_output("$spaces$error\n");
 349                 }
 350                 $self->_failure_output($explain) if $explain;
 351             }
 352         }
 353     }
 354     my $files = @$tests;
 355     $self->_output("Files=$files, Tests=$total, $runtime\n");
 356     my $status = $aggregate->get_status;
 357     $self->_output("Result: $status\n");
 358 }
 359
 360 sub _output_summary_failure {
 361     my ( $self, $method, $name, $test, $parser ) = @_;
 362
 363     # ugly hack.  Must rethink this :(
 364     my $output = $method eq 'failed' ? '_failure_output' : '_output';
 365
 366     if ( $parser->$method() ) {
 367         $self->_summary_test_header( $test, $parser );
 368         $self->$output($name);
 369         my @results = $self->_balanced_range( 40, $parser->$method() );
 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;