File Coverage

blib/lib/Test/Base/Less.pm

Criterion	Covered	Total	%
statement	93	98	94.9
branch	14	18	77.7
condition	6	11	54.5
subroutine	21	22	95.4
pod	3	6	50.0
total	137	155	88.3

package Test::Base::Less;
use strict;
use warnings;
use utf8;

our $VERSION = '0.13';

use parent qw/Test::Builder::Module Exporter/;
use Test::More;
use Data::Section::TestBase ();
use Carp ();

our @EXPORT = (@Test::More::EXPORT, qw/filters blocks register_filter run run_is run_is_deeply/);

our %FILTER_MAP;
our %FILTERS;

sub register_filter($&) {
    my ($name, $code) = @_;
    $FILTERS{$name} = $code;
}

sub filters($) {
    my $data = shift;
    for my $key (keys %$data) {
        $FILTER_MAP{$key} ||= [];
        push @{$FILTER_MAP{$key}}, @{$data->{$key}};
    }
    return;
}

sub blocks() {
    my @blocks = _get_blocks(scalar(caller(0)));
    return @blocks;
}

sub _get_blocks {
    my $package = shift;

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

    my $content = join '', <$d>;

    my $parser = Text::TestBase->new();
    my @blocks = $parser->parse($content);
    my @retval;
    for my $block (@blocks) {
        for my $section_name ($block->get_section_names) {
            my @data = $block->get_section($section_name);
            if (my $filter_names = $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 = $FILTERS{$filter_stuff};
                        unless ($filter) {
                            Carp::croak "Unknown filter name: $filter_stuff";
                        }
                        @data = $filter->(@data);
                    }
                }
            }
            $block->set_section($section_name => @data);
        }
        if ($block->has_section('ONLY')) {
            __PACKAGE__->builder->diag("I found ONLY: maybe you're debugging?");
            return $block;
        }
        if ($block->has_section('SKIP')) {
            next;
        }
        push @retval, $block;
        if ($block->has_section('LAST')) {
            return @retval;
        }
    }
    return @retval;
}

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

    for my $block (_get_blocks(scalar(caller(0)))) {
        __PACKAGE__->builder->subtest($block->name || 'L: ' . $block->get_lineno, sub {
            $code->($block);
        });
    }
}

sub run_is($$) {
    my ($a, $b) = @_;

    for my $block (_get_blocks(scalar(caller(0)))) {
        __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) = @_;

    for my $block (_get_blocks(scalar(caller(0)))) {
        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
        );
    }
}

package Test::Base::Less::Filter;

Test::Base::Less::register_filter(eval => \&_eval);

sub _eval {
    my $src = shift;
    no warnings;
    my @return = CORE::eval $src;
    return $@ if $@;
    return @return;
}

Test::Base::Less::register_filter(chomp => \&_chomp);
sub _chomp {
    map { CORE::chomp; $_ } @_;
}

Test::Base::Less::register_filter(uc => \&_uc);
sub _uc {
    map { CORE::uc($_) } @_;
}

Test::Base::Less::register_filter(trim => \&_trim);
sub _trim {
    map {
        s/\A([ \t]*\n)+//;
        s/(?<=\n)\s*\z//g;
        $_;
    } @_;
}

Test::Base::Less::register_filter(lines => \&_lines);
sub _lines {
    my $src = shift;
    return () unless length $src;
    my @lines = ($src =~ /^(.*\n?)/gm);
    return @lines;
}

1;
__END__