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__

=head1 NAME

Test::Base::SubTest - Enables Test::Base to use subtest

=head1 SYNOPSIS

    use Test::Base::SubTest;

    filters { input => [qw/eval/] };
    run {
        my $block = shift;
        is $block->input, $block->expected, $block->name;
    };
    done_testing;

    __DATA__

    ### subtest 1
        === test 1-1
        --- input:    4*2
        --- expected: 8

        === test 1-2
        --- input :   3*3
        --- expected: 9

    ### subtest 2
        === test 2-1
        --- input:    4*3
        --- expected: 12

=begin html

<div><img src="http://cdn-ak.f.st-hatena.com/images/fotolife/C/Cside/20140116/20140116204246.png?1389872580"></div>

=end html

=head1 DESCRIPTION

Test::Base::SubTest is a extension of L<Test::Base::Less>.

"### TEST NAME" is a delimiter of a subtest. Indentaion is necessary.

=head1 FUNCTIONS

This module exports all Test::More's exportable functions, and following functions:

=over 4

=item filters(+{ } : HashRef);

    filters {
        input => [qw/eval/],
    };

Set a filter for the section name.

=item run(\&subroutine)

    run {
        my $block = shift;
        is $block->input, $block->expected, $block->name;
    };

Calls the sub for each block. It passes the current block object to the subroutine.

=item run_is([data_name1, data_name2])

    run_is input => 'expected';

=item run_is_deeply([data_name1, data_name2])

=item register_filter($name: Str, $code: CodeRef)

Register a filter for $name using $code.

=back

=head1 DEFAULT FILTERS

This module provides only few filters. If you want to add more filters, pull-reqs welcome.
(I only merge a patch using no depended modules)

=over 4

=item eval

eval() the code.

=item chomp

C<chomp()> the arguments.

=item uc

C<uc()> the arguments.

=item trim

Remove extra blank lines from the beginning and end of the data. This
allows you to visually separate your test data with blank lines.

=back

=head1 REGISTER YOUR OWN FILTER

You can register your own filter by following form:

    use Digest::MD5 qw/md5_hex/;
    Test::Base::Less::register_filter(md5_hex => \&md5_hex);

=head1 USE CODEREF AS FILTER

You can use a CodeRef as filter.

    use Digest::MD5 qw/md5_hex/;
    filters {
        input => [\&md5_hex],
    };

=head1 SEE ALSO

Most of code is taken from L<Test::Base::Less>. Thank you very match, tokuhirom.

=head1 AUTHOR

Hiroki Honda E<lt>cside.story@gmail.comE<gt>

=head1 LICENSE

Copyright (C) Hiroki Honda

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut