diff options
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Formatter')
8 files changed, 1483 insertions, 0 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Formatter/Base.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Formatter/Base.pm new file mode 100755 index 0000000000..f6efeaed63 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Formatter/Base.pm @@ -0,0 +1,490 @@ +package TAP::Formatter::Base; + +use strict; +use warnings; +use base 'TAP::Base'; +use POSIX qw(strftime); + +my $MAX_ERRORS = 5; +my %VALIDATION_FOR; + +BEGIN { + %VALIDATION_FOR = ( + directives => sub { shift; shift }, + verbosity => sub { shift; shift }, + normalize => sub { shift; shift }, + timer => sub { shift; shift }, + failures => sub { shift; shift }, + comments => sub { shift; shift }, + errors => sub { shift; shift }, + color => sub { shift; shift }, + jobs => sub { shift; shift }, + show_count => sub { shift; shift }, + stdout => sub { + my ( $self, $ref ) = @_; + + $self->_croak("option 'stdout' needs a filehandle") + unless $self->_is_filehandle($ref); + + return $ref; + }, + ); + + sub _is_filehandle { + my ( $self, $ref ) = @_; + + return 0 if !defined $ref; + + return 1 if ref $ref eq 'GLOB'; # lexical filehandle + return 1 if !ref $ref && ref \$ref eq 'GLOB'; # bare glob like *STDOUT + + return 1 if eval { $ref->can('print') }; + + return 0; + } + + my @getter_setters = qw( + _longest + _printed_summary_header + _colorizer + ); + + __PACKAGE__->mk_methods( @getter_setters, keys %VALIDATION_FOR ); +} + +=head1 NAME + +TAP::Formatter::Base - Base class for harness output delegates + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=head1 DESCRIPTION + +This provides console orientated output formatting for TAP::Harness. + +=head1 SYNOPSIS + + use TAP::Formatter::Console; + my $harness = TAP::Formatter::Console->new( \%args ); + +=cut + +sub _initialize { + my ( $self, $arg_for ) = @_; + $arg_for ||= {}; + + $self->SUPER::_initialize($arg_for); + my %arg_for = %$arg_for; # force a shallow copy + + $self->verbosity(0); + + for my $name ( keys %VALIDATION_FOR ) { + my $property = delete $arg_for{$name}; + if ( defined $property ) { + my $validate = $VALIDATION_FOR{$name}; + $self->$name( $self->$validate($property) ); + } + } + + if ( my @props = keys %arg_for ) { + $self->_croak( + "Unknown arguments to " . __PACKAGE__ . "::new (@props)" ); + } + + $self->stdout( \*STDOUT ) unless $self->stdout; + + if ( $self->color ) { + require TAP::Formatter::Color; + $self->_colorizer( TAP::Formatter::Color->new ); + } + + return $self; +} + +sub verbose { shift->verbosity >= 1 } +sub quiet { shift->verbosity <= -1 } +sub really_quiet { shift->verbosity <= -2 } +sub silent { shift->verbosity <= -3 } + +=head1 METHODS + +=head2 Class Methods + +=head3 C<new> + + my %args = ( + verbose => 1, + ) + my $harness = TAP::Formatter::Console->new( \%args ); + +The constructor returns a new C<TAP::Formatter::Console> object. If +a L<TAP::Harness> is created with no C<formatter> a +C<TAP::Formatter::Console> is automatically created. If any of the +following options were given to TAP::Harness->new they well be passed to +this constructor which accepts an optional hashref whose allowed keys are: + +=over 4 + +=item * C<verbosity> + +Set the verbosity level. + +=item * C<verbose> + +Printing individual test results to STDOUT. + +=item * C<timer> + +Append run time for each test to output. Uses L<Time::HiRes> if available. + +=item * C<failures> + +Show test failures (this is a no-op if C<verbose> is selected). + +=item * C<comments> + +Show test comments (this is a no-op if C<verbose> is selected). + +=item * C<quiet> + +Suppressing some test output (mostly failures while tests are running). + +=item * C<really_quiet> + +Suppressing everything but the tests summary. + +=item * C<silent> + +Suppressing all output. + +=item * C<errors> + +If parse errors are found in the TAP output, a note of this will be made +in the summary report. To see all of the parse errors, set this argument to +true: + + errors => 1 + +=item * C<directives> + +If set to a true value, only test results with directives will be displayed. +This overrides other settings such as C<verbose>, C<failures>, or C<comments>. + +=item * C<stdout> + +A filehandle for catching standard output. + +=item * C<color> + +If defined specifies whether color output is desired. If C<color> is not +defined it will default to color output if color support is available on +the current platform and output is not being redirected. + +=item * C<jobs> + +The number of concurrent jobs this formatter will handle. + +=item * C<show_count> + +Boolean value. If false, disables the C<X/Y> test count which shows up while +tests are running. + +=back + +Any keys for which the value is C<undef> will be ignored. + +=cut + +# new supplied by TAP::Base + +=head3 C<prepare> + +Called by Test::Harness before any test output is generated. + +This is an advisory and may not be called in the case where tests are +being supplied to Test::Harness by an iterator. + +=cut + +sub prepare { + my ( $self, @tests ) = @_; + + my $longest = 0; + + for my $test (@tests) { + $longest = length $test if length $test > $longest; + } + + $self->_longest($longest); +} + +sub _format_now { strftime "[%H:%M:%S]", localtime } + +sub _format_name { + my ( $self, $test ) = @_; + my $name = $test; + my $periods = '.' x ( $self->_longest + 2 - length $test ); + $periods = " $periods "; + + if ( $self->timer ) { + my $stamp = $self->_format_now(); + return "$stamp $name$periods"; + } + else { + return "$name$periods"; + } + +} + +=head3 C<open_test> + +Called to create a new test session. A test session looks like this: + + my $session = $formatter->open_test( $test, $parser ); + while ( defined( my $result = $parser->next ) ) { + $session->result($result); + exit 1 if $result->is_bailout; + } + $session->close_test; + +=cut + +sub open_test { + die "Unimplemented."; +} + +sub _output_success { + my ( $self, $msg ) = @_; + $self->_output($msg); +} + +=head3 C<summary> + + $harness->summary( $aggregate ); + +C<summary> prints the summary report after all tests are run. The first +argument is an aggregate to summarise. An optional second argument may +be set to a true value to indicate that the summary is being output as a +result of an interrupted test run. + +=cut + +sub summary { + my ( $self, $aggregate, $interrupted ) = @_; + + return if $self->silent; + + my @t = $aggregate->descriptions; + my $tests = \@t; + + my $runtime = $aggregate->elapsed_timestr; + + my $total = $aggregate->total; + my $passed = $aggregate->passed; + + if ( $self->timer ) { + $self->_output( $self->_format_now(), "\n" ); + } + + $self->_failure_output("Test run interrupted!\n") + if $interrupted; + + # TODO: Check this condition still works when all subtests pass but + # the exit status is nonzero + + if ( $aggregate->all_passed ) { + $self->_output_success("All tests successful.\n"); + } + + # ~TODO option where $aggregate->skipped generates reports + if ( $total != $passed or $aggregate->has_problems ) { + $self->_output("\nTest Summary Report"); + $self->_output("\n-------------------\n"); + for my $test (@$tests) { + $self->_printed_summary_header(0); + my ($parser) = $aggregate->parsers($test); + $self->_output_summary_failure( + 'failed', + [ ' Failed test: ', ' Failed tests: ' ], + $test, $parser + ); + $self->_output_summary_failure( + 'todo_passed', + " TODO passed: ", $test, $parser + ); + + # ~TODO this cannot be the default + #$self->_output_summary_failure( 'skipped', " Tests skipped: " ); + + if ( my $exit = $parser->exit ) { + $self->_summary_test_header( $test, $parser ); + $self->_failure_output(" Non-zero exit status: $exit\n"); + } + elsif ( my $wait = $parser->wait ) { + $self->_summary_test_header( $test, $parser ); + $self->_failure_output(" Non-zero wait status: $wait\n"); + } + + if ( my @errors = $parser->parse_errors ) { + my $explain; + if ( @errors > $MAX_ERRORS && !$self->errors ) { + $explain + = "Displayed the first $MAX_ERRORS of " + . scalar(@errors) + . " TAP syntax errors.\n" + . "Re-run prove with the -p option to see them all.\n"; + splice @errors, $MAX_ERRORS; + } + $self->_summary_test_header( $test, $parser ); + $self->_failure_output( + sprintf " Parse errors: %s\n", + shift @errors + ); + for my $error (@errors) { + my $spaces = ' ' x 16; + $self->_failure_output("$spaces$error\n"); + } + $self->_failure_output($explain) if $explain; + } + } + } + my $files = @$tests; + $self->_output("Files=$files, Tests=$total, $runtime\n"); + my $status = $aggregate->get_status; + $self->_output("Result: $status\n"); +} + +sub _output_summary_failure { + my ( $self, $method, $name, $test, $parser ) = @_; + + # ugly hack. Must rethink this :( + my $output = $method eq 'failed' ? '_failure_output' : '_output'; + + if ( my @r = $parser->$method() ) { + $self->_summary_test_header( $test, $parser ); + my ( $singular, $plural ) + = 'ARRAY' eq ref $name ? @$name : ( $name, $name ); + $self->$output( @r == 1 ? $singular : $plural ); + my @results = $self->_balanced_range( 40, @r ); + $self->$output( sprintf "%s\n" => shift @results ); + my $spaces = ' ' x 16; + while (@results) { + $self->$output( sprintf "$spaces%s\n" => shift @results ); + } + } +} + +sub _summary_test_header { + my ( $self, $test, $parser ) = @_; + return if $self->_printed_summary_header; + my $spaces = ' ' x ( $self->_longest - length $test ); + $spaces = ' ' unless $spaces; + my $output = $self->_get_output_method($parser); + my $wait = $parser->wait; + + if (defined $wait) { + my $signum = $wait & 0x7f; + + my $description; + + if ($signum) { + require Config; + my @names = split ' ', $Config::Config{'sig_name'}; + $description = "Signal: $names[$signum]"; + + my $dumped = $wait & 0x80; + $description .= ', dumped core' if $dumped; + } + elsif ($wait != 0) { + $description = sprintf 'exited %d', ($wait >> 8); + } + + $wait .= " ($description)" if $wait != 0; + } + else { + $wait = '(none)'; + } + + $self->$output( + sprintf "$test$spaces(Wstat: %s Tests: %d Failed: %d)\n", + $wait, $parser->tests_run, scalar $parser->failed + ); + $self->_printed_summary_header(1); +} + +sub _output { + my $self = shift; + + print { $self->stdout } @_; +} + +sub _failure_output { + my $self = shift; + + $self->_output(@_); +} + +sub _balanced_range { + my ( $self, $limit, @range ) = @_; + @range = $self->_range(@range); + my $line = ""; + my @lines; + my $curr = 0; + while (@range) { + if ( $curr < $limit ) { + my $range = ( shift @range ) . ", "; + $line .= $range; + $curr += length $range; + } + elsif (@range) { + $line =~ s/, $//; + push @lines => $line; + $line = ''; + $curr = 0; + } + } + if ($line) { + $line =~ s/, $//; + push @lines => $line; + } + return @lines; +} + +sub _range { + my ( $self, @numbers ) = @_; + + # shouldn't be needed, but subclasses might call this + @numbers = sort { $a <=> $b } @numbers; + my ( $min, @range ); + + for my $i ( 0 .. $#numbers ) { + my $num = $numbers[$i]; + my $next = $numbers[ $i + 1 ]; + if ( defined $next && $next == $num + 1 ) { + if ( !defined $min ) { + $min = $num; + } + } + elsif ( defined $min ) { + push @range => "$min-$num"; + undef $min; + } + else { + push @range => $num; + } + } + return @range; +} + +sub _get_output_method { + my ( $self, $parser ) = @_; + return $parser->has_problems ? '_failure_output' : '_output'; +} + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Formatter/Color.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Formatter/Color.pm new file mode 100755 index 0000000000..873ff9680a --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Formatter/Color.pm @@ -0,0 +1,116 @@ +package TAP::Formatter::Color; + +use strict; +use warnings; + +use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); + +use base 'TAP::Object'; + +my $NO_COLOR; + +BEGIN { + $NO_COLOR = 0; + + eval 'require Term::ANSIColor'; + if ($@) { + $NO_COLOR = $@; + }; + if (IS_WIN32) { + eval 'use Win32::Console::ANSI'; + if ($@) { + $NO_COLOR = $@; + } + }; + + if ($NO_COLOR) { + *set_color = sub { }; + } else { + *set_color = sub { + my ( $self, $output, $color ) = @_; + $output->( Term::ANSIColor::color($color) ); + }; + } +} + +=head1 NAME + +TAP::Formatter::Color - Run Perl test scripts with color + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=head1 DESCRIPTION + +Note that this harness is I<experimental>. You may not like the colors I've +chosen and I haven't yet provided an easy way to override them. + +This test harness is the same as L<TAP::Harness>, but test results are output +in color. Passing tests are printed in green. Failing tests are in red. +Skipped tests are blue on a white background and TODO tests are printed in +white. + +If L<Term::ANSIColor> cannot be found (and L<Win32::Console::ANSI> if running +under Windows) tests will be run without color. + +=head1 SYNOPSIS + + use TAP::Formatter::Color; + my $harness = TAP::Formatter::Color->new( \%args ); + $harness->runtests(@tests); + +=head1 METHODS + +=head2 Class Methods + +=head3 C<new> + +The constructor returns a new C<TAP::Formatter::Color> object. If +L<Term::ANSIColor> is not installed, returns undef. + +=cut + +# new() implementation supplied by TAP::Object + +sub _initialize { + my $self = shift; + + if ($NO_COLOR) { + + # shorten that message a bit + ( my $error = $NO_COLOR ) =~ s/ in \@INC .*//s; + warn "Note: Cannot run tests in color: $error\n"; + return; # abort object construction + } + + return $self; +} + +############################################################################## + +=head3 C<can_color> + + Test::Formatter::Color->can_color() + +Returns a boolean indicating whether or not this module can actually +generate colored output. This will be false if it could not load the +modules needed for the current platform. + +=cut + +sub can_color { + return !$NO_COLOR; +} + +=head3 C<set_color> + +Set the output color. + +=cut + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Formatter/Console.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Formatter/Console.pm new file mode 100755 index 0000000000..dc7e0ddc64 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Formatter/Console.pm @@ -0,0 +1,100 @@ +package TAP::Formatter::Console; + +use strict; +use warnings; +use base 'TAP::Formatter::Base'; +use POSIX qw(strftime); + +=head1 NAME + +TAP::Formatter::Console - Harness output delegate for default console output + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=head1 DESCRIPTION + +This provides console orientated output formatting for TAP::Harness. + +=head1 SYNOPSIS + + use TAP::Formatter::Console; + my $harness = TAP::Formatter::Console->new( \%args ); + +=head2 C<< open_test >> + +See L<TAP::Formatter::Base> + +=cut + +sub open_test { + my ( $self, $test, $parser ) = @_; + + my $class + = $self->jobs > 1 + ? 'TAP::Formatter::Console::ParallelSession' + : 'TAP::Formatter::Console::Session'; + + eval "require $class"; + $self->_croak($@) if $@; + + my $session = $class->new( + { name => $test, + formatter => $self, + parser => $parser, + show_count => $self->show_count, + } + ); + + $session->header; + + return $session; +} + +# Use _colorizer delegate to set output color. NOP if we have no delegate +sub _set_colors { + my ( $self, @colors ) = @_; + if ( my $colorizer = $self->_colorizer ) { + my $output_func = $self->{_output_func} ||= sub { + $self->_output(@_); + }; + $colorizer->set_color( $output_func, $_ ) for @colors; + } +} + +sub _failure_color { + my ($self) = @_; + + return $ENV{'HARNESS_SUMMARY_COLOR_FAIL'} || 'red'; +} + +sub _success_color { + my ($self) = @_; + + return $ENV{'HARNESS_SUMMARY_COLOR_SUCCESS'} || 'green'; +} + +sub _output_success { + my ( $self, $msg ) = @_; + $self->_set_colors( $self->_success_color() ); + $self->_output($msg); + $self->_set_colors('reset'); +} + +sub _failure_output { + my $self = shift; + $self->_set_colors( $self->_failure_color() ); + my $out = join '', @_; + my $has_newline = chomp $out; + $self->_output($out); + $self->_set_colors('reset'); + $self->_output($/) + if $has_newline; +} + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Formatter/Console/ParallelSession.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Formatter/Console/ParallelSession.pm new file mode 100755 index 0000000000..1ec9e8be9a --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Formatter/Console/ParallelSession.pm @@ -0,0 +1,201 @@ +package TAP::Formatter::Console::ParallelSession; + +use strict; +use warnings; +use File::Spec; +use File::Path; +use Carp; + +use base 'TAP::Formatter::Console::Session'; + +use constant WIDTH => 72; # Because Eric says + +my %shared; + +sub _initialize { + my ( $self, $arg_for ) = @_; + + $self->SUPER::_initialize($arg_for); + my $formatter = $self->formatter; + + # Horrid bodge. This creates our shared context per harness. Maybe + # TAP::Harness should give us this? + my $context = $shared{$formatter} ||= $self->_create_shared_context; + push @{ $context->{active} }, $self; + + return $self; +} + +sub _create_shared_context { + my $self = shift; + return { + active => [], + tests => 0, + fails => 0, + }; +} + +=head1 NAME + +TAP::Formatter::Console::ParallelSession - Harness output delegate for parallel console output + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=head1 DESCRIPTION + +This provides console orientated output formatting for L<TAP::Harness> +when run with multiple L<TAP::Harness/jobs>. + +=head1 SYNOPSIS + +=cut + +=head1 METHODS + +=head2 Class Methods + +=head3 C<header> + +Output test preamble + +=cut + +sub header { +} + +sub _clear_ruler { + my $self = shift; + $self->formatter->_output( "\r" . ( ' ' x WIDTH ) . "\r" ); +} + +my $now = 0; +my $start; + +my $trailer = '... )==='; +my $chop_length = WIDTH - length $trailer; + +sub _output_ruler { + my ( $self, $refresh ) = @_; + my $new_now = time; + return if $new_now == $now and !$refresh; + $now = $new_now; + $start ||= $now; + my $formatter = $self->formatter; + return if $formatter->really_quiet; + + my $context = $shared{$formatter}; + + my $ruler = sprintf '===( %7d;%d ', $context->{tests}, $now - $start; + + for my $active ( @{ $context->{active} } ) { + my $parser = $active->parser; + my $tests = $parser->tests_run; + my $planned = $parser->tests_planned || '?'; + + $ruler .= sprintf '%' . length($planned) . "d/$planned ", $tests; + } + chop $ruler; # Remove a trailing space + $ruler .= ')==='; + + if ( length $ruler > WIDTH ) { + $ruler =~ s/(.{$chop_length}).*/$1$trailer/o; + } + else { + $ruler .= '=' x ( WIDTH - length($ruler) ); + } + $formatter->_output("\r$ruler"); +} + +=head3 C<result> + + Called by the harness for each line of TAP it receives . + +=cut + +sub result { + my ( $self, $result ) = @_; + my $formatter = $self->formatter; + + # my $really_quiet = $formatter->really_quiet; + # my $show_count = $self->_should_show_count; + + if ( $result->is_test ) { + my $context = $shared{$formatter}; + $context->{tests}++; + + my $active = $context->{active}; + if ( @$active == 1 ) { + + # There is only one test, so use the serial output format. + return $self->SUPER::result($result); + } + + $self->_output_ruler( $self->parser->tests_run == 1 ); + } + elsif ( $result->is_bailout ) { + $formatter->_failure_output( + "Bailout called. Further testing stopped: " + . $result->explanation + . "\n" ); + } +} + +=head3 C<clear_for_close> + +=cut + +sub clear_for_close { + my $self = shift; + my $formatter = $self->formatter; + return if $formatter->really_quiet; + my $context = $shared{$formatter}; + if ( @{ $context->{active} } == 1 ) { + $self->SUPER::clear_for_close; + } + else { + $self->_clear_ruler; + } +} + +=head3 C<close_test> + +=cut + +sub close_test { + my $self = shift; + my $name = $self->name; + my $parser = $self->parser; + my $formatter = $self->formatter; + my $context = $shared{$formatter}; + + $self->SUPER::close_test; + + my $active = $context->{active}; + + my @pos = grep { $active->[$_]->name eq $name } 0 .. $#$active; + + die "Can't find myself" unless @pos; + splice @$active, $pos[0], 1; + + if ( @$active > 1 ) { + $self->_output_ruler(1); + } + elsif ( @$active == 1 ) { + + # Print out "test/name.t ...." + $active->[0]->SUPER::header; + } + else { + + # $self->formatter->_output("\n"); + delete $shared{$formatter}; + } +} + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Formatter/Console/Session.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Formatter/Console/Session.pm new file mode 100755 index 0000000000..53ad867387 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Formatter/Console/Session.pm @@ -0,0 +1,205 @@ +package TAP::Formatter::Console::Session; + +use strict; +use warnings; + +use base 'TAP::Formatter::Session'; + +my @ACCESSOR; + +BEGIN { + my @CLOSURE_BINDING = qw( header result clear_for_close close_test ); + + for my $method (@CLOSURE_BINDING) { + no strict 'refs'; + *$method = sub { + my $self = shift; + return ( $self->{_closures} ||= $self->_closures )->{$method} + ->(@_); + }; + } +} + +=head1 NAME + +TAP::Formatter::Console::Session - Harness output delegate for default console output + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=head1 DESCRIPTION + +This provides console orientated output formatting for TAP::Harness. + +=cut + +sub _get_output_result { + my $self = shift; + + my @color_map = ( + { test => sub { $_->is_test && !$_->is_ok }, + colors => ['red'], + }, + { test => sub { $_->is_test && $_->has_skip }, + colors => [ + 'white', + 'on_blue' + ], + }, + { test => sub { $_->is_test && $_->has_todo }, + colors => ['yellow'], + }, + ); + + my $formatter = $self->formatter; + my $parser = $self->parser; + + return $formatter->_colorizer + ? sub { + my $result = shift; + for my $col (@color_map) { + local $_ = $result; + if ( $col->{test}->() ) { + $formatter->_set_colors( @{ $col->{colors} } ); + last; + } + } + $formatter->_output( $self->_format_for_output($result) ); + $formatter->_set_colors('reset'); + } + : sub { + $formatter->_output( $self->_format_for_output(shift) ); + }; +} + +sub _closures { + my $self = shift; + + my $parser = $self->parser; + my $formatter = $self->formatter; + my $pretty = $formatter->_format_name( $self->name ); + my $show_count = $self->show_count; + + my $really_quiet = $formatter->really_quiet; + my $quiet = $formatter->quiet; + my $verbose = $formatter->verbose; + my $directives = $formatter->directives; + my $failures = $formatter->failures; + my $comments = $formatter->comments; + + my $output_result = $self->_get_output_result; + + my $output = '_output'; + my $plan = ''; + my $newline_printed = 0; + + my $last_status_printed = 0; + + return { + header => sub { + $formatter->_output($pretty) + unless $really_quiet; + }, + + result => sub { + my $result = shift; + + if ( $result->is_bailout ) { + $formatter->_failure_output( + "Bailout called. Further testing stopped: " + . $result->explanation + . "\n" ); + } + + return if $really_quiet; + + my $is_test = $result->is_test; + + # These are used in close_test - but only if $really_quiet + # is false - so it's safe to only set them here unless that + # relationship changes. + + if ( !$plan ) { + my $planned = $parser->tests_planned || '?'; + $plan = "/$planned "; + } + $output = $formatter->_get_output_method($parser); + + if ( $show_count and $is_test ) { + my $number = $result->number; + my $now = CORE::time; + + # Print status roughly once per second. + # We will always get the first number as a side effect of + # $last_status_printed starting with the value 0, which $now + # will never be. (Unless someone sets their clock to 1970) + if ( $last_status_printed != $now ) { + $formatter->$output("\r$pretty$number$plan"); + $last_status_printed = $now; + } + } + + if (!$quiet + && ( $verbose + || ( $is_test && $failures && !$result->is_ok ) + || ( $comments && $result->is_comment ) + || ( $directives && $result->has_directive ) ) + ) + { + unless ($newline_printed) { + $formatter->_output("\n"); + $newline_printed = 1; + } + $output_result->($result); + $formatter->_output("\n"); + } + }, + + clear_for_close => sub { + my $spaces + = ' ' x length( '.' . $pretty . $plan . $parser->tests_run ); + $formatter->$output("\r$spaces"); + }, + + close_test => sub { + if ( $show_count && !$really_quiet ) { + $self->clear_for_close; + $formatter->$output("\r$pretty"); + } + + # Avoid circular references + $self->parser(undef); + $self->{_closures} = {}; + + return if $really_quiet; + + if ( my $skip_all = $parser->skip_all ) { + $formatter->_output("skipped: $skip_all\n"); + } + elsif ( $parser->has_problems ) { + $self->_output_test_failure($parser); + } + else { + my $time_report = $self->time_report($formatter, $parser); + $formatter->_output_success( $self->_make_ok_line($time_report) ); + } + }, + }; +} + +=head2 C<< clear_for_close >> + +=head2 C<< close_test >> + +=head2 C<< header >> + +=head2 C<< result >> + +=cut + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Formatter/File.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Formatter/File.pm new file mode 100755 index 0000000000..396b4074b3 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Formatter/File.pm @@ -0,0 +1,56 @@ +package TAP::Formatter::File; + +use strict; +use warnings; +use TAP::Formatter::File::Session; +use POSIX qw(strftime); + +use base 'TAP::Formatter::Base'; + +=head1 NAME + +TAP::Formatter::File - Harness output delegate for file output + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=head1 DESCRIPTION + +This provides file orientated output formatting for TAP::Harness. + +=head1 SYNOPSIS + + use TAP::Formatter::File; + my $harness = TAP::Formatter::File->new( \%args ); + +=head2 C<< open_test >> + +See L<TAP::Formatter::Base> + +=cut + +sub open_test { + my ( $self, $test, $parser ) = @_; + + my $session = TAP::Formatter::File::Session->new( + { name => $test, + formatter => $self, + parser => $parser, + } + ); + + $session->header; + + return $session; +} + +sub _should_show_count { + return 0; +} + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Formatter/File/Session.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Formatter/File/Session.pm new file mode 100755 index 0000000000..210c9a47d3 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Formatter/File/Session.pm @@ -0,0 +1,95 @@ +package TAP::Formatter::File::Session; + +use strict; +use warnings; +use base 'TAP::Formatter::Session'; + +=head1 NAME + +TAP::Formatter::File::Session - Harness output delegate for file output + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=head1 DESCRIPTION + +This provides file orientated output formatting for L<TAP::Harness>. +It is particularly important when running with parallel tests, as it +ensures that test results are not interleaved, even when run +verbosely. + +=cut + +=head1 METHODS + +=head2 result + +Stores results for later output, all together. + +=cut + +sub result { + my $self = shift; + my $result = shift; + + my $parser = $self->parser; + my $formatter = $self->formatter; + + if ( $result->is_bailout ) { + $formatter->_failure_output( + "Bailout called. Further testing stopped: " + . $result->explanation + . "\n" ); + return; + } + + if (!$formatter->quiet + && ( $formatter->verbose + || ( $result->is_test && $formatter->failures && !$result->is_ok ) + || ( $formatter->comments && $result->is_comment ) + || ( $result->has_directive && $formatter->directives ) ) + ) + { + $self->{results} .= $self->_format_for_output($result) . "\n"; + } +} + +=head2 close_test + +When the test file finishes, outputs the summary, together. + +=cut + +sub close_test { + my $self = shift; + + # Avoid circular references + $self->parser(undef); + + my $parser = $self->parser; + my $formatter = $self->formatter; + my $pretty = $formatter->_format_name( $self->name ); + + return if $formatter->really_quiet; + if ( my $skip_all = $parser->skip_all ) { + $formatter->_output( $pretty . "skipped: $skip_all\n" ); + } + elsif ( $parser->has_problems ) { + $formatter->_output( + $pretty . ( $self->{results} ? "\n" . $self->{results} : "\n" ) ); + $self->_output_test_failure($parser); + } + else { + my $time_report = $self->time_report( $formatter, $parser ); + $formatter->_output( + $pretty . ( $self->{results} ? "\n" . $self->{results} : "" ) ); + $formatter->_output_success( $self->_make_ok_line($time_report) ); + } +} + +1; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Formatter/Session.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Formatter/Session.pm new file mode 100755 index 0000000000..5fb633b443 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Formatter/Session.pm @@ -0,0 +1,220 @@ +package TAP::Formatter::Session; + +use strict; +use warnings; + +use base 'TAP::Base'; + +my @ACCESSOR; + +BEGIN { + + @ACCESSOR = qw( name formatter parser show_count ); + + for my $method (@ACCESSOR) { + no strict 'refs'; + *$method = sub { shift->{$method} }; + } +} + +=head1 NAME + +TAP::Formatter::Session - Abstract base class for harness output delegate + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +=head1 METHODS + +=head2 Class Methods + +=head3 C<new> + + my %args = ( + formatter => $self, + ) + my $harness = TAP::Formatter::Console::Session->new( \%args ); + +The constructor returns a new C<TAP::Formatter::Console::Session> object. + +=over 4 + +=item * C<formatter> + +=item * C<parser> + +=item * C<name> + +=item * C<show_count> + +=back + +=cut + +sub _initialize { + my ( $self, $arg_for ) = @_; + $arg_for ||= {}; + + $self->SUPER::_initialize($arg_for); + my %arg_for = %$arg_for; # force a shallow copy + + for my $name (@ACCESSOR) { + $self->{$name} = delete $arg_for{$name}; + } + + if ( !defined $self->show_count ) { + $self->{show_count} = 1; # defaults to true + } + if ( $self->show_count ) { # but may be a damned lie! + $self->{show_count} = $self->_should_show_count; + } + + if ( my @props = sort keys %arg_for ) { + $self->_croak( + "Unknown arguments to " . __PACKAGE__ . "::new (@props)" ); + } + + return $self; +} + +=head3 C<header> + +Output test preamble + +=head3 C<result> + +Called by the harness for each line of TAP it receives. + +=head3 C<close_test> + +Called to close a test session. + +=head3 C<clear_for_close> + +Called by C<close_test> to clear the line showing test progress, or the parallel +test ruler, prior to printing the final test result. + +=head3 C<time_report> + +Return a formatted string about the elapsed (wall-clock) time +and about the consumed CPU time. + +=cut + +sub header { } + +sub result { } + +sub close_test { } + +sub clear_for_close { } + +sub _should_show_count { + my $self = shift; + return + !$self->formatter->verbose + && -t $self->formatter->stdout + && !$ENV{HARNESS_NOTTY}; +} + +sub _format_for_output { + my ( $self, $result ) = @_; + return $self->formatter->normalize ? $result->as_string : $result->raw; +} + +sub _output_test_failure { + my ( $self, $parser ) = @_; + my $formatter = $self->formatter; + return if $formatter->really_quiet; + + my $tests_run = $parser->tests_run; + my $tests_planned = $parser->tests_planned; + + my $total + = defined $tests_planned + ? $tests_planned + : $tests_run; + + my $passed = $parser->passed; + + # The total number of fails includes any tests that were planned but + # didn't run + my $failed = $parser->failed + $total - $tests_run; + my $exit = $parser->exit; + + if ( my $exit = $parser->exit ) { + my $wstat = $parser->wait; + my $status = sprintf( "%d (wstat %d, 0x%x)", $exit, $wstat, $wstat ); + $formatter->_failure_output("Dubious, test returned $status\n"); + } + + if ( $failed == 0 ) { + $formatter->_failure_output( + $total + ? "All $total subtests passed " + : 'No subtests run ' + ); + } + else { + $formatter->_failure_output("Failed $failed/$total subtests "); + if ( !$total ) { + $formatter->_failure_output("\nNo tests run!"); + } + } + + if ( my $skipped = $parser->skipped ) { + $passed -= $skipped; + my $test = 'subtest' . ( $skipped != 1 ? 's' : '' ); + $formatter->_output( + "\n\t(less $skipped skipped $test: $passed okay)"); + } + + if ( my $failed = $parser->todo_passed ) { + my $test = $failed > 1 ? 'tests' : 'test'; + $formatter->_output( + "\n\t($failed TODO $test unexpectedly succeeded)"); + } + + $formatter->_output("\n"); +} + +sub _make_ok_line { + my ( $self, $suffix ) = @_; + return "ok$suffix\n"; +} + +sub time_report { + my ( $self, $formatter, $parser ) = @_; + + my @time_report; + if ( $formatter->timer ) { + my $start_time = $parser->start_time; + my $end_time = $parser->end_time; + if ( defined $start_time and defined $end_time ) { + my $elapsed = $end_time - $start_time; + push @time_report, + $self->time_is_hires + ? sprintf( ' %8d ms', $elapsed * 1000 ) + : sprintf( ' %8s s', $elapsed || '<1' ); + } + my $start_times = $parser->start_times(); + my $end_times = $parser->end_times(); + my $usr = $end_times->[0] - $start_times->[0]; + my $sys = $end_times->[1] - $start_times->[1]; + my $cusr = $end_times->[2] - $start_times->[2]; + my $csys = $end_times->[3] - $start_times->[3]; + push @time_report, + sprintf('(%5.2f usr %5.2f sys + %5.2f cusr %5.2f csys = %5.2f CPU)', + $usr, $sys, $cusr, $csys, + $usr + $sys + $cusr + $csys); + } + + return "@time_report"; +} + +1; |