Commit | Line | Data |
3fea05b9 |
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; |