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