local-lib5/lib/perl5/TAP/Formatter/Base.pm

   1 package TAP::Formatter::Base;
   2
   3 use strict;
   4 use TAP::Base ();
   5 use POSIX qw(strftime);
   6
   7 use vars qw($VERSION @ISA);
   8
   9 my $MAX_ERRORS = 5;
  10 my %VALIDATION_FOR;
  11
  12 BEGIN {
  13     @ISA = qw(TAP::Base);
  14
  15     %VALIDATION_FOR = (
  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 },
  26         stdout     => sub {
  27             my ( $self, $ref ) = @_;
  28             $self->_croak("option 'stdout' needs a filehandle")
  29               unless ( ref $ref || '' ) eq 'GLOB'
  30               or eval { $ref->can('print') };
  31             return $ref;
  32         },
  33     );
  34
  35     my @getter_setters = qw(
  36       _longest
  37       _printed_summary_header
  38       _colorizer
  39     );
  40
  41     __PACKAGE__->mk_methods( @getter_setters, keys %VALIDATION_FOR );
  42 }
  43
  44 =head1 NAME
  45
  46 TAP::Formatter::Console - Harness output delegate for default console output
  47
  48 =head1 VERSION
  49
  50 Version 3.17
  51
  52 =cut
  53
  54 $VERSION = '3.17';
  55
  56 =head1 DESCRIPTION
  57
  58 This provides console orientated output formatting for TAP::Harness.
  59
  60 =head1 SYNOPSIS
  61
  62  use TAP::Formatter::Console;
  63  my $harness = TAP::Formatter::Console->new( \%args );
  64
  65 =cut
  66
  67 sub _initialize {
  68     my ( $self, $arg_for ) = @_;
  69     $arg_for ||= {};
  70
  71     $self->SUPER::_initialize($arg_for);
  72     my %arg_for = %$arg_for;    # force a shallow copy
  73
  74     $self->verbosity(0);
  75
  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) );
  81         }
  82     }
  83
  84     if ( my @props = keys %arg_for ) {
  85         $self->_croak(
  86             "Unknown arguments to " . __PACKAGE__ . "::new (@props)" );
  87     }
  88
  89     $self->stdout( \*STDOUT ) unless $self->stdout;
  90
  91     if ( $self->color ) {
  92         require TAP::Formatter::Color;
  93         $self->_colorizer( TAP::Formatter::Color->new );
  94     }
  95
  96     return $self;
  97 }
  98
  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 }
 103
 104 =head1 METHODS
 105
 106 =head2 Class Methods
 107
 108 =head3 C<new>
 109
 110  my %args = (
 111     verbose => 1,
 112  )
 113  my $harness = TAP::Formatter::Console->new( \%args );
 114
 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:
 120
 121 =over 4
 122
 123 =item * C<verbosity>
 124
 125 Set the verbosity level.
 126
 127 =item * C<verbose>
 128
 129 Printing individual test results to STDOUT.
 130
 131 =item * C<timer>
 132
 133 Append run time for each test to output. Uses L<Time::HiRes> if available.
 134
 135 =item * C<failures>
 136
 137 Show test failures (this is a no-op if C<verbose> is selected).
 138
 139 =item * C<comments>
 140
 141 Show test comments (this is a no-op if C<verbose> is selected).
 142
 143 =item * C<quiet>
 144
 145 Suppressing some test output (mostly failures while tests are running).
 146
 147 =item * C<really_quiet>
 148
 149 Suppressing everything but the tests summary.
 150
 151 =item * C<silent>
 152
 153 Suppressing all output.
 154
 155 =item * C<errors>
 156
 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
 159 true:
 160
 161   errors => 1
 162
 163 =item * C<directives>
 164
 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>.
 167
 168 =item * C<stdout>
 169
 170 A filehandle for catching standard output.
 171
 172 =item * C<color>
 173
 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.
 177
 178 =item * C<jobs>
 179
 180 The number of concurrent jobs this formatter will handle.
 181
 182 =item * C<show_count>
 183
 184 Boolean value.  If false, disables the C<X/Y> test count which shows up while
 185 tests are running.
 186
 187 =back
 188
 189 Any keys for which the value is C<undef> will be ignored.
 190
 191 =cut
 192
 193 # new supplied by TAP::Base
 194
 195 =head3 C<prepare>
 196
 197 Called by Test::Harness before any test output is generated.
 198
 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.
 201
 202 =cut
 203
 204 sub prepare {
 205     my ( $self, @tests ) = @_;
 206
 207     my $longest = 0;
 208
 209     foreach my $test (@tests) {
 210         $longest = length $test if length $test > $longest;
 211     }
 212
 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 $periods = '.' x ( $self->_longest + 2 - length $test );
 222     $periods = " $periods ";
 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     die "Unimplemented.";
 249 }
 250
 251 sub _output_success {
 252     my ( $self, $msg ) = @_;
 253     $self->_output($msg);
 254 }
 255
 256 =head3 C<summary>
 257
 258   $harness->summary( $aggregate );
 259
 260 C<summary> prints the summary report after all tests are run.  The argument is
 261 an aggregate.
 262
 263 =cut
 264
 265 sub summary {
 266     my ( $self, $aggregate ) = @_;
 267
 268     return if $self->silent;
 269
 270     my @t     = $aggregate->descriptions;
 271     my $tests = \@t;
 272
 273     my $runtime = $aggregate->elapsed_timestr;
 274
 275     my $total  = $aggregate->total;
 276     my $passed = $aggregate->passed;
 277
 278     if ( $self->timer ) {
 279         $self->_output( $self->_format_now(), "\n" );
 280     }
 281
 282     # TODO: Check this condition still works when all subtests pass but
 283     # the exit status is nonzero
 284
 285     if ( $aggregate->all_passed ) {
 286         $self->_output_success("All tests successful.\n");
 287     }
 288
 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(
 297                 'failed',
 298                 [ '  Failed test:  ', '  Failed tests:  ' ],
 299                 $test, $parser
 300             );
 301             $self->_output_summary_failure(
 302                 'todo_passed',
 303                 "  TODO passed:   ", $test, $parser
 304             );
 305
 306             # ~TODO this cannot be the default
 307             #$self->_output_summary_failure( 'skipped', "  Tests skipped: " );
 308
 309             if ( my $exit = $parser->exit ) {
 310                 $self->_summary_test_header( $test, $parser );
 311                 $self->_failure_output("  Non-zero exit status: $exit\n");
 312             }
 313             elsif ( my $wait = $parser->wait ) {
 314                 $self->_summary_test_header( $test, $parser );
 315                 $self->_failure_output("  Non-zero wait status: $wait\n");
 316             }
 317
 318             if ( my @errors = $parser->parse_errors ) {
 319                 my $explain;
 320                 if ( @errors > $MAX_ERRORS && !$self->errors ) {
 321                     $explain
 322                       = "Displayed the first $MAX_ERRORS of "
 323                       . scalar(@errors)
 324                       . " TAP syntax errors.\n"
 325                       . "Re-run prove with the -p option to see them all.\n";
 326                     splice @errors, $MAX_ERRORS;
 327                 }
 328                 $self->_summary_test_header( $test, $parser );
 329                 $self->_failure_output(
 330                     sprintf "  Parse errors: %s\n",
 331                     shift @errors
 332                 );
 333                 foreach my $error (@errors) {
 334                     my $spaces = ' ' x 16;
 335                     $self->_failure_output("$spaces$error\n");
 336                 }
 337                 $self->_failure_output($explain) if $explain;
 338             }
 339         }
 340     }
 341     my $files = @$tests;
 342     $self->_output("Files=$files, Tests=$total, $runtime\n");
 343     my $status = $aggregate->get_status;
 344     $self->_output("Result: $status\n");
 345 }
 346
 347 sub _output_summary_failure {
 348     my ( $self, $method, $name, $test, $parser ) = @_;
 349
 350     # ugly hack.  Must rethink this :(
 351     my $output = $method eq 'failed' ? '_failure_output' : '_output';
 352
 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;
 361         while (@results) {
 362             $self->$output( sprintf "$spaces%s\n" => shift @results );
 363         }
 364     }
 365 }
 366
 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);
 373     $self->$output(
 374         sprintf "$test$spaces(Wstat: %d Tests: %d Failed: %d)\n",
 375         $parser->wait, $parser->tests_run, scalar $parser->failed
 376     );
 377     $self->_printed_summary_header(1);
 378 }
 379
 380 sub _output {
 381     my $self = shift;
 382
 383     print { $self->stdout } @_;
 384 }
 385
 386 sub _failure_output {
 387     my $self = shift;
 388
 389     $self->_output(@_);
 390 }
 391
 392 sub _balanced_range {
 393     my ( $self, $limit, @range ) = @_;
 394     @range = $self->_range(@range);
 395     my $line = "";
 396     my @lines;
 397     my $curr = 0;
 398     while (@range) {
 399         if ( $curr < $limit ) {
 400             my $range = ( shift @range ) . ", ";
 401             $line .= $range;
 402             $curr += length $range;
 403         }
 404         elsif (@range) {
 405             $line =~ s/, $//;
 406             push @lines => $line;
 407             $line = '';
 408             $curr = 0;
 409         }
 410     }
 411     if ($line) {
 412         $line =~ s/, $//;
 413         push @lines => $line;
 414     }
 415     return @lines;
 416 }
 417
 418 sub _range {
 419     my ( $self, @numbers ) = @_;
 420
 421     # shouldn't be needed, but subclasses might call this
 422     @numbers = sort { $a <=> $b } @numbers;
 423     my ( $min, @range );
 424
 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 ) {
 430                 $min = $num;
 431             }
 432         }
 433         elsif ( defined $min ) {
 434             push @range => "$min-$num";
 435             undef $min;
 436         }
 437         else {
 438             push @range => $num;
 439         }
 440     }
 441     return @range;
 442 }
 443
 444 sub _get_output_method {
 445     my ( $self, $parser ) = @_;
 446     return $parser->has_problems ? '_failure_output' : '_output';
 447 }
 448
 449 1;