File Coverage

blib/lib/Test/Base/SubTest.pm

Criterion	Covered	Total	%
statement	91	99	91.9
branch	18	22	81.8
condition	11	17	64.7
subroutine	19	20	95.0
pod	4	4	100.0
total	143	162	88.2

package Test::Base::SubTest;
use strict;
use warnings;
use utf8;
use parent qw(Exporter);
our @EXPORT = (@Test::More::EXPORT, qw/filters blocks register_filter run run_is run_is_deeply/);

our $VERSION = '0.5';

use parent qw/
    Test::Base::Less
    Test::Builder::Module Exporter
/;
use Test::More;
use Carp qw/croak/;
use Text::TestBase::SubTest;

my $SKIP;

sub blocks() { croak 'block() is not supported. Use run{} instead.' }

{
    no warnings 'once';
    *filters         = \&Test::Base::Less::filters;
    *register_filter = \&Test::Base::Less::register_filter;
}

sub run(&) {
    my $code = shift;

    my $content = _get_data_section();
    my $node = Text::TestBase::SubTest->new->parse($content);

    _exec_each_test($node, sub {
        my $block = shift;
        $code->($block);
    });
}

sub run_is {
    my ($a, $b) = @_;
    $a ||= 'input';
    $b ||= 'expected';
    my $content = _get_data_section();
    my $node = Text::TestBase::SubTest->new->parse($content);

    _exec_each_test($node, sub {
        my $block = shift;
        __PACKAGE__->builder->is_eq(
            $block->get_section($a),
            $block->get_section($b),
            $block->name || 'L: ' . $block->get_lineno
        );
    });
}

sub run_is_deeply($$) {
    my ($a, $b) = @_;
    $a ||= 'input';
    $b ||= 'expected';
    my $package = scalar(caller(0));

    my $content = _get_data_section();
    my $node = Text::TestBase::SubTest->new->parse($content);

    _exec_each_test($node, sub {
        my $block = shift;
        local $Test::Builder::Level = $Test::Builder::Level + 1;
        Test::More::is_deeply(
            $block->get_section($a),
            $block->get_section($b),
            $block->name || 'L: ' . $block->get_lineno
        );
    });
}

sub _exec_each_test {
    my ($subtest, $code) = @_;

    my $executer = sub {
        for my $node (@{ $subtest->child_nodes }) {
            if ($node->is_subtest) {
                _exec_each_test($node, $code);
            } else {
                next if $SKIP;

                my @names = $node->get_section_names;
                for my $section_name (@names) {
                    my @data = $node->get_section($section_name);
                    if (my $filter_names = $Test::Base::Less::FILTER_MAP{$section_name}) {
                        for my $filter_stuff (@$filter_names) {
                            if (ref $filter_stuff eq 'CODE') { # filters { input => [\&code] };
                                @data = $filter_stuff->(@data);
                            } else { # filters { input => [qw/eval/] };
                                my $filter = $Test::Base::Less::FILTERS{$filter_stuff};
                                unless ($filter) {
                                    Carp::croak "Unknown filter name: $filter_stuff";
                                }
                                @data = $filter->(@data);
                            }
                        }
                    }
                    $node->set_section($section_name => @data);
                }
                if ($node->has_section('ONLY')) {
                    Carp::croak "Sorry, section 'ONLY' is not implemented... Patches welcome.";
                    __PACKAGE__->builder->diag("I found ONLY: maybe you're debugging?");
                    $SKIP = 1;
                    $code->($node);
                    next;
                }
                if ($node->has_section('SKIP')) {
                    next;
                }
                if ($node->has_section('LAST')) {
                    $SKIP = 1;
                    $code->($node);
                    next;
                }

                $code->($node);
            }
        }
    };
    if ($subtest->is_root) {
        $executer->();
    } else {
        return if $SKIP;
        __PACKAGE__->builder->subtest(
            ($subtest->name || 'L: ' . $subtest->get_lineno) => $executer
        );
    }
}

sub _get_data_section {
    my $package = scalar(caller(1));
    my $d = do { no strict 'refs'; \*{"${package}::DATA"} };
    unless (defined fileno $d) {
        Carp::croak("Missing __DATA__ section in $package.");
    }
    seek $d, 0, 0;

    return join '', <$d>;
}

1;
__END__