1package Test2::Formatter::TAP;
2use strict;
3use warnings;
4
5our $VERSION = '1.302175';
6
7use Test2::Util qw/clone_io/;
8
9use Test2::Util::HashBase qw{
10    no_numbers handles _encoding _last_fh
11    -made_assertion
12};
13
14sub OUT_STD() { 0 }
15sub OUT_ERR() { 1 }
16
17BEGIN { require Test2::Formatter; our @ISA = qw(Test2::Formatter) }
18
19my $supports_tables;
20sub supports_tables {
21    if (!defined $supports_tables) {
22        local $SIG{__DIE__} = 'DEFAULT';
23        local $@;
24        $supports_tables
25            = ($INC{'Term/Table.pm'} && $INC{'Term/Table/Util.pm'})
26            || eval { require Term::Table; require Term::Table::Util; 1 }
27            || 0;
28    }
29    return $supports_tables;
30}
31
32sub _autoflush {
33    my($fh) = pop;
34    my $old_fh = select $fh;
35    $| = 1;
36    select $old_fh;
37}
38
39_autoflush(\*STDOUT);
40_autoflush(\*STDERR);
41
42sub hide_buffered { 1 }
43
44sub init {
45    my $self = shift;
46
47    $self->{+HANDLES} ||= $self->_open_handles;
48    if(my $enc = delete $self->{encoding}) {
49        $self->encoding($enc);
50    }
51}
52
53sub _open_handles {
54    my $self = shift;
55
56    require Test2::API;
57    my $out = clone_io(Test2::API::test2_stdout());
58    my $err = clone_io(Test2::API::test2_stderr());
59
60    _autoflush($out);
61    _autoflush($err);
62
63    return [$out, $err];
64}
65
66sub encoding {
67    my $self = shift;
68
69    if ($] ge "5.007003" and @_) {
70        my ($enc) = @_;
71        my $handles = $self->{+HANDLES};
72
73        # https://rt.perl.org/Public/Bug/Display.html?id=31923
74        # If utf8 is requested we use ':utf8' instead of ':encoding(utf8)' in
75        # order to avoid the thread segfault.
76        if ($enc =~ m/^utf-?8$/i) {
77            binmode($_, ":utf8") for @$handles;
78        }
79        else {
80            binmode($_, ":encoding($enc)") for @$handles;
81        }
82        $self->{+_ENCODING} = $enc;
83    }
84
85    return $self->{+_ENCODING};
86}
87
88if ($^C) {
89    no warnings 'redefine';
90    *write = sub {};
91}
92sub write {
93    my ($self, $e, $num, $f) = @_;
94
95    # The most common case, a pass event with no amnesty and a normal name.
96    return if $self->print_optimal_pass($e, $num);
97
98    $f ||= $e->facet_data;
99
100    $self->encoding($f->{control}->{encoding}) if $f->{control}->{encoding};
101
102    my @tap = $self->event_tap($f, $num) or return;
103
104    $self->{+MADE_ASSERTION} = 1 if $f->{assert};
105
106    my $nesting = $f->{trace}->{nested} || 0;
107    my $handles = $self->{+HANDLES};
108    my $indent = '    ' x $nesting;
109
110    # Local is expensive! Only do it if we really need to.
111    local($\, $,) = (undef, '') if $\ || $,;
112    for my $set (@tap) {
113        no warnings 'uninitialized';
114        my ($hid, $msg) = @$set;
115        next unless $msg;
116        my $io = $handles->[$hid] or next;
117
118        print $io "\n"
119            if $ENV{HARNESS_ACTIVE}
120            && $hid == OUT_ERR
121            && $self->{+_LAST_FH} != $io
122            && $msg =~ m/^#\s*Failed( \(TODO\))? test /;
123
124        $msg =~ s/^/$indent/mg if $nesting;
125        print $io $msg;
126        $self->{+_LAST_FH} = $io;
127    }
128}
129
130sub print_optimal_pass {
131    my ($self, $e, $num) = @_;
132
133    my $type = ref($e);
134
135    # Only optimal if this is a Pass or a passing Ok
136    return unless $type eq 'Test2::Event::Pass' || ($type eq 'Test2::Event::Ok' && $e->{pass});
137
138    # Amnesty requires further processing (todo is a form of amnesty)
139    return if ($e->{amnesty} && @{$e->{amnesty}}) || defined($e->{todo});
140
141    # A name with a newline or hash symbol needs extra processing
142    return if defined($e->{name}) && (-1 != index($e->{name}, "\n") || -1 != index($e->{name}, '#'));
143
144    my $ok = 'ok';
145    $ok .= " $num" if $num && !$self->{+NO_NUMBERS};
146    $ok .= defined($e->{name}) ? " - $e->{name}\n" : "\n";
147
148    if (my $nesting = $e->{trace}->{nested}) {
149        my $indent = '    ' x $nesting;
150        $ok = "$indent$ok";
151    }
152
153    my $io = $self->{+HANDLES}->[OUT_STD];
154
155    local($\, $,) = (undef, '') if $\ || $,;
156    print $io $ok;
157    $self->{+_LAST_FH} = $io;
158
159    return 1;
160}
161
162sub event_tap {
163    my ($self, $f, $num) = @_;
164
165    my @tap;
166
167    # If this IS the first event the plan should come first
168    # (plan must be before or after assertions, not in the middle)
169    push @tap => $self->plan_tap($f) if $f->{plan} && !$self->{+MADE_ASSERTION};
170
171    # The assertion is most important, if present.
172    if ($f->{assert}) {
173        push @tap => $self->assert_tap($f, $num);
174        push @tap => $self->debug_tap($f, $num) unless $f->{assert}->{no_debug} || $f->{assert}->{pass};
175    }
176
177    # Almost as important as an assertion
178    push @tap => $self->error_tap($f) if $f->{errors};
179
180    # Now lets see the diagnostics messages
181    push @tap => $self->info_tap($f) if $f->{info};
182
183    # If this IS NOT the first event the plan should come last
184    # (plan must be before or after assertions, not in the middle)
185    push @tap => $self->plan_tap($f) if $self->{+MADE_ASSERTION} && $f->{plan};
186
187    # Bail out
188    push @tap => $self->halt_tap($f) if $f->{control}->{halt};
189
190    return @tap if @tap;
191    return @tap if $f->{control}->{halt};
192    return @tap if grep { $f->{$_} } qw/assert plan info errors/;
193
194    # Use the summary as a fallback if nothing else is usable.
195    return $self->summary_tap($f, $num);
196}
197
198sub error_tap {
199    my $self = shift;
200    my ($f) = @_;
201
202    my $IO = ($f->{amnesty} && @{$f->{amnesty}}) ? OUT_STD : OUT_ERR;
203
204    return map {
205        my $details = $_->{details};
206
207        my $msg;
208        if (ref($details)) {
209            require Data::Dumper;
210            my $dumper = Data::Dumper->new([$details])->Indent(2)->Terse(1)->Pad('# ')->Useqq(1)->Sortkeys(1);
211            chomp($msg = $dumper->Dump);
212        }
213        else {
214            chomp($msg = $details);
215            $msg =~ s/^/# /;
216            $msg =~ s/\n/\n# /g;
217        }
218
219        [$IO, "$msg\n"];
220    } @{$f->{errors}};
221}
222
223sub plan_tap {
224    my $self = shift;
225    my ($f) = @_;
226    my $plan = $f->{plan} or return;
227
228    return if $plan->{none};
229
230    if ($plan->{skip}) {
231        my $reason = $plan->{details} or return [OUT_STD, "1..0 # SKIP\n"];
232        chomp($reason);
233        return [OUT_STD, '1..0 # SKIP ' . $reason . "\n"];
234    }
235
236    return [OUT_STD, "1.." . $plan->{count} . "\n"];
237}
238
239sub no_subtest_space { 0 }
240sub assert_tap {
241    my $self = shift;
242    my ($f, $num) = @_;
243
244    my $assert = $f->{assert} or return;
245    my $pass = $assert->{pass};
246    my $name = $assert->{details};
247
248    my $ok = $pass ? 'ok' : 'not ok';
249    $ok .= " $num" if $num && !$self->{+NO_NUMBERS};
250
251    # The regex form is ~250ms, the index form is ~50ms
252    my @extra;
253    defined($name) && (
254        (index($name, "\n") != -1 && (($name, @extra) = split(/\n\r?/, $name, -1))),
255        ((index($name, "#" ) != -1  || substr($name, -1) eq '\\') && (($name =~ s|\\|\\\\|g), ($name =~ s|#|\\#|g)))
256    );
257
258    my $extra_space = @extra ? ' ' x (length($ok) + 2) : '';
259    my $extra_indent = '';
260
261    my ($directives, $reason, $is_skip);
262    if ($f->{amnesty}) {
263        my %directives;
264
265        for my $am (@{$f->{amnesty}}) {
266            next if $am->{inherited};
267            my $tag = $am->{tag} or next;
268            $is_skip = 1 if $tag eq 'skip';
269
270            $directives{$tag} ||= $am->{details};
271        }
272
273        my %seen;
274
275        # Sort so that TODO comes before skip even on systems where lc sorts
276        # before uc, as other code depends on that ordering.
277        my @order = grep { !$seen{$_}++ } sort { lc $b cmp lc $a } keys %directives;
278
279        $directives = ' # ' . join ' & ' => @order;
280
281        for my $tag ('skip', @order) {
282            next unless defined($directives{$tag}) && length($directives{$tag});
283            $reason = $directives{$tag};
284            last;
285        }
286    }
287
288    $ok .= " - $name" if defined $name && !($is_skip && !$name);
289
290    my @subtap;
291    if ($f->{parent} && $f->{parent}->{buffered}) {
292        $ok .= ' {';
293
294        # In a verbose harness we indent the extra since they will appear
295        # inside the subtest braces. This helps readability. In a non-verbose
296        # harness we do not do this because it is less readable.
297        if ($ENV{HARNESS_IS_VERBOSE} || !$ENV{HARNESS_ACTIVE}) {
298            $extra_indent = "    ";
299            $extra_space = ' ';
300        }
301
302        # Render the sub-events, we use our own counter for these.
303        my $count = 0;
304        @subtap = map {
305            my $f2 = $_;
306
307            # Bump the count for any event that should bump it.
308            $count++ if $f2->{assert};
309
310            # This indents all output lines generated for the sub-events.
311            # index 0 is the filehandle, index 1 is the message we want to indent.
312            map { $_->[1] =~ s/^(.*\S.*)$/    $1/mg; $_ } $self->event_tap($f2, $count);
313        } @{$f->{parent}->{children}};
314
315        push @subtap => [OUT_STD, "}\n"];
316    }
317
318    if ($directives) {
319        $directives = ' # TODO & SKIP' if $directives eq ' # TODO & skip';
320        $ok .= $directives;
321        $ok .= " $reason" if defined($reason);
322    }
323
324    $extra_space = ' ' if $self->no_subtest_space;
325
326    my @out = ([OUT_STD, "$ok\n"]);
327    push @out => map {[OUT_STD, "${extra_indent}#${extra_space}$_\n"]} @extra if @extra;
328    push @out => @subtap;
329
330    return @out;
331}
332
333sub debug_tap {
334    my ($self, $f, $num) = @_;
335
336    # Figure out the debug info, this is typically the file name and line
337    # number, but can also be a custom message. If no trace object is provided
338    # then we have nothing useful to display.
339    my $name  = $f->{assert}->{details};
340    my $trace = $f->{trace};
341
342    my $debug = "[No trace info available]";
343    if ($trace->{details}) {
344        $debug = $trace->{details};
345    }
346    elsif ($trace->{frame}) {
347        my ($pkg, $file, $line) = @{$trace->{frame}};
348        $debug = "at $file line $line." if $file && $line;
349    }
350
351    my $amnesty = $f->{amnesty} && @{$f->{amnesty}}
352        ? ' (with amnesty)'
353        : '';
354
355    # Create the initial diagnostics. If the test has a name we put the debug
356    # info on a second line, this behavior is inherited from Test::Builder.
357    my $msg = defined($name)
358        ? qq[# Failed test${amnesty} '$name'\n# $debug\n]
359        : qq[# Failed test${amnesty} $debug\n];
360
361    my $IO = $f->{amnesty} && @{$f->{amnesty}} ? OUT_STD : OUT_ERR;
362
363    return [$IO, $msg];
364}
365
366sub halt_tap {
367    my ($self, $f) = @_;
368
369    return if $f->{trace}->{nested} && !$f->{trace}->{buffered};
370    my $details = $f->{control}->{details};
371
372    return [OUT_STD, "Bail out!\n"] unless defined($details) && length($details);
373    return [OUT_STD, "Bail out!  $details\n"];
374}
375
376sub info_tap {
377    my ($self, $f) = @_;
378
379    return map {
380        my $details = $_->{details};
381        my $table   = $_->{table};
382
383        my $IO = $_->{debug} && !($f->{amnesty} && @{$f->{amnesty}}) ? OUT_ERR : OUT_STD;
384
385        my $msg;
386        if ($table && $self->supports_tables) {
387            $msg = join "\n" => map { "# $_" } Term::Table->new(
388                header      => $table->{header},
389                rows        => $table->{rows},
390                collapse    => $table->{collapse},
391                no_collapse => $table->{no_collapse},
392                sanitize    => 1,
393                mark_tail   => 1,
394                max_width   => $self->calc_table_size($f),
395            )->render();
396        }
397        elsif (ref($details)) {
398            require Data::Dumper;
399            my $dumper = Data::Dumper->new([$details])->Indent(2)->Terse(1)->Pad('# ')->Useqq(1)->Sortkeys(1);
400            chomp($msg = $dumper->Dump);
401        }
402        else {
403            chomp($msg = $details);
404            $msg =~ s/^/# /;
405            $msg =~ s/\n/\n# /g;
406        }
407
408        [$IO, "$msg\n"];
409    } @{$f->{info}};
410}
411
412sub summary_tap {
413    my ($self, $f, $num) = @_;
414
415    return if $f->{about}->{no_display};
416
417    my $summary = $f->{about}->{details} or return;
418    chomp($summary);
419    $summary =~ s/^/# /smg;
420
421    return [OUT_STD, "$summary\n"];
422}
423
424sub calc_table_size {
425    my $self = shift;
426    my ($f) = @_;
427
428    my $term = Term::Table::Util::term_size();
429    my $nesting = 2 + (($f->{trace}->{nested} || 0) * 4); # 4 spaces per level, also '# ' prefix
430    my $total = $term - $nesting;
431
432    # Sane minimum width, any smaller and we are asking for pain
433    return 50 if $total < 50;
434
435    return $total;
436}
437
4381;
439
440__END__
441
442=pod
443
444=encoding UTF-8
445
446=head1 NAME
447
448Test2::Formatter::TAP - Standard TAP formatter
449
450=head1 DESCRIPTION
451
452This is what takes events and turns them into TAP.
453
454=head1 SYNOPSIS
455
456    use Test2::Formatter::TAP;
457    my $tap = Test2::Formatter::TAP->new();
458
459    # Switch to utf8
460    $tap->encoding('utf8');
461
462    $tap->write($event, $number); # Output an event
463
464=head1 METHODS
465
466=over 4
467
468=item $bool = $tap->no_numbers
469
470=item $tap->set_no_numbers($bool)
471
472Use to turn numbers on and off.
473
474=item $arrayref = $tap->handles
475
476=item $tap->set_handles(\@handles);
477
478Can be used to get/set the filehandles. Indexes are identified by the
479C<OUT_STD> and C<OUT_ERR> constants.
480
481=item $encoding = $tap->encoding
482
483=item $tap->encoding($encoding)
484
485Get or set the encoding. By default no encoding is set, the original settings
486of STDOUT and STDERR are used.
487
488This directly modifies the stored filehandles, it does not create new ones.
489
490=item $tap->write($e, $num)
491
492Write an event to the console.
493
494=back
495
496=head1 SOURCE
497
498The source code repository for Test2 can be found at
499F<http://github.com/Test-More/test-more/>.
500
501=head1 MAINTAINERS
502
503=over 4
504
505=item Chad Granum E<lt>exodist@cpan.orgE<gt>
506
507=back
508
509=head1 AUTHORS
510
511=over 4
512
513=item Chad Granum E<lt>exodist@cpan.orgE<gt>
514
515=item Kent Fredric E<lt>kentnl@cpan.orgE<gt>
516
517=back
518
519=head1 COPYRIGHT
520
521Copyright 2019 Chad Granum E<lt>exodist@cpan.orgE<gt>.
522
523This program is free software; you can redistribute it and/or
524modify it under the same terms as Perl itself.
525
526See F<http://dev.perl.org/licenses/>
527
528=cut
529