Commit | Line | Data |
b965d173 |
1 | package TAP::Formatter::Console::Session; |
2 | |
3 | use strict; |
4 | use TAP::Base; |
5 | |
6 | use vars qw($VERSION @ISA); |
7 | |
8 | @ISA = qw(TAP::Base); |
9 | |
10 | my @ACCESSOR; |
11 | |
12 | BEGIN { |
13 | |
14 | @ACCESSOR = qw( name formatter parser ); |
15 | |
16 | for my $method (@ACCESSOR) { |
17 | no strict 'refs'; |
18 | *$method = sub { shift->{$method} }; |
19 | } |
20 | |
21 | my @CLOSURE_BINDING = qw( header result close_test ); |
22 | |
23 | for my $method (@CLOSURE_BINDING) { |
24 | no strict 'refs'; |
25 | *$method = sub { |
26 | my $self = shift; |
27 | return ( $self->{_closures} ||= $self->_closures )->{$method} |
28 | ->(@_); |
29 | }; |
30 | } |
31 | } |
32 | |
33 | =head1 NAME |
34 | |
35 | TAP::Formatter::Console::Session - Harness output delegate for default console output |
36 | |
37 | =head1 VERSION |
38 | |
69f36734 |
39 | Version 3.06 |
b965d173 |
40 | |
41 | =cut |
42 | |
69f36734 |
43 | $VERSION = '3.06'; |
b965d173 |
44 | |
45 | =head1 DESCRIPTION |
46 | |
47 | This provides console orientated output formatting for TAP::Harness. |
48 | |
49 | =head1 SYNOPSIS |
50 | |
51 | =cut |
52 | |
53 | =head1 METHODS |
54 | |
55 | =head2 Class Methods |
56 | |
57 | =head3 C<new> |
58 | |
59 | my %args = ( |
60 | formatter => $self, |
61 | ) |
62 | my $harness = TAP::Formatter::Console::Session->new( \%args ); |
63 | |
64 | The constructor returns a new C<TAP::Formatter::Console::Session> object. |
65 | |
66 | =over 4 |
67 | |
68 | =item * C<formatter> |
69 | |
70 | =item * C<parser> |
71 | |
72 | =item * C<name> |
73 | |
74 | =back |
75 | |
76 | =cut |
77 | |
78 | sub _initialize { |
79 | my ( $self, $arg_for ) = @_; |
80 | $arg_for ||= {}; |
81 | |
82 | $self->SUPER::_initialize($arg_for); |
83 | my %arg_for = %$arg_for; # force a shallow copy |
84 | |
85 | for my $name (@ACCESSOR) { |
86 | $self->{$name} = delete $arg_for{$name}; |
87 | } |
88 | |
89 | if ( my @props = sort keys %arg_for ) { |
90 | $self->_croak("Unknown arguments to TAP::Harness::new (@props)"); |
91 | } |
92 | |
93 | return $self; |
94 | } |
95 | |
96 | =head3 C<header> |
97 | |
98 | Output test preamble |
99 | |
100 | =head3 C<result> |
101 | |
102 | Called by the harness for each line of TAP it receives. |
103 | |
104 | =head3 C<close_test> |
105 | |
106 | Called to close a test session. |
107 | |
108 | =cut |
109 | |
110 | sub _get_output_result { |
111 | my $self = shift; |
112 | |
113 | my @color_map = ( |
114 | { test => sub { $_->is_test && !$_->is_ok }, |
115 | colors => ['red'], |
116 | }, |
117 | { test => sub { $_->is_test && $_->has_skip }, |
118 | colors => [ |
119 | 'white', |
120 | 'on_blue' |
121 | ], |
122 | }, |
123 | { test => sub { $_->is_test && $_->has_todo }, |
124 | colors => ['yellow'], |
125 | }, |
126 | ); |
127 | |
128 | my $formatter = $self->formatter; |
129 | my $parser = $self->parser; |
130 | |
131 | return $formatter->_colorizer |
132 | ? sub { |
133 | my $result = shift; |
134 | for my $col (@color_map) { |
135 | local $_ = $result; |
136 | if ( $col->{test}->() ) { |
137 | $formatter->_set_colors( @{ $col->{colors} } ); |
138 | last; |
139 | } |
140 | } |
141 | $formatter->_output( $result->as_string ); |
142 | $formatter->_set_colors('reset'); |
143 | } |
144 | : sub { |
145 | $formatter->_output( shift->as_string ); |
146 | }; |
147 | } |
148 | |
149 | sub _closures { |
150 | my $self = shift; |
151 | |
152 | my $parser = $self->parser; |
153 | my $formatter = $self->formatter; |
154 | my $show_count = $self->_should_show_count; |
155 | my $pretty = $formatter->_format_name( $self->name ); |
156 | |
157 | my $really_quiet = $formatter->really_quiet; |
158 | my $quiet = $formatter->quiet; |
159 | my $verbose = $formatter->verbose; |
160 | my $directives = $formatter->directives; |
161 | my $failures = $formatter->failures; |
162 | |
163 | my $output_result = $self->_get_output_result; |
164 | |
165 | my $output = '_output'; |
166 | my $plan = ''; |
167 | my $newline_printed = 0; |
168 | |
169 | my $last_status_printed = 0; |
170 | |
171 | return { |
172 | header => sub { |
173 | $formatter->_output($pretty) |
174 | unless $really_quiet; |
175 | }, |
176 | |
177 | result => sub { |
178 | my $result = shift; |
179 | |
180 | if ( $result->is_bailout ) { |
181 | $formatter->_failure_output( |
182 | "Bailout called. Further testing stopped: " |
183 | . $result->explanation |
184 | . "\n" ); |
185 | } |
186 | |
187 | return if $really_quiet; |
188 | |
189 | my $is_test = $result->is_test; |
190 | |
191 | # These are used in close_test - but only if $really_quiet |
192 | # is false - so it's safe to only set them here unless that |
193 | # relationship changes. |
194 | |
195 | if ( !$plan ) { |
196 | my $planned = $parser->tests_planned || '?'; |
197 | $plan = "/$planned "; |
198 | } |
199 | $output = $formatter->_get_output_method($parser); |
200 | |
201 | if ( $show_count and $is_test ) { |
202 | my $number = $result->number; |
203 | my $now = CORE::time; |
204 | |
205 | # Print status on first number, and roughly once per second |
206 | if ( ( $number == 1 ) |
207 | || ( $last_status_printed != $now ) ) |
208 | { |
209 | $formatter->$output("\r$pretty$number$plan"); |
210 | $last_status_printed = $now; |
211 | } |
212 | } |
213 | |
214 | if (!$quiet |
215 | && ( ( $verbose && !$failures ) |
216 | || ( $is_test && $failures && !$result->is_ok ) |
217 | || ( $result->has_directive && $directives ) ) |
218 | ) |
219 | { |
220 | unless ($newline_printed) { |
221 | $formatter->_output("\n"); |
222 | $newline_printed = 1; |
223 | } |
224 | $output_result->($result); |
225 | $formatter->_output("\n"); |
226 | } |
227 | }, |
228 | |
229 | close_test => sub { |
230 | return if $really_quiet; |
231 | |
232 | if ($show_count) { |
233 | my $spaces = ' ' x |
234 | length( '.' . $pretty . $plan . $parser->tests_run ); |
235 | $formatter->$output("\r$spaces\r$pretty"); |
236 | } |
237 | |
238 | if ( my $skip_all = $parser->skip_all ) { |
239 | $formatter->_output("skipped: $skip_all\n"); |
240 | } |
241 | elsif ( $parser->has_problems ) { |
242 | $self->_output_test_failure($parser); |
243 | } |
244 | else { |
245 | my $time_report = ''; |
246 | if ( $formatter->timer ) { |
247 | my $start_time = $parser->start_time; |
248 | my $end_time = $parser->end_time; |
249 | if ( defined $start_time and defined $end_time ) { |
250 | my $elapsed = $end_time - $start_time; |
251 | $time_report |
252 | = $self->time_is_hires |
253 | ? sprintf( ' %8d ms', $elapsed * 1000 ) |
254 | : sprintf( ' %8s s', $elapsed || '<1' ); |
255 | } |
256 | } |
257 | |
258 | $formatter->_output("ok$time_report\n"); |
259 | } |
260 | }, |
261 | }; |
262 | } |
263 | |
264 | sub _should_show_count { |
265 | |
266 | # we need this because if someone tries to redirect the output, it can get |
267 | # very garbled from the carriage returns (\r) in the count line. |
268 | return !shift->formatter->verbose && -t STDOUT; |
269 | } |
270 | |
271 | sub _output_test_failure { |
272 | my ( $self, $parser ) = @_; |
273 | my $formatter = $self->formatter; |
274 | return if $formatter->really_quiet; |
275 | |
276 | my $tests_run = $parser->tests_run; |
277 | my $tests_planned = $parser->tests_planned; |
278 | |
279 | my $total |
280 | = defined $tests_planned |
281 | ? $tests_planned |
282 | : $tests_run; |
283 | |
284 | my $passed = $parser->passed; |
285 | |
286 | # The total number of fails includes any tests that were planned but |
287 | # didn't run |
288 | my $failed = $parser->failed + $total - $tests_run; |
289 | my $exit = $parser->exit; |
290 | |
291 | # TODO: $flist isn't used anywhere |
292 | # my $flist = join ", " => $formatter->range( $parser->failed ); |
293 | |
294 | if ( my $exit = $parser->exit ) { |
295 | my $wstat = $parser->wait; |
296 | my $status = sprintf( "%d (wstat %d, 0x%x)", $exit, $wstat, $wstat ); |
297 | $formatter->_failure_output(" Dubious, test returned $status\n"); |
298 | } |
299 | |
300 | if ( $failed == 0 ) { |
301 | $formatter->_failure_output( |
302 | $total |
303 | ? " All $total subtests passed " |
304 | : ' No subtests run ' |
305 | ); |
306 | } |
307 | else { |
308 | $formatter->_failure_output(" Failed $failed/$total subtests "); |
309 | if ( !$total ) { |
310 | $formatter->_failure_output("\nNo tests run!"); |
311 | } |
312 | } |
313 | |
314 | if ( my $skipped = $parser->skipped ) { |
315 | $passed -= $skipped; |
316 | my $test = 'subtest' . ( $skipped != 1 ? 's' : '' ); |
317 | $formatter->_output( |
318 | "\n\t(less $skipped skipped $test: $passed okay)"); |
319 | } |
320 | |
321 | if ( my $failed = $parser->todo_passed ) { |
322 | my $test = $failed > 1 ? 'tests' : 'test'; |
323 | $formatter->_output( |
324 | "\n\t($failed TODO $test unexpectedly succeeded)"); |
325 | } |
326 | |
327 | $formatter->_output("\n"); |
328 | } |
329 | |
330 | 1; |