File Coverage

blib/lib/TAP/Formatter/Base.pm
Criterion Covered Total %
statement 165 182 90.6
branch 56 70 80.0
condition 12 14 85.7
subroutine 22 24 91.6
pod 7 7 100.0
total 262 297 88.2


line stmt bran cond sub pod time code
1             package TAP::Formatter::Base;
2              
3 17     17   5317 use strict;
  17         24  
  17         466  
4 17     17   66 use warnings;
  17         20  
  17         452  
5 17     17   57 use base 'TAP::Base';
  17         19  
  17         1358  
6 17     17   971 use POSIX qw(strftime);
  17         10081  
  17         82  
7              
8             my $MAX_ERRORS = 5;
9             my %VALIDATION_FOR;
10              
11             BEGIN {
12             %VALIDATION_FOR = (
13 2         3 directives => sub { shift; shift },
  2         10  
14 66         85 verbosity => sub { shift; shift },
  66         135  
15 0         0 normalize => sub { shift; shift },
  0         0  
16 41         29 timer => sub { shift; shift },
  41         105  
17 6         4 failures => sub { shift; shift },
  6         19  
18 3         3 comments => sub { shift; shift },
  3         12  
19 1         2 errors => sub { shift; shift },
  1         10  
20 40         38 color => sub { shift; shift },
  40         158  
21 84         89 jobs => sub { shift; shift },
  84         230  
22 2         4 show_count => sub { shift; shift },
  2         15  
23             stdout => sub {
24 15         23 my ( $self, $ref ) = @_;
25              
26 15 100       45 $self->_croak("option 'stdout' needs a filehandle")
27             unless $self->_is_filehandle($ref);
28              
29 13         42 return $ref;
30             },
31 17     17   10704 );
32              
33             sub _is_filehandle {
34 15     15   21 my ( $self, $ref ) = @_;
35              
36 15 50       33 return 0 if !defined $ref;
37              
38 15 100       48 return 1 if ref $ref eq 'GLOB'; # lexical filehandle
39 13 100 100     44 return 1 if !ref $ref && ref \$ref eq 'GLOB'; # bare glob like *STDOUT
40              
41 12 100       17 return 1 if eval { $ref->can('print') };
  12         100  
42              
43 2         17 return 0;
44             }
45              
46 17         46 my @getter_setters = qw(
47             _longest
48             _printed_summary_header
49             _colorizer
50             );
51              
52 17         190 __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 88     88   120 my ( $self, $arg_for ) = @_;
80 88   100     256 $arg_for ||= {};
81              
82 88         309 $self->SUPER::_initialize($arg_for);
83 88         297 my %arg_for = %$arg_for; # force a shallow copy
84              
85 88         273 $self->verbosity(0);
86              
87 88         339 for my $name ( keys %VALIDATION_FOR ) {
88 952         700 my $property = delete $arg_for{$name};
89 952 100       1222 if ( defined $property ) {
90 260         241 my $validate = $VALIDATION_FOR{$name};
91 260         519 $self->$name( $self->$validate($property) );
92             }
93             }
94              
95 86 50       281 if ( my @props = keys %arg_for ) {
96 0         0 $self->_croak(
97             "Unknown arguments to " . __PACKAGE__ . "::new (@props)" );
98             }
99              
100 86 100       269 $self->stdout( \*STDOUT ) unless $self->stdout;
101              
102 86 100       194 if ( $self->color ) {
103 1         336 require TAP::Formatter::Color;
104 1         9 $self->_colorizer( TAP::Formatter::Color->new );
105             }
106              
107 86         297 return $self;
108             }
109              
110 423     423 1 896 sub verbose { shift->verbosity >= 1 }
111 398     398 1 766 sub quiet { shift->verbosity <= -1 }
112 142     142 1 274 sub really_quiet { shift->verbosity <= -2 }
113 44     44 1 113 sub silent { shift->verbosity <= -3 }
114              
115             =head1 METHODS
116              
117             =head2 Class Methods
118              
119             =head3 C
120              
121             my %args = (
122             verbose => 1,
123             )
124             my $harness = TAP::Formatter::Console->new( \%args );
125              
126             The constructor returns a new C object. If
127             a L is created with no C a
128             C 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
135              
136             Set the verbosity level.
137              
138             =item * C
139              
140             Printing individual test results to STDOUT.
141              
142             =item * C
143              
144             Append run time for each test to output. Uses L if available.
145              
146             =item * C
147              
148             Show test failures (this is a no-op if C is selected).
149              
150             =item * C
151              
152             Show test comments (this is a no-op if C is selected).
153              
154             =item * C
155              
156             Suppressing some test output (mostly failures while tests are running).
157              
158             =item * C
159              
160             Suppressing everything but the tests summary.
161              
162             =item * C
163              
164             Suppressing all output.
165              
166             =item * C
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
175              
176             If set to a true value, only test results with directives will be displayed.
177             This overrides other settings such as C, C, or C.
178              
179             =item * C
180              
181             A filehandle for catching standard output.
182              
183             =item * C
184              
185             If defined specifies whether color output is desired. If C 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
190              
191             The number of concurrent jobs this formatter will handle.
192              
193             =item * C
194              
195             Boolean value. If false, disables the C test count which shows up while
196             tests are running.
197              
198             =back
199              
200             Any keys for which the value is C will be ignored.
201              
202             =cut
203              
204             # new supplied by TAP::Base
205              
206             =head3 C
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 79     79 1 154 my ( $self, @tests ) = @_;
217              
218 79         85 my $longest = 0;
219              
220 79         225 for my $test (@tests) {
221 107 100       270 $longest = length $test if length $test > $longest;
222             }
223              
224 79         254 $self->_longest($longest);
225             }
226              
227 0     0   0 sub _format_now { strftime "[%H:%M:%S]", localtime }
228              
229             sub _format_name {
230 105     105   169 my ( $self, $test ) = @_;
231 105         157 my $name = $test;
232 105         482 my $periods = '.' x ( $self->_longest + 2 - length $test );
233 105         236 $periods = " $periods ";
234              
235 105 50       308 if ( $self->timer ) {
236 0         0 my $stamp = $self->_format_now();
237 0         0 return "$stamp $name$periods";
238             }
239             else {
240 105         330 return "$name$periods";
241             }
242              
243             }
244              
245             =head3 C
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 0     0 1 0 die "Unimplemented.";
260             }
261              
262             sub _output_success {
263 18     18   42 my ( $self, $msg ) = @_;
264 18         52 $self->_output($msg);
265             }
266              
267             =head3 C
268              
269             $harness->summary( $aggregate );
270              
271             C 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 44     44 1 67 my ( $self, $aggregate, $interrupted ) = @_;
280              
281 44 100       126 return if $self->silent;
282              
283 38         150 my @t = $aggregate->descriptions;
284 38         53 my $tests = \@t;
285              
286 38         114 my $runtime = $aggregate->elapsed_timestr;
287              
288 38         2970 my $total = $aggregate->total;
289 38         104 my $passed = $aggregate->passed;
290              
291 38 50       364 if ( $self->timer ) {
292 0         0 $self->_output( $self->_format_now(), "\n" );
293             }
294              
295 38 50       82 $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 38 100       100 if ( $aggregate->all_passed ) {
302 24         73 $self->_output_success("All tests successful.\n");
303             }
304              
305             # ~TODO option where $aggregate->skipped generates reports
306 38 100 100     394 if ( $total != $passed or $aggregate->has_problems ) {
307 15         53 $self->_output("\nTest Summary Report");
308 15         293 $self->_output("\n-------------------\n");
309 15         200 for my $test (@$tests) {
310 15         89 $self->_printed_summary_header(0);
311 15         53 my ($parser) = $aggregate->parsers($test);
312 15         95 $self->_output_summary_failure(
313             'failed',
314             [ ' Failed test: ', ' Failed tests: ' ],
315             $test, $parser
316             );
317 15         39 $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 15 50       37 if ( my $exit = $parser->exit ) {
    50          
326 0         0 $self->_summary_test_header( $test, $parser );
327 0         0 $self->_failure_output(" Non-zero exit status: $exit\n");
328             }
329             elsif ( my $wait = $parser->wait ) {
330 0         0 $self->_summary_test_header( $test, $parser );
331 0         0 $self->_failure_output(" Non-zero wait status: $wait\n");
332             }
333              
334 15 100       37 if ( my @errors = $parser->parse_errors ) {
335 4         6 my $explain;
336 4 50 33     20 if ( @errors > $MAX_ERRORS && !$self->errors ) {
337 0         0 $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 0         0 splice @errors, $MAX_ERRORS;
343             }
344 4         13 $self->_summary_test_header( $test, $parser );
345 4         20 $self->_failure_output(
346             sprintf " Parse errors: %s\n",
347             shift @errors
348             );
349 4         52 for my $error (@errors) {
350 0         0 my $spaces = ' ' x 16;
351 0         0 $self->_failure_output("$spaces$error\n");
352             }
353 4 50       14 $self->_failure_output($explain) if $explain;
354             }
355             }
356             }
357 38         64 my $files = @$tests;
358 38         165 $self->_output("Files=$files, Tests=$total, $runtime\n");
359 38         559 my $status = $aggregate->get_status;
360 38         133 $self->_output("Result: $status\n");
361             }
362              
363             sub _output_summary_failure {
364 30     30   51 my ( $self, $method, $name, $test, $parser ) = @_;
365              
366             # ugly hack. Must rethink this :(
367 30 100       76 my $output = $method eq 'failed' ? '_failure_output' : '_output';
368              
369 30 100       77 if ( my @r = $parser->$method() ) {
370 13         46 $self->_summary_test_header( $test, $parser );
371 13 100       48 my ( $singular, $plural )
372             = 'ARRAY' eq ref $name ? @$name : ( $name, $name );
373 13 50       55 $self->$output( @r == 1 ? $singular : $plural );
374 13         140 my @results = $self->_balanced_range( 40, @r );
375 13         56 $self->$output( sprintf "%s\n" => shift @results );
376 13         116 my $spaces = ' ' x 16;
377 13         49 while (@results) {
378 0         0 $self->$output( sprintf "$spaces%s\n" => shift @results );
379             }
380             }
381             }
382              
383             sub _summary_test_header {
384 17     17   28 my ( $self, $test, $parser ) = @_;
385 17 100       42 return if $self->_printed_summary_header;
386 15         41 my $spaces = ' ' x ( $self->_longest - length $test );
387 15 50       49 $spaces = ' ' unless $spaces;
388 15         43 my $output = $self->_get_output_method($parser);
389 15         48 my $wait = $parser->wait;
390 15 50       39 defined $wait or $wait = '(none)';
391 15         65 $self->$output(
392             sprintf "$test$spaces(Wstat: %s Tests: %d Failed: %d)\n",
393             $wait, $parser->tests_run, scalar $parser->failed
394             );
395 15         210 $self->_printed_summary_header(1);
396             }
397              
398             sub _output {
399 162     162   195 my $self = shift;
400              
401 162         127 print { $self->stdout } @_;
  162         322  
402             }
403              
404             sub _failure_output {
405 68     68   76 my $self = shift;
406              
407 68         189 $self->_output(@_);
408             }
409              
410             sub _balanced_range {
411 14     14   639 my ( $self, $limit, @range ) = @_;
412 14         41 @range = $self->_range(@range);
413 14         22 my $line = "";
414 14         11 my @lines;
415 14         17 my $curr = 0;
416 14         31 while (@range) {
417 17 100       39 if ( $curr < $limit ) {
    50          
418 16         28 my $range = ( shift @range ) . ", ";
419 16         29 $line .= $range;
420 16         39 $curr += length $range;
421             }
422             elsif (@range) {
423 1         5 $line =~ s/, $//;
424 1         1 push @lines => $line;
425 1         2 $line = '';
426 1         2 $curr = 0;
427             }
428             }
429 14 50       27 if ($line) {
430 14         64 $line =~ s/, $//;
431 14         23 push @lines => $line;
432             }
433 14         34 return @lines;
434             }
435              
436             sub _range {
437 15     15   1017 my ( $self, @numbers ) = @_;
438              
439             # shouldn't be needed, but subclasses might call this
440 15         35 @numbers = sort { $a <=> $b } @numbers;
  20         18  
441 15         25 my ( $min, @range );
442              
443 15         54 for my $i ( 0 .. $#numbers ) {
444 25         36 my $num = $numbers[$i];
445 25         37 my $next = $numbers[ $i + 1 ];
446 25 100 100     366 if ( defined $next && $next == $num + 1 ) {
    100          
447 6 100       12 if ( !defined $min ) {
448 4         5 $min = $num;
449             }
450             }
451             elsif ( defined $min ) {
452 4         7 push @range => "$min-$num";
453 4         5 undef $min;
454             }
455             else {
456 15         31 push @range => $num;
457             }
458             }
459 15         46 return @range;
460             }
461              
462             sub _get_output_method {
463 54     54   65 my ( $self, $parser ) = @_;
464 54 100       109 return $parser->has_problems ? '_failure_output' : '_output';
465             }
466              
467             1;