diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/TAP/Formatter/Console/ParallelSession.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/TAP/Formatter/Console/ParallelSession.pm | 202 |
1 files changed, 202 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/TAP/Formatter/Console/ParallelSession.pm b/Master/tlpkg/tlperl/lib/TAP/Formatter/Console/ParallelSession.pm new file mode 100644 index 00000000000..b6b5134cda1 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/TAP/Formatter/Console/ParallelSession.pm @@ -0,0 +1,202 @@ +package TAP::Formatter::Console::ParallelSession; + +use strict; +use File::Spec; +use File::Path; +use TAP::Formatter::Console::Session; +use Carp; + +use constant WIDTH => 72; # Because Eric says +use vars qw($VERSION @ISA); + +@ISA = qw(TAP::Formatter::Console::Session); + +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.17 + +=cut + +$VERSION = '3.17'; + +=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; + + foreach 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; |