File Coverage

blib/lib/Test/Steering/Wheel.pm

Criterion	Covered	Total	%
statement	137	142	96.4
branch	35	42	83.3
condition	5	9	55.5
subroutine	24	25	96.0
pod	5	5	100.0
total	206	223	92.3

package Test::Steering::Wheel;

use warnings;
use strict;
use Carp;
use TAP::Harness;
use Scalar::Util qw(refaddr);

=head1 NAME

Test::Steering::Wheel - Execute tests and renumber the resulting TAP.

=head1 VERSION

This document describes Test::Steering::Wheel version 0.02

=cut

our $VERSION = '0.02';

=head1 SYNOPSIS

    use Test::Steering::Wheel;

    my $wheel = Test::Steering::Wheel->new;
    $wheel->include_tests( 'xt/vms/*.t' ) if $^O eq 'VMS';
    $wheel->include_tests( 'xt/windows/*.t' ) if $^O =~ 'MSWin32';

=head1 DESCRIPTION

Behind the scenes in L is a singleton instance of
C.

See L for more information.

=head1 INTERFACE

=head2 C<< new >>

Create a new C.

=over

=item C<< add_prefix >>

=item C<< announce >>

=item C<< defaults >>

=item C<< harness >>

=back

=cut

{
    my %DEFAULTS;

    BEGIN {
        %DEFAULTS = (
            add_prefix => 0,
            announce   => 0,
            defaults   => {},
            harness    => 'TAP::Harness',
        );

        for my $method ( keys %DEFAULTS ) {
            no strict 'refs';
            *{ __PACKAGE__ . '::' . $method } = sub {
                my $self = shift;
                croak "$method may not be set" if @_;
                return $self->{$method};
            };
        }
    }

    sub new {
        my $class = shift;
        croak "Must supply an even number of arguments" if @_ % 1;
        my %args = ( %DEFAULTS, @_ );

        my @bad = grep { !exists $DEFAULTS{$_} } keys %args;
        croak "Illegal option(s): ", join ', ', sort @bad if @bad;

        return bless { _test_number_adjust => 0, %args }, $class;
    }

    # Documentation lower down
    sub option_names {
        my $class = shift;
        return sort keys %DEFAULTS;
    }
}

# Output demultiplexer. Handles output associated with multiple parsers.
# If parsers output sequentially no buffering is done. If, however,
# output from multiple parsers is interleaved output from the first
# encountered will be echoed directly and output from all the others
# will be buffered.
#
# After a parser finishes (calls $done) the next parser to generate
# output will have its buffer flushed and will start output directly.
#
# The upshot of all this is that we output from multiple parsers doing
# the minimum amount of buffering necessary to keep per-parser output
# ordered.

sub _output_demux {
    my ( $self, $printer, $complete ) = @_;
    my $current_id = undef;
    my %queue_for  = ();
    my @completed  = ();

    my $finish = sub {
        while ( my $job = shift @completed ) {
            my ( $parser, $buffered ) = @$job;
            $printer->( $parser, @$_ ) for @$buffered;
            $complete->( $parser );
        }
    };

    return (
        # demux
        sub {
            my ( $parser, $type, $line ) = @_;
            my $id = refaddr $parser;

            unless ( defined $current_id ) {
                # Our chance to take over...
                if ( $self->announce ) {
                    my $name = $self->_name_for_parser( $parser );
                    print STDERR "# Running $name\n";
                }
                if ( my $buffered = delete $queue_for{$id} ) {
                    $printer->( $parser, @$_ ) for @$buffered;
                }
                $current_id = $id;
            }

            if ( $current_id == $id ) {
                $printer->( $parser, $type, $line );
            }
            else {
                push @{ $queue_for{$id} }, [ $type, $line ];
            }

        },
        # done
        sub {
            my $parser = shift;
            my $id     = refaddr $parser;
            if ( defined $current_id && $current_id == $id ) {
                # Finished the current one so allow another to
                # take over
                $complete->( $parser );
                undef $current_id;
                # Flush any others that have completed in the mean time
                $finish->();
            }
            else {
                # Add to completed list
                push @completed, [ $parser, delete $queue_for{$id} ];
            }
        },
        # finish
        $finish,
    );
}

