Commit | Line | Data |
b965d173 |
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 }, |
27fc0087 |
23 | show_count => sub { shift; shift }, |
69f36734 |
24 | stdout => sub { |
b965d173 |
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 |
b965d173 |
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 | |
27fc0087 |
55 | Version 3.14 |
b965d173 |
56 | |
57 | =cut |
58 | |
27fc0087 |
59 | $VERSION = '3.14'; |
b965d173 |
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 | |
27fc0087 |
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 | |
b965d173 |
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 | |
f7c69158 |
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 | |
b965d173 |
203 | =cut |
204 | |
205 | sub prepare { |
206 | my ( $self, @tests ) = @_; |
207 | |
208 | my $longest = 0; |
209 | |
b965d173 |
210 | foreach my $test (@tests) { |
211 | $longest = length $test if length $test > $longest; |
b965d173 |
212 | } |
213 | |
b965d173 |
214 | $self->_longest($longest); |
215 | } |
216 | |
217 | sub _format_now { strftime "[%H:%M:%S]", localtime } |
218 | |
219 | sub _format_name { |
220 | my ( $self, $test ) = @_; |
f7c69158 |
221 | my $name = $test; |
222 | my $periods = '.' x ( $self->_longest + 4 - length $test ); |
b965d173 |
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( |
27fc0087 |
259 | { name => $test, |
260 | formatter => $self, |
261 | parser => $parser, |
262 | show_count => $self->show_count, |
b965d173 |
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( |
69f36734 |
312 | 'failed', |
313 | [ ' Failed test: ', ' Failed tests: ' ], |
314 | $test, $parser |
b965d173 |
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 | |
69f36734 |
364 | if ( my @r = $parser->$method() ) { |
b965d173 |
365 | $self->_summary_test_header( $test, $parser ); |
69f36734 |
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 ); |
b965d173 |
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; |