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