sub _name_for_parser {
    my $self   = shift;
    my $parser = shift;
    my $id     = refaddr $parser;
    return $self->{parser_name}->{$id} unless @_;
    return $self->{parser_name}->{$id} = shift;
}

# Like ok
sub _output_result {
    my ( $self, $ok, $description ) = @_;
    printf( "%sok %d %s\n",
        $ok ? '' : 'not ',
        ++$self->{_test_number_adjust}, $description );
}

# Output additional test failures if our subtest had problems.

sub _parser_postmortem {
    my ( $self, $parser ) = @_;

    my $test = $self->_name_for_parser( $parser );

    my @errs = ();

    push @errs, "$test: Parse error: $_" for $parser->parse_errors;

    my ( $wait, $exit ) = ( $parser->wait, $parser->exit );
    push @errs, "$test: Non-zero status: exit=$exit, wait=$wait"
      if $exit || $wait;

    if ( @errs ) {
        $self->_output_result( 0, $_ ) for @errs;
    }
    else {
        $self->_output_result( 1, "$test done" );
    }
}

sub _load {
    my $class = shift;
    unless ( $INC{$class} || eval "use $class; 1" ) {
        croak "Can't load $class: $@";
    }
    return $class;
}

=head2 C<< include_tests >>

Run one or more tests. Wildcards will be expanded.

    include_tests( 'xt/vms/*.t' ) if $^O eq 'VMS';
    include_tests( 'xt/windows/*.t' ) if $^O =~ 'MSWin32';

=cut

sub include_tests {
    my ( $self, @tests ) = @_;

    my %options = ( verbosity => -9, %{ $self->defaults } );
    my @real_tests = ();

    # Split options hashes from tests
    for my $t (
        map { 'ARRAY' eq ref $_ ? $_ : [ $_, $_ ] }
        map { ref $_ ? $_ : glob $_ } @tests
      ) {
        if ( 'HASH' eq ref $t ) {
            %options = ( %options, %$t );
        }
        else {
            push @real_tests,
              grep { !$self->{_seen}->{ $_->[1] }++ } $t;
        }
    }

    my $harness    = _load( $self->harness )->new( \%options );
    my $add_prefix = $self->add_prefix;

    my $printer = sub {
        my ( $parser, $type, $line ) = @_;
        print "TAP version 13\n" unless $self->{_started}++;
        if ( $type eq 'test' ) {
            $line =~ s/(\d+)/$1 + $self->{_test_number_adjust}/e;
            if ( $add_prefix ) {
                my $name = $self->_name_for_parser( $parser );
                $line =~ s/(\d+)[ \t]*(\S+)/$1: $2/;
                $line =~ s/(\d+)/$1 $name/;
            }
        }
        print $line;
    };

    my $complete = sub {
        my $parser    = shift;
        my $tests_run = $parser->tests_run;
        $self->{_test_number_adjust} += $parser->tests_run;
    };

    my ( $demux, $done, $finish )
      = $self->_output_demux( $printer, $complete );

    $harness->callback(
        made_parser => sub {
            my ( $parser, $test_desc ) = @_;

            $self->_name_for_parser( $parser, $test_desc->[1] );

            $parser->callback( plan    => sub { } );
            $parser->callback( version => sub { } );
            $parser->callback(
                test => sub {
                    my $test = shift;
                    my $raw  = $test->as_string;
                    $demux->( $parser, 'test', "$raw\n" );
                }
            );
            $parser->callback(
                ELSE => sub {
                    my $result = shift;
                    $demux->( $parser, 'raw', $result->raw . "\n" );
                }
            );
            $parser->callback(
                EOF => sub {
                    $done->( $parser );
                    $self->_parser_postmortem( $parser );
                }
            );
        }
    );

    my $aggregator = $harness->runtests( @real_tests );
    $finish->();
}

=head2 C

Output the trailing plan.

=cut

sub end_plan {
    my $self = shift;
    if ( my $plan = $self->{_test_number_adjust} ) {
        print "1..$plan\n";
        $self->{_test_number_adjust} = 0;
    }
}

=head2 C<< tests_run >>

Get a list of tests that have been run.

    my @tests = $wheel->tests_run();

=cut

sub tests_run {
    my $self = shift;
    return sort keys %{ $self->{_seen} || {} };
}

=head2 C<< option_names >>

Get the names of the supported options to C. Used by L
to validate its arguments.

=cut

1;

__END__