git.maemo.org Git - dh-make-perl/blob - dev/i386/libtest-harness-perl/libtest-harness-perl-3.12/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       _printed_summary_header
  35       _colorizer
  36     );
  37
  38     for my $method ( @getter_setters, keys %VALIDATION_FOR ) {
  39         no strict 'refs';
  40         *$method = sub {
  41             my $self = shift;
  42             return $self->{$method} unless @_;
  43             $self->{$method} = shift;
  44         };
  45     }
  46 }
  47
  48 =head1 NAME
  49
  50 TAP::Formatter::Console - Harness output delegate for default console output
  51
  52 =head1 VERSION
  53
  54 Version 3.12
  55
  56 =cut
  57
  58 $VERSION = '3.12';
  59
  60 =head1 DESCRIPTION
  61
  62 This provides console orientated output formatting for TAP::Harness.
  63
  64 =head1 SYNOPSIS
  65
  66  use TAP::Formatter::Console;
  67  my $harness = TAP::Formatter::Console->new( \%args );
  68
  69 =cut
  70
  71 sub _initialize {
  72     my ( $self, $arg_for ) = @_;
  73     $arg_for ||= {};
  74
  75     $self->SUPER::_initialize($arg_for);
  76     my %arg_for = %$arg_for;    # force a shallow copy
  77
  78     $self->verbosity(0);
  79
  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) );
  85         }
  86     }
  87
  88     if ( my @props = keys %arg_for ) {
  89         $self->_croak(
  90             "Unknown arguments to " . __PACKAGE__ . "::new (@props)" );
  91     }
  92
  93     $self->stdout( \*STDOUT ) unless $self->stdout;
  94
  95     if ( $self->color ) {
  96         require TAP::Formatter::Color;
  97         $self->_colorizer( TAP::Formatter::Color->new );
  98     }
  99
 100     return $self;
 101 }
 102
 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 }
 107
 108 =head1 METHODS
 109
 110 =head2 Class Methods
 111
 112 =head3 C<new>
 113
 114  my %args = (
 115     verbose => 1,
 116  )
 117  my $harness = TAP::Formatter::Console->new( \%args );
 118
 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:
 124
 125 =over 4
 126
 127 =item * C<verbosity>
 128
 129 Set the verbosity level.
 130
 131 =item * C<verbose>
 132
 133 Printing individual test results to STDOUT.
 134
 135 =item * C<timer>
 136
 137 Append run time for each test to output. Uses L<Time::HiRes> if available.
 138
 139 =item * C<failures>
 140
 141 Only show test failures (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> or C<failures>.
 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 =back
 183
 184 Any keys for which the value is C<undef> will be ignored.
 185
 186 =cut
 187
 188 # new supplied by TAP::Base
 189
 190 =head3 C<prepare>
 191
 192 Called by Test::Harness before any test output is generated.
 193
 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.
 196
 197 =cut
 198
 199 sub prepare {
 200     my ( $self, @tests ) = @_;
 201
 202     my $longest = 0;
 203
 204     foreach my $test (@tests) {
 205         $longest = length $test if length $test > $longest;
 206     }
 207
 208     $self->_longest($longest);
 209 }
 210
 211 sub _format_now { strftime "[%H:%M:%S]", localtime }
 212
 213 sub _format_name {
 214     my ( $self, $test ) = @_;
 215     my $name = $test;
 216     my $periods = '.' x ( $self->_longest + 4 - length $test );
 217
 218     if ( $self->timer ) {
 219         my $stamp = $self->_format_now();
 220         return "$stamp $name$periods";
 221     }
 222     else {
 223         return "$name$periods";
 224     }
 225
 226 }
 227
 228 =head3 C<open_test>
 229
 230 Called to create a new test session. A test session looks like this:
 231
 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;
 236     }
 237     $session->close_test;
 238
 239 =cut
 240
 241 sub open_test {
 242     my ( $self, $test, $parser ) = @_;
 243
 244     my $class
 245       = $self->jobs > 1
 246       ? 'TAP::Formatter::Console::ParallelSession'
 247       : 'TAP::Formatter::Console::Session';
 248
 249     eval "require $class";
 250     $self->_croak($@) if $@;
 251
 252     my $session = $class->new(
 253         {   name      => $test,
 254             formatter => $self,
 255             parser    => $parser
 256         }
 257     );
 258
 259     $session->header;
 260
 261     return $session;
 262 }
 263
 264 =head3 C<summary>
 265
 266   $harness->summary( $aggregate );
 267
 268 C<summary> prints the summary report after all tests are run.  The argument is
 269 an aggregate.
 270
 271 =cut
 272
 273 sub summary {
 274     my ( $self, $aggregate ) = @_;
 275
 276     return if $self->silent;
 277
 278     my @t     = $aggregate->descriptions;
 279     my $tests = \@t;
 280
 281     my $runtime = $aggregate->elapsed_timestr;
 282
 283     my $total  = $aggregate->total;
 284     my $passed = $aggregate->passed;
 285
 286     if ( $self->timer ) {
 287         $self->_output( $self->_format_now(), "\n" );
 288     }
 289
 290     # TODO: Check this condition still works when all subtests pass but
 291     # the exit status is nonzero
 292
 293     if ( $aggregate->all_passed ) {
 294         $self->_output("All tests successful.\n");
 295     }
 296
 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(
 305                 'failed',
 306                 [ '  Failed test:  ', '  Failed tests:  ' ],
 307                 $test, $parser
 308             );
 309             $self->_output_summary_failure(
 310                 'todo_passed',
 311                 "  TODO passed:   ", $test, $parser
 312             );
 313
 314             # ~TODO this cannot be the default
 315             #$self->_output_summary_failure( 'skipped', "  Tests skipped: " );
 316
 317             if ( my $exit = $parser->exit ) {
 318                 $self->_summary_test_header( $test, $parser );
 319                 $self->_failure_output("  Non-zero exit status: $exit\n");
 320             }
 321
 322             if ( my @errors = $parser->parse_errors ) {
 323                 my $explain;
 324                 if ( @errors > $MAX_ERRORS && !$self->errors ) {
 325                     $explain
 326                       = "Displayed the first $MAX_ERRORS of "
 327                       . scalar(@errors)
 328                       . " TAP syntax errors.\n"
 329                       . "Re-run prove with the -p option to see them all.\n";
 330                     splice @errors, $MAX_ERRORS;
 331                 }
 332                 $self->_summary_test_header( $test, $parser );
 333                 $self->_failure_output(
 334                     sprintf "  Parse errors: %s\n",
 335                     shift @errors
 336                 );
 337                 foreach my $error (@errors) {
 338                     my $spaces = ' ' x 16;
 339                     $self->_failure_output("$spaces$error\n");
 340                 }
 341                 $self->_failure_output($explain) if $explain;
 342             }
 343         }
 344     }
 345     my $files = @$tests;
 346     $self->_output("Files=$files, Tests=$total, $runtime\n");
 347     my $status = $aggregate->get_status;
 348     $self->_output("Result: $status\n");
 349 }
 350
 351 sub _output_summary_failure {
 352     my ( $self, $method, $name, $test, $parser ) = @_;
 353
 354     # ugly hack.  Must rethink this :(
 355     my $output = $method eq 'failed' ? '_failure_output' : '_output';
 356
 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;
 365         while (@results) {
 366             $self->$output( sprintf "$spaces%s\n" => shift @results );
 367         }
 368     }
 369 }
 370
 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);
 377     $self->$output(
 378         sprintf "$test$spaces(Wstat: %d Tests: %d Failed: %d)\n",
 379         $parser->wait, $parser->tests_run, scalar $parser->failed
 380     );
 381     $self->_printed_summary_header(1);
 382 }
 383
 384 sub _output {
 385     my $self = shift;
 386
 387     print { $self->stdout } @_;
 388 }
 389
 390 # Use _colorizer delegate to set output color. NOP if we have no delegate
 391 sub _set_colors {
 392     my ( $self, @colors ) = @_;
 393     if ( my $colorizer = $self->_colorizer ) {
 394         my $output_func = $self->{_output_func} ||= sub {
 395             $self->_output(@_);
 396         };
 397         $colorizer->set_color( $output_func, $_ ) for @colors;
 398     }
 399 }
 400
 401 sub _failure_output {
 402     my $self = shift;
 403     $self->_set_colors('red');
 404     my $out = join '', @_;
 405     my $has_newline = chomp $out;
 406     $self->_output($out);
 407     $self->_set_colors('reset');
 408     $self->_output($/)
 409       if $has_newline;
 410 }
 411
 412 sub _balanced_range {
 413     my ( $self, $limit, @range ) = @_;
 414     @range = $self->_range(@range);
 415     my $line = "";
 416     my @lines;
 417     my $curr = 0;
 418     while (@range) {
 419         if ( $curr < $limit ) {
 420             my $range = ( shift @range ) . ", ";
 421             $line .= $range;
 422             $curr += length $range;
 423         }
 424         elsif (@range) {
 425             $line =~ s/, $//;
 426             push @lines => $line;
 427             $line = '';
 428             $curr = 0;
 429         }
 430     }
 431     if ($line) {
 432         $line =~ s/, $//;
 433         push @lines => $line;
 434     }
 435     return @lines;
 436 }
 437
 438 sub _range {
 439     my ( $self, @numbers ) = @_;
 440
 441     # shouldn't be needed, but subclasses might call this
 442     @numbers = sort { $a <=> $b } @numbers;
 443     my ( $min, @range );
 444
 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 ) {
 450                 $min = $num;
 451             }
 452         }
 453         elsif ( defined $min ) {
 454             push @range => "$min-$num";
 455             undef $min;
 456         }
 457         else {
 458             push @range => $num;
 459         }
 460     }
 461     return @range;
 462 }
 463
 464 sub _get_output_method {
 465     my ( $self, $parser ) = @_;
 466     return $parser->has_problems ? '_failure_output' : '_output';
 467 }
 468
 469 1;