Update Test-Harness to CPAN version 3.39
[perl.git] / cpan / Test-Harness / lib / TAP / Formatter / Console / Session.pm
1 package TAP::Formatter::Console::Session;
2
3 use strict;
4 use warnings;
5
6 use base 'TAP::Formatter::Session';
7
8 my @ACCESSOR;
9
10 BEGIN {
11     my @CLOSURE_BINDING = qw( header result clear_for_close close_test );
12
13     for my $method (@CLOSURE_BINDING) {
14         no strict 'refs';
15         *$method = sub {
16             my $self = shift;
17             return ( $self->{_closures} ||= $self->_closures )->{$method}
18               ->(@_);
19         };
20     }
21 }
22
23 =head1 NAME
24
25 TAP::Formatter::Console::Session - Harness output delegate for default console output
26
27 =head1 VERSION
28
29 Version 3.39
30
31 =cut
32
33 our $VERSION = '3.39';
34
35 =head1 DESCRIPTION
36
37 This provides console orientated output formatting for TAP::Harness.
38
39 =cut
40
41 sub _get_output_result {
42     my $self = shift;
43
44     my @color_map = (
45         {   test => sub { $_->is_test && !$_->is_ok },
46             colors => ['red'],
47         },
48         {   test => sub { $_->is_test && $_->has_skip },
49             colors => [
50                 'white',
51                 'on_blue'
52             ],
53         },
54         {   test => sub { $_->is_test && $_->has_todo },
55             colors => ['yellow'],
56         },
57     );
58
59     my $formatter = $self->formatter;
60     my $parser    = $self->parser;
61
62     return $formatter->_colorizer
63       ? sub {
64         my $result = shift;
65         for my $col (@color_map) {
66             local $_ = $result;
67             if ( $col->{test}->() ) {
68                 $formatter->_set_colors( @{ $col->{colors} } );
69                 last;
70             }
71         }
72         $formatter->_output( $self->_format_for_output($result) );
73         $formatter->_set_colors('reset');
74       }
75       : sub {
76         $formatter->_output( $self->_format_for_output(shift) );
77       };
78 }
79
80 sub _closures {
81     my $self = shift;
82
83     my $parser     = $self->parser;
84     my $formatter  = $self->formatter;
85     my $pretty     = $formatter->_format_name( $self->name );
86     my $show_count = $self->show_count;
87
88     my $really_quiet = $formatter->really_quiet;
89     my $quiet        = $formatter->quiet;
90     my $verbose      = $formatter->verbose;
91     my $directives   = $formatter->directives;
92     my $failures     = $formatter->failures;
93     my $comments     = $formatter->comments;
94
95     my $output_result = $self->_get_output_result;
96
97     my $output          = '_output';
98     my $plan            = '';
99     my $newline_printed = 0;
100
101     my $last_status_printed = 0;
102
103     return {
104         header => sub {
105             $formatter->_output($pretty)
106               unless $really_quiet;
107         },
108
109         result => sub {
110             my $result = shift;
111
112             if ( $result->is_bailout ) {
113                 $formatter->_failure_output(
114                         "Bailout called.  Further testing stopped:  "
115                       . $result->explanation
116                       . "\n" );
117             }
118
119             return if $really_quiet;
120
121             my $is_test = $result->is_test;
122
123             # These are used in close_test - but only if $really_quiet
124             # is false - so it's safe to only set them here unless that
125             # relationship changes.
126
127             if ( !$plan ) {
128                 my $planned = $parser->tests_planned || '?';
129                 $plan = "/$planned ";
130             }
131             $output = $formatter->_get_output_method($parser);
132
133             if ( $show_count and $is_test ) {
134                 my $number = $result->number;
135                 my $now    = CORE::time;
136
137                 # Print status roughly once per second.
138                 # We will always get the first number as a side effect of
139                 # $last_status_printed starting with the value 0, which $now
140                 # will never be. (Unless someone sets their clock to 1970)
141                 if ( $last_status_printed != $now ) {
142                     $formatter->$output("\r$pretty$number$plan");
143                     $last_status_printed = $now;
144                 }
145             }
146
147             if (!$quiet
148                 && (   $verbose
149                     || ( $is_test && $failures && !$result->is_ok )
150                     || ( $comments   && $result->is_comment )
151                     || ( $directives && $result->has_directive ) )
152               )
153             {
154                 unless ($newline_printed) {
155                     $formatter->_output("\n");
156                     $newline_printed = 1;
157                 }
158                 $output_result->($result);
159                 $formatter->_output("\n");
160             }
161         },
162
163         clear_for_close => sub {
164             my $spaces
165               = ' ' x length( '.' . $pretty . $plan . $parser->tests_run );
166             $formatter->$output("\r$spaces");
167         },
168
169         close_test => sub {
170             if ( $show_count && !$really_quiet ) {
171                 $self->clear_for_close;
172                 $formatter->$output("\r$pretty");
173             }
174
175             # Avoid circular references
176             $self->parser(undef);
177             $self->{_closures} = {};
178
179             return if $really_quiet;
180
181             if ( my $skip_all = $parser->skip_all ) {
182                 $formatter->_output("skipped: $skip_all\n");
183             }
184             elsif ( $parser->has_problems ) {
185                 $self->_output_test_failure($parser);
186             }
187             else {
188                 my $time_report = $self->time_report($formatter, $parser);
189                 $formatter->_output( $self->_make_ok_line($time_report) );
190             }
191         },
192     };
193 }
194
195 =head2 C<<      clear_for_close >>
196
197 =head2 C<<      close_test >>
198
199 =head2 C<<      header >>
200
201 =head2 C<<      result >>
202
203 =cut
204
205 1;