TAP::Harness::Compatible - Run Perl standard test scripts with statistics

  use TAP::Harness::Compatible;

  runtests(@test_files);

    bonus           Number of individual todo tests unexpectedly passed
    max             Number of individual tests ran
    ok              Number of individual tests passed
    sub_skipped     Number of individual tests skipped
    todo            Number of individual todo tests

    files           Number of test files ran
    good            Number of test files passed
    bad             Number of test files failed
    tests           Number of test files originally given
    skipped         Number of test files skipped

    name        Name of the test which failed
    estat       Script's exit value
    wstat       Script's wait status
    max         Number of individual tests
    failed      Number which failed
    canon       List of tests which failed (as string).

    Either Tim Bunce or Andreas Koenig, we don't know. What we know for
    sure is, that it was inspired by Larry Wall's F<TEST> script that came
    with perl distributions for ages. Numerous anonymous contributors
    exist.  Andreas Koenig held the torch for many years, and then
    Michael G Schwern.

package TAP::Harness::Compatible;

require 5.00405;

use TAP::Harness;
use TAP::Parser::Aggregator;

#use TAP::Harness::Compatible::Straps;
use Exporter;
use Benchmark;
use Config;
use strict;

# TODO: Emulate at least some of these
use vars qw(
  $VERSION
  @ISA @EXPORT @EXPORT_OK
  $Verbose $Switches $Debug
  $verbose $switches $debug
  $Columns
  $Directives
  $Timer
  $ML $Last_ML_Print
  $Strap
  $has_time_hires
);

BEGIN {
    eval q{use Time::HiRes 'time'};
    $has_time_hires = !$@;
}

$VERSION = '0.54';

# Backwards compatibility for exportable variable names.
*verbose  = *Verbose;
*switches = *Switches;
*debug    = *Debug;

$ENV{HARNESS_ACTIVE}  = 1;
$ENV{HARNESS_VERSION} = $VERSION;

END {

    # For VMS.
    delete $ENV{HARNESS_ACTIVE};
    delete $ENV{HARNESS_VERSION};
}

@ISA       = ('Exporter');
@EXPORT    = qw(&runtests);
@EXPORT_OK = qw(&execute_tests $verbose $switches);

$Verbose = $ENV{HARNESS_VERBOSE} || 0;
$Debug   = $ENV{HARNESS_DEBUG}   || 0;
$Switches = '-w';
$Columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80;
$Columns--;    # Some shells have trouble with a full line of text.
$Timer = $ENV{HARNESS_TIMER} || 0;

sub runtests {
    my @tests = @_;

    my $harness   = _new_harness();
    my $aggregate = TAP::Parser::Aggregator->new();

    my $results = $harness->aggregate_tests( $aggregate, @tests );

    $harness->summary($results);

    my $total  = $aggregate->total;
    my $passed = $aggregate->passed;

    return $total && $total == $passed;
}

sub _canon {
    my @list   = sort { $a <=> $b } @_;
    my @ranges = ();
    my $count  = scalar @list;
    my $pos    = 0;

    while ( $pos < $count ) {
        my $end = $pos + 1;
        $end++ while $end < $count && $list[$end] <= $list[ $end - 1 ] + 1;
        push @ranges, ( $end == $pos + 1 )
          ? $list[$pos]
          : join( '-', $list[$pos], $list[ $end - 1 ] );
        $pos = $end;
    }

    return join( ' ', @ranges );
}

sub _new_harness {

    # This is a bit crufty. The switches have all been joined into a
    # single string so we have to try and recover them.
    my ( @lib, @switches );
    for my $opt (split( / \s+ (?=-) /x, $Switches )) {
        if ( $opt =~ /^ -I (.*) $ /x ) {
            push @lib, $1;
        }
        else {
            push @switches, $opt;
        }
    }

    my $args = {
        verbose    => $Verbose,
        timer      => $Timer,
        directives => $Directives,
        lib        => \@lib,
        switches   => \@switches,
    };

    return TAP::Harness->new($args);
}

sub _check_sequence {
    my @list = @_;
    my $prev;
    while ( my $next = shift @list ) {
        return if defined $prev && $next <= $prev;
        $prev = $next;
    }

    return 1;
}

sub execute_tests {
    my %args = @_;

    # TODO: Handle out option

    my $harness   = _new_harness();
    my $aggregate = TAP::Parser::Aggregator->new();

    my %tot = (
        bonus       => 0,
        max         => 0,
        ok          => 0,
        bad         => 0,
        good        => 0,
        files       => 0,
        tests       => 0,
        sub_skipped => 0,
        todo        => 0,
        skipped     => 0,
        bench       => undef,
    );

    # Install a callback so we get to see any plans the
    # harness executes.
    $harness->callback(
        made_parser => sub {
            my $parser = shift;
            $parser->callback(
                plan => sub {
                    my $plan = shift;
                    if ( $plan->directive eq 'SKIP' ) {
                        $tot{skipped}++;
                    }
                }
            );
        }
    );

    my $results = $harness->aggregate_tests( $aggregate, @{ $args{tests} } );

    $tot{bench} = timediff( $results->{end}, $results->{start} );

    # TODO: Work out the circumstances under which the files
    # and tests totals can differ.
    $tot{files} = $tot{tests} = @{ $results->{tests} };

    my %failedtests = ();
    my %todo_passed = ();

    for my $test ( @{ $results->{tests} } ) {
        my ($parser) = $aggregate->parsers($test);

        my @failed = $parser->failed;

        my $wstat         = $parser->wait;
        my $estat         = $parser->exit;
        my $planned       = $parser->tests_planned;
        my @errors        = $parser->parse_errors;
        my $passed        = $parser->passed;
        my $actual_passed = $parser->actual_passed;

        my $ok_seq = _check_sequence( $parser->actual_passed );

        # Duplicate exit, wait status semantics of old version
        $estat ||= '' unless $wstat;
        $wstat ||= '';

        $tot{max} += ( $planned || 0 );
        $tot{bonus} += $parser->todo_passed;
        $tot{ok} += $passed > $actual_passed ? $passed : $actual_passed;
        $tot{sub_skipped} += $parser->skipped;
        $tot{todo}        += $parser->todo;

        if ( @failed || $estat || @errors ) {
            $tot{bad}++;

            my $huh_planned = $planned ? undef: '??';
            my $huh_errors  = $ok_seq  ? undef: '??';

            $failedtests{$test} = {
                'canon' => $huh_planned
                  || $huh_errors
                  || _canon(@failed)
                  || '??',
                'estat'  => $estat,
                'failed' => $huh_planned || $huh_errors || scalar @failed,
                'max' => $huh_planned || $planned,
                'name'  => $test,
                'wstat' => $wstat
            };
        }
        else {
            $tot{good}++;
        }

        my @todo = $parser->todo_passed;
        if (@todo) {
            $todo_passed{$test} = {
                'canon'  => _canon(@todo),
                'estat'  => $estat,
                'failed' => scalar @todo,
                'max'    => scalar $parser->todo,
                'name'   => $test,
                'wstat'  => $wstat
            };
        }
    }

    return ( \%tot, \%failedtests, \%todo_passed );
}

1;
__END__