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