cpan/Test-Simple/lib/Test2/Formatter/TAP.pm

   1 package Test2::Formatter::TAP;
   2 use strict;
   3 use warnings;
   4
   5 our $VERSION = '1.302198';
   6
   7 use Test2::Util qw/clone_io/;
   8
   9 use Test2::Util::HashBase qw{
  10     no_numbers handles _encoding _last_fh
  11     -made_assertion
  12 };
  13
  14 sub OUT_STD() { 0 }
  15 sub OUT_ERR() { 1 }
  16
  17 BEGIN { require Test2::Formatter; our @ISA = qw(Test2::Formatter) }
  18
  19 my $supports_tables;
  20 sub 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
  32 sub _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
  42 sub hide_buffered { 1 }
  43
  44 sub 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
  53 sub _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
  66 sub 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
  88 if ($^C) {
  89     no warnings 'redefine';
  90     *write = sub {};
  91 }
  92 sub 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
 130 sub 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
 162 sub 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
 198 sub 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
 223 sub 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
 239 sub no_subtest_space { 0 }
 240 sub 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
 333 sub 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
 366 sub 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
 376 sub 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
 412 sub 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
 424 sub 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
 438 1;
 439
 440 __END__
 441
 442 =pod
 443
 444 =encoding UTF-8
 445
 446 =head1 NAME
 447
 448 Test2::Formatter::TAP - Standard TAP formatter
 449
 450 =head1 DESCRIPTION
 451
 452 This 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
 472 Use to turn numbers on and off.
 473
 474 =item $arrayref = $tap->handles
 475
 476 =item $tap->set_handles(\@handles);
 477
 478 Can be used to get/set the filehandles. Indexes are identified by the
 479 C<OUT_STD> and C<OUT_ERR> constants.
 480
 481 =item $encoding = $tap->encoding
 482
 483 =item $tap->encoding($encoding)
 484
 485 Get or set the encoding. By default no encoding is set, the original settings
 486 of STDOUT and STDERR are used.
 487
 488 This directly modifies the stored filehandles, it does not create new ones.
 489
 490 =item $tap->write($e, $num)
 491
 492 Write an event to the console.
 493
 494 =back
 495
 496 =head1 SOURCE
 497
 498 The source code repository for Test2 can be found at
 499 F<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
 521 Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
 522
 523 This program is free software; you can redistribute it and/or
 524 modify it under the same terms as Perl itself.
 525
 526 See F<http://dev.perl.org/licenses/>
 527
 528 =cut