Initial Commit
This commit is contained in:
Riley Schneider
201
database/perl/lib/TAP/Formatter/Console/ParallelSession.pm
Normal file
201
database/perl/lib/TAP/Formatter/Console/ParallelSession.pm
Normal file
@@ -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.42
|
||||
|
||||
=cut
|
||||
|
||||
our $VERSION = '3.42';
|
||||
|
||||
=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;
|
||||
205
database/perl/lib/TAP/Formatter/Console/Session.pm
Normal file
205
database/perl/lib/TAP/Formatter/Console/Session.pm
Normal file
@@ -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.42
|
||||
|
||||
=cut
|
||||
|
||||
our $VERSION = '3.42';
|
||||
|
||||
=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( $self->_make_ok_line($time_report) );
|
||||
}
|
||||
},
|
||||
};
|
||||
}
|
||||
|
||||
=head2 C<< clear_for_close >>
|
||||
|
||||
=head2 C<< close_test >>
|
||||
|
||||
=head2 C<< header >>
|
||||
|
||||
=head2 C<< result >>
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
Reference in New Issue
Block a user