File Coverage

blib/lib/TAP/Filter.pm

Criterion	Covered	Total	%
statement	75	76	98.6
branch	17	18	94.4
condition	11	12	91.6
subroutine	19	19	100.0
pod	4	4	100.0
total	126	129	97.6

package TAP::Filter;

use warnings;
use strict;
use Carp qw( confess croak );
use TAP::Filter::Iterator;

use base qw( TAP::Harness );

=head1 NAME

TAP::Filter - Filter TAP stream within TAP::Harness

=head1 VERSION

This document describes TAP::Filter version 0.04

=cut

our $VERSION = '0.04';

=head1 SYNOPSIS

In a program:

    use TAP::Filter qw( MyFilter );

    my $harness = TAP::Filter->new;
    $harness->runtests( @tests );

With prove:

    prove --harness=TAP::Filter=MyFilter -rb t

=head1 DESCRIPTION

C allows arbitrary filters to be placed in the TAP
processing pipeline of L. Installed filters see the parsed
TAP stream a line at a time and can modify the stream by

=over

=item * replacing a result

=item * injecting extra results

=item * removing results

=back

C exists mainly to load a number of filters into the TAP
processing pipeline. Filters are generally subclasses of
L. See the documentation for that module for
information about writing filters.

=head2 Loading filters

Filters may be installed into the TAP processing pipeline in a number of
different ways...

=head3 From the prove command line

The C command that is supplied with L allows tests
to be run interactively from the command line. By default it will use
L to run these tests it can be told to use a different
harness. C (which is a subclass of L) may be
used with C in this way:

    prove --harness=TAP::Filter=MyFilter,OtherFilter -rb t

C will attempt to load two filters, C and
C. If the name of the filter class to be loaded starts with
C that prefix may be omitted, so the example above would
load filter classes called C and
C.

=head3 C<< use TAP::Filter qw( MyFilter ) >>

If you are writing a program that uses L you can load
filters by replacing

    use TAP::Harness;
    my $harness = TAP::Harness->new;

with

    use TAP::Filter qw( MyFilter OtherFilter );
    my $harness = TAP::Filter->new;

As with the prove command line invocation above C will
attempt to load the specified filter classes from the C
namespace. If that fails the classnames are taken to be absolute.

=head3 Calling C<< TAP::Filter->add_filter >>

As an alternative to the concise filter loading notation above filters
may be loaded by calling C:

    use TAP::Filter;
    TAP::Filter->add_filter( 'MyFilter' );
    TAP::Filter->add_filter( 'OtherFilter' );
    my $harness = TAP::Filter->new;

Multiple filters may be loaded with a single call to C:

    TAP::Filter->add_filter( 'MyFilter', 'OtherFilter' );

You may also pass a reference to a filter instance:

    my $my_filter = TAP::Filter::MyFilter->new;
    TAP::Filter->add_filter( $my_filter );

=head2 Filter scope

C maintains a single, global list of installed filters.
Once loaded filters can not be removed. If either of these features
proves problematic let me know and I'll consider alternatives.

=head1 INTERFACE

=head2 C<< add_filter >>

Add one or more filters to C's filter chain. Each argument
to C may be either

=over

=item * a partial class name

=item * a complete class name

=item * a filter instance

=back

If the filter's class name begins with C it is only
necessary to supply the trailing portion of the name:

    # Looks for TAP::Filter::Foo::Bar then plain Foo::Bar
    TAP::Filter->add_filter( 'Foo::Bar' );

=cut

sub _filter_from_class_name {
    my $class = shift;
    my $name  = shift;
    return $name if !defined $name || ref $name;
    my @err = ();
    for my $prefix ( 'TAP::Filter::', '' ) {
        my $class_name = $prefix . $name;
        eval "use $class_name";
        return $class_name->new unless $@;
        push @err, $@;
    }
    croak "Can't load filter class for $name\n", join( '', @err );
}

