summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Formatter/TAP.pm
diff options
context:
space:
mode:
authorNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
committerNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
commite0c6872cf40896c7be36b11dcc744620f10adf1d (patch)
tree60335e10d2f4354b0674ec22d7b53f0f8abee672 /systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Formatter/TAP.pm
Initial commit
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Formatter/TAP.pm')
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Formatter/TAP.pm487
1 files changed, 487 insertions, 0 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Formatter/TAP.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Formatter/TAP.pm
new file mode 100644
index 0000000000..2082de7b8f
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Formatter/TAP.pm
@@ -0,0 +1,487 @@
+package Test2::Formatter::TAP;
+use strict;
+use warnings;
+
+our $VERSION = '1.302133';
+
+use Test2::Util qw/clone_io/;
+
+use Test2::Util::HashBase qw{
+ no_numbers handles _encoding _last_fh
+ -made_assertion
+};
+
+sub OUT_STD() { 0 }
+sub OUT_ERR() { 1 }
+
+BEGIN { require Test2::Formatter; our @ISA = qw(Test2::Formatter) }
+
+sub _autoflush {
+ my($fh) = pop;
+ my $old_fh = select $fh;
+ $| = 1;
+ select $old_fh;
+}
+
+_autoflush(\*STDOUT);
+_autoflush(\*STDERR);
+
+sub hide_buffered { 1 }
+
+sub init {
+ my $self = shift;
+
+ $self->{+HANDLES} ||= $self->_open_handles;
+ if(my $enc = delete $self->{encoding}) {
+ $self->encoding($enc);
+ }
+}
+
+sub _open_handles {
+ my $self = shift;
+
+ require Test2::API;
+ my $out = clone_io(Test2::API::test2_stdout());
+ my $err = clone_io(Test2::API::test2_stderr());
+
+ _autoflush($out);
+ _autoflush($err);
+
+ return [$out, $err];
+}
+
+sub encoding {
+ my $self = shift;
+
+ if ($] ge "5.007003" and @_) {
+ my ($enc) = @_;
+ my $handles = $self->{+HANDLES};
+
+ # https://rt.perl.org/Public/Bug/Display.html?id=31923
+ # If utf8 is requested we use ':utf8' instead of ':encoding(utf8)' in
+ # order to avoid the thread segfault.
+ if ($enc =~ m/^utf-?8$/i) {
+ binmode($_, ":utf8") for @$handles;
+ }
+ else {
+ binmode($_, ":encoding($enc)") for @$handles;
+ }
+ $self->{+_ENCODING} = $enc;
+ }
+
+ return $self->{+_ENCODING};
+}
+
+if ($^C) {
+ no warnings 'redefine';
+ *write = sub {};
+}
+sub write {
+ my ($self, $e, $num, $f) = @_;
+
+ # The most common case, a pass event with no amnesty and a normal name.
+ return if $self->print_optimal_pass($e, $num);
+
+ $f ||= $e->facet_data;
+
+ $self->encoding($f->{control}->{encoding}) if $f->{control}->{encoding};
+
+ my @tap = $self->event_tap($f, $num) or return;
+
+ $self->{+MADE_ASSERTION} = 1 if $f->{assert};
+
+ my $nesting = $f->{trace}->{nested} || 0;
+ my $handles = $self->{+HANDLES};
+ my $indent = ' ' x $nesting;
+
+ # Local is expensive! Only do it if we really need to.
+ local($\, $,) = (undef, '') if $\ || $,;
+ for my $set (@tap) {
+ no warnings 'uninitialized';
+ my ($hid, $msg) = @$set;
+ next unless $msg;
+ my $io = $handles->[$hid] or next;
+
+ print $io "\n"
+ if $ENV{HARNESS_ACTIVE}
+ && !$ENV{HARNESS_IS_VERBOSE}
+ && $hid == OUT_ERR
+ && $self->{+_LAST_FH} != $io
+ && $msg =~ m/^#\s*Failed test /;
+
+ $msg =~ s/^/$indent/mg if $nesting;
+ print $io $msg;
+ $self->{+_LAST_FH} = $io;
+ }
+}
+
+sub print_optimal_pass {
+ my ($self, $e, $num) = @_;
+
+ my $type = ref($e);
+
+ # Only optimal if this is a Pass or a passing Ok
+ return unless $type eq 'Test2::Event::Pass' || ($type eq 'Test2::Event::Ok' && $e->{pass});
+
+ # Amnesty requires further processing (todo is a form of amnesty)
+ return if ($e->{amnesty} && @{$e->{amnesty}}) || defined($e->{todo});
+
+ # A name with a newline or hash symbol needs extra processing
+ return if defined($e->{name}) && (-1 != index($e->{name}, "\n") || -1 != index($e->{name}, '#'));
+
+ my $ok = 'ok';
+ $ok .= " $num" if $num && !$self->{+NO_NUMBERS};
+ $ok .= defined($e->{name}) ? " - $e->{name}\n" : "\n";
+
+ if (my $nesting = $e->{trace}->{nested}) {
+ my $indent = ' ' x $nesting;
+ $ok = "$indent$ok";
+ }
+
+ my $io = $self->{+HANDLES}->[OUT_STD];
+
+ local($\, $,) = (undef, '') if $\ || $,;
+ print $io $ok;
+ $self->{+_LAST_FH} = $io;
+
+ return 1;
+}
+
+sub event_tap {
+ my ($self, $f, $num) = @_;
+
+ my @tap;
+
+ # If this IS the first event the plan should come first
+ # (plan must be before or after assertions, not in the middle)
+ push @tap => $self->plan_tap($f) if $f->{plan} && !$self->{+MADE_ASSERTION};
+
+ # The assertion is most important, if present.
+ if ($f->{assert}) {
+ push @tap => $self->assert_tap($f, $num);
+ push @tap => $self->debug_tap($f, $num) unless $f->{assert}->{no_debug} || $f->{assert}->{pass};
+ }
+
+ # Almost as important as an assertion
+ push @tap => $self->error_tap($f) if $f->{errors};
+
+ # Now lets see the diagnostics messages
+ push @tap => $self->info_tap($f) if $f->{info};
+
+ # If this IS NOT the first event the plan should come last
+ # (plan must be before or after assertions, not in the middle)
+ push @tap => $self->plan_tap($f) if $self->{+MADE_ASSERTION} && $f->{plan};
+
+ # Bail out
+ push @tap => $self->halt_tap($f) if $f->{control}->{halt};
+
+ return @tap if @tap;
+ return @tap if $f->{control}->{halt};
+ return @tap if grep { $f->{$_} } qw/assert plan info errors/;
+
+ # Use the summary as a fallback if nothing else is usable.
+ return $self->summary_tap($f, $num);
+}
+
+sub error_tap {
+ my $self = shift;
+ my ($f) = @_;
+
+ my $IO = ($f->{amnesty} && @{$f->{amnesty}}) ? OUT_STD : OUT_ERR;
+
+ return map {
+ my $details = $_->{details};
+
+ my $msg;
+ if (ref($details)) {
+ require Data::Dumper;
+ my $dumper = Data::Dumper->new([$details])->Indent(2)->Terse(1)->Pad('# ')->Useqq(1)->Sortkeys(1);
+ chomp($msg = $dumper->Dump);
+ }
+ else {
+ chomp($msg = $details);
+ $msg =~ s/^/# /;
+ $msg =~ s/\n/\n# /g;
+ }
+
+ [$IO, "$msg\n"];
+ } @{$f->{errors}};
+}
+
+sub plan_tap {
+ my $self = shift;
+ my ($f) = @_;
+ my $plan = $f->{plan} or return;
+
+ return if $plan->{none};
+
+ if ($plan->{skip}) {
+ my $reason = $plan->{details} or return [OUT_STD, "1..0 # SKIP\n"];
+ chomp($reason);
+ return [OUT_STD, '1..0 # SKIP ' . $reason . "\n"];
+ }
+
+ return [OUT_STD, "1.." . $plan->{count} . "\n"];
+}
+
+sub no_subtest_space { 0 }
+sub assert_tap {
+ my $self = shift;
+ my ($f, $num) = @_;
+
+ my $assert = $f->{assert} or return;
+ my $pass = $assert->{pass};
+ my $name = $assert->{details};
+
+ my $ok = $pass ? 'ok' : 'not ok';
+ $ok .= " $num" if $num && !$self->{+NO_NUMBERS};
+
+ # The regex form is ~250ms, the index form is ~50ms
+ my @extra;
+ defined($name) && (
+ (index($name, "\n") != -1 && (($name, @extra) = split(/\n\r?/, $name, -1))),
+ ((index($name, "#" ) != -1 || substr($name, -1) eq '\\') && (($name =~ s|\\|\\\\|g), ($name =~ s|#|\\#|g)))
+ );
+
+ my $extra_space = @extra ? ' ' x (length($ok) + 2) : '';
+ my $extra_indent = '';
+
+ my ($directives, $reason, $is_skip);
+ if ($f->{amnesty}) {
+ my %directives;
+
+ for my $am (@{$f->{amnesty}}) {
+ next if $am->{inherited};
+ my $tag = $am->{tag} or next;
+ $is_skip = 1 if $tag eq 'skip';
+
+ $directives{$tag} ||= $am->{details};
+ }
+
+ my %seen;
+ my @order = grep { !$seen{$_}++ } sort keys %directives;
+
+ $directives = ' # ' . join ' & ' => @order;
+
+ for my $tag ('skip', @order) {
+ next unless defined($directives{$tag}) && length($directives{$tag});
+ $reason = $directives{$tag};
+ last;
+ }
+ }
+
+ $ok .= " - $name" if defined $name && !($is_skip && !$name);
+
+ my @subtap;
+ if ($f->{parent} && $f->{parent}->{buffered}) {
+ $ok .= ' {';
+
+ # In a verbose harness we indent the extra since they will appear
+ # inside the subtest braces. This helps readability. In a non-verbose
+ # harness we do not do this because it is less readable.
+ if ($ENV{HARNESS_IS_VERBOSE} || !$ENV{HARNESS_ACTIVE}) {
+ $extra_indent = " ";
+ $extra_space = ' ';
+ }
+
+ # Render the sub-events, we use our own counter for these.
+ my $count = 0;
+ @subtap = map {
+ my $f2 = $_;
+
+ # Bump the count for any event that should bump it.
+ $count++ if $f2->{assert};
+
+ # This indents all output lines generated for the sub-events.
+ # index 0 is the filehandle, index 1 is the message we want to indent.
+ map { $_->[1] =~ s/^(.*\S.*)$/ $1/mg; $_ } $self->event_tap($f2, $count);
+ } @{$f->{parent}->{children}};
+
+ push @subtap => [OUT_STD, "}\n"];
+ }
+
+ if ($directives) {
+ $directives = ' # TODO & SKIP' if $directives eq ' # TODO & skip';
+ $ok .= $directives;
+ $ok .= " $reason" if defined($reason);
+ }
+
+ $extra_space = ' ' if $self->no_subtest_space;
+
+ my @out = ([OUT_STD, "$ok\n"]);
+ push @out => map {[OUT_STD, "${extra_indent}#${extra_space}$_\n"]} @extra if @extra;
+ push @out => @subtap;
+
+ return @out;
+}
+
+sub debug_tap {
+ my ($self, $f, $num) = @_;
+
+ # Figure out the debug info, this is typically the file name and line
+ # number, but can also be a custom message. If no trace object is provided
+ # then we have nothing useful to display.
+ my $name = $f->{assert}->{details};
+ my $trace = $f->{trace};
+
+ my $debug = "[No trace info available]";
+ if ($trace->{details}) {
+ $debug = $trace->{details};
+ }
+ elsif ($trace->{frame}) {
+ my ($pkg, $file, $line) = @{$trace->{frame}};
+ $debug = "at $file line $line." if $file && $line;
+ }
+
+ my $amnesty = $f->{amnesty} && @{$f->{amnesty}}
+ ? ' (with amnesty)'
+ : '';
+
+ # Create the initial diagnostics. If the test has a name we put the debug
+ # info on a second line, this behavior is inherited from Test::Builder.
+ my $msg = defined($name)
+ ? qq[# Failed test${amnesty} '$name'\n# $debug\n]
+ : qq[# Failed test${amnesty} $debug\n];
+
+ my $IO = $f->{amnesty} && @{$f->{amnesty}} ? OUT_STD : OUT_ERR;
+
+ return [$IO, $msg];
+}
+
+sub halt_tap {
+ my ($self, $f) = @_;
+
+ return if $f->{trace}->{nested} && !$f->{trace}->{buffered};
+ my $details = $f->{control}->{details};
+
+ return [OUT_STD, "Bail out!\n"] unless defined($details) && length($details);
+ return [OUT_STD, "Bail out! $details\n"];
+}
+
+sub info_tap {
+ my ($self, $f) = @_;
+
+ return map {
+ my $details = $_->{details};
+
+ my $IO = $_->{debug} && !($f->{amnesty} && @{$f->{amnesty}}) ? OUT_ERR : OUT_STD;
+
+ my $msg;
+ if (ref($details)) {
+ require Data::Dumper;
+ my $dumper = Data::Dumper->new([$details])->Indent(2)->Terse(1)->Pad('# ')->Useqq(1)->Sortkeys(1);
+ chomp($msg = $dumper->Dump);
+ }
+ else {
+ chomp($msg = $details);
+ $msg =~ s/^/# /;
+ $msg =~ s/\n/\n# /g;
+ }
+
+ [$IO, "$msg\n"];
+ } @{$f->{info}};
+}
+
+sub summary_tap {
+ my ($self, $f, $num) = @_;
+
+ return if $f->{about}->{no_display};
+
+ my $summary = $f->{about}->{details} or return;
+ chomp($summary);
+ $summary =~ s/^/# /smg;
+
+ return [OUT_STD, "$summary\n"];
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test2::Formatter::TAP - Standard TAP formatter
+
+=head1 DESCRIPTION
+
+This is what takes events and turns them into TAP.
+
+=head1 SYNOPSIS
+
+ use Test2::Formatter::TAP;
+ my $tap = Test2::Formatter::TAP->new();
+
+ # Switch to utf8
+ $tap->encoding('utf8');
+
+ $tap->write($event, $number); # Output an event
+
+=head1 METHODS
+
+=over 4
+
+=item $bool = $tap->no_numbers
+
+=item $tap->set_no_numbers($bool)
+
+Use to turn numbers on and off.
+
+=item $arrayref = $tap->handles
+
+=item $tap->set_handles(\@handles);
+
+Can be used to get/set the filehandles. Indexes are identified by the
+C<OUT_STD> and C<OUT_ERR> constants.
+
+=item $encoding = $tap->encoding
+
+=item $tap->encoding($encoding)
+
+Get or set the encoding. By default no encoding is set, the original settings
+of STDOUT and STDERR are used.
+
+This directly modifies the stored filehandles, it does not create new ones.
+
+=item $tap->write($e, $num)
+
+Write an event to the console.
+
+=back
+
+=head1 SOURCE
+
+The source code repository for Test2 can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINERS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Kent Fredric E<lt>kentnl@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://dev.perl.org/licenses/>
+
+=cut