Initial Commit

database/perl/lib/TAP/Formatter/Base.pm

@@ -0,0 +1,467 @@
+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.42
+
+=cut
+
+our $VERSION = '3.42';
+
+=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;
+    defined $wait or $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;

database/perl/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.42
+
+=cut
+
+our $VERSION = '3.42';
+
+=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;

database/perl/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.42
+
+=cut
+
+our $VERSION = '3.42';
+
+=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;

database/perl/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.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;

database/perl/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.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;

database/perl/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.42
+
+=cut
+
+our $VERSION = '3.42';
+
+=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;

database/perl/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.42
+
+=cut
+
+our $VERSION = '3.42';
+
+=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} : "" )
+              . $self->_make_ok_line($time_report) );
+    }
+}
+
+1;

database/perl/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.42
+
+=cut
+
+our $VERSION = '3.42';
+
+=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;