{
    my @Filter = ();

    sub add_filter {
        my $class = shift;
        for my $name ( @_ ) {
            my $filter = $class->_filter_from_class_name( $name );
            croak "Filter must have a 'add_to_parser' method"
              unless defined $filter
                  && UNIVERSAL::can( $filter, 'can' )
                  && $filter->can( 'add_to_parser' );
            push @Filter, $filter;
        }
    }

=head2 C<< get_filters >>

Returns a list of currently installed filters. Each item in the list
will be a reference to an instantiated filter - even if the
corresponding filter was specified by class name.

=cut

    sub get_filters {
        my $class = shift;
        return @Filter;
    }
}

=head2 C<< make_parser >>

Subclassed from C. Create a new C and install
any registered filters in its TAP processing pipeline.

Study the implementation of C if you need to implement an
alternative filter loading scheme.

=cut

sub make_parser {
    my ( $self, @args ) = @_;

    my ( $parser, $session ) = $self->SUPER::make_parser( @args );

    for my $filter ( reverse $self->get_filters ) {
        $filter->add_to_parser( $parser );
    }

    return ( $parser, $session );
}

sub import {
    my $class = shift;
    $class->add_filter( @_ );
}

=head2 C<< ok >>

A convenience method for creating new test results to inject into the
TAP stream.

    my $result = TAP::Filter->ok(
        ok          => 1,          # test passed
        description => 'A test',
    );

The returned result is an instance of L suitable
for feeding into the TAP stream. See L for more
information about manipulating the TAP stream.

The arguments to C are a number of key, value pairs. The following
keys are recognised:

=over

=item C

Boolean. Whether the test passed.

=item C

The textual description of the test.

=item C

A TODO or SKIP directive.

=item C

Text explaining why the test is a skip or todo.

=back

=cut

sub _load_result_maker {
    my @classes = (
        [ 'TAP::Parser::ResultFactory' => 'make_result' ],
        [ 'TAP::Parser::Result'        => 'new' ]
    );

    for my $ctor ( @classes ) {
        my ( $pkg, $method ) = @$ctor;
        eval "use $pkg ()";
        unless ( $@ ) {
            return sub {
                return $pkg->$method( @_ );
            };
        }
    }

    confess "Can't load a suitable TAP::Parser::Result"
      . " factory class, tried ", join( ', ', @classes ), "\n";
}

{
    my $result_maker = undef;
    sub _result_maker { $result_maker ||= _load_result_maker }
}

sub _trim {
    my $data = shift;
    return '' unless defined $data;
    $data =~ s/^\s+//;
    $data =~ s/\s+$//;
    return $data;
}

sub _escape {
    my $str = shift;
    $str =~ s/([#\\])/\\$1/g;
    return $str;
}

sub _make_raw {
    my $spec = shift;
    my @raw = ( $spec->{ok}, '*' );
    push @raw, _escape( $spec->{description} )
      if $spec->{description};
    if ( my $dir = $spec->{directive} ) {
        push @raw, "# $dir";
        push @raw, _escape( $spec->{explanation} )
          if $spec->{explanation};
    }
    return join ' ', @raw;
}

{
    my %spec_filter = (
        type        => sub { 'test' },
        test_num    => sub { 0 },
        explanation => sub { _trim( shift ) },
        description => sub {
            my $desc = _trim( shift );
            return $desc ? "- $desc" : '';
        },
        directive => sub {
            my $dir = shift;
            return uc( defined $dir ? $dir : '' );
        },
        ok => sub { $_[0] ? 'ok' : 'not ok' },
    );

    sub ok {
        my $class = shift;
        croak "ok needs a number of name => value pairs"
          if @_ & 1;
        my %spec = @_;

        for my $name ( keys %spec_filter ) {
            $spec{$name} = $spec_filter{$name}->( $spec{$name} );
        }

        $spec{raw} = _make_raw( \%spec );
        return _result_maker()->( \%spec );
    }
}

1;
__END__