File Coverage

blib/lib/Text/TestBase.pm

Criterion	Covered	Total	%
statement	63	64	98.4
branch	15	22	68.1
condition	3	8	37.5
subroutine	10	10	100.0
pod	2	2	100.0
total	93	106	87.7

package Text::TestBase;
use strict;
use warnings;
use 5.008001;
our $VERSION = '0.13';

use Class::Accessor::Lite (
    rw => [qw/block_delim data_delim block_class/],
);
use Carp ();

use Text::TestBase::Block;

sub new {
    my $class = shift;
    my %args = @_==1 ? %{$_[0]} : @_;
    bless {
        block_delim => '===',
        data_delim => '---',
        block_class => 'Text::TestBase::Block',
        %args,
    }, $class;
}

sub parse {
    my ($self, $spec) = @_;
    my $cd = $self->block_delim;
    my $lineno = 1;
    my @hunks;

    $spec =~ s/
          ^(\Q${cd}\E.*?(?=^\Q${cd}\E|\z))
        | ^([^\n]*\n)
    /
        if ($1) {
            push @hunks, $1;
        } elsif ($2) {
            $lineno++;
        }
        '';
    /msgxe;

    my @blocks;
    for my $hunk (@hunks) {
        push @blocks, $self->_make_block($hunk, $lineno);
        $hunk =~ s/\n/$lineno++/ge;
    }
    return @blocks;
}

sub _make_block {
    my ($self, $hunk, $lineno) = @_;

    my $cd = $self->block_delim;
    my $dd = $self->data_delim;
    $hunk =~ s/\A\Q${cd}\E[ \t]*(.*)\s+// or die;
    my $name = $1;
    my @parts = split /^\Q${dd}\E +\(?(\w+)\)? *(.*)?\n/m, $hunk;
    my $description = shift @parts;
    $description ||= '';
    unless ($description =~ /\S/) {
        $description = $name;
    }
    $description =~ s/\s*\z//;
    my $block = $self->block_class->new(
        description => $description,
        name        => $name,
        _lineno     => $lineno,
    );

    my $filter_map = {};
    my $section_order = [];
    while (@parts) {
        my ($type, $filters, $value) = splice(@parts, 0, 3);
        $self->_check_reserved($type);
        $value = '' unless defined $value;
        $filters = '' unless defined $filters;
        if ($filters =~ /:(\s|\z)/) {
            Carp::croak "Extra lines not allowed in '$type' section"
              if $value =~ /\S/;
            ($filters, $value) = split /\s*:(?:\s+|\z)/, $filters, 2;
            $value = '' unless defined $value;
            $value =~ s/^\s*(.*?)\s*$/$1/;
        }
        $block->push_section($type, $value, $filters);
    }
    return $block;
}

my $reserved_section_names = {};
{
    %$reserved_section_names = map {
        ($_, 1);
    } keys(%Text::TestBase::Block::), qw( new DESTROY );
}
sub _check_reserved {
    my $id = shift;
    Carp::croak "'$id' is a reserved name. Use something else.\n"
      if $reserved_section_names->{$id} or
         $id =~ /^_/ or $id =~ /^(get_|set_|push_)/;
}


1;
__END__