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 }, |
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; |