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