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


line stmt bran cond sub pod time code
1             package Text::TestBase;
2 14     14   68866 use strict;
  14         25  
  14         336  
3 14     14   65 use warnings;
  14         23  
  14         295  
4 14     14   306 use 5.008001;
  14         50  
5             our $VERSION = '0.13';
6              
7             use Class::Accessor::Lite (
8 14         100 rw => [qw/block_delim data_delim block_class/],
9 14     14   11599 );
  14         16174  
10 14     14   1106 use Carp ();
  14         23  
  14         266  
11              
12 14     14   7220 use Text::TestBase::Block;
  14         35  
  14         10591  
13              
14             sub new {
15 19     19 1 717 my $class = shift;
16 19 50       89 my %args = @_==1 ? %{$_[0]} : @_;
  0         0  
17 19         144 bless {
18             block_delim => '===',
19             data_delim => '---',
20             block_class => 'Text::TestBase::Block',
21             %args,
22             }, $class;
23             }
24              
25             sub parse {
26 18     18 1 41 my ($self, $spec) = @_;
27 18         88 my $cd = $self->block_delim;
28 18         135 my $lineno = 1;
29 18         39 my @hunks;
30              
31 18         560 $spec =~ s/
32             ^(\Q${cd}\E.*?(?=^\Q${cd}\E|\z))
33             | ^([^\n]*\n)
34             /
35 406 100       1308 if ($1) {
    50          
36 40         101 push @hunks, $1;
37             } elsif ($2) {
38 366         439 $lineno++;
39             }
40 406         1302 '';
41             /msgxe;
42              
43 18         59 my @blocks;
44 18         45 for my $hunk (@hunks) {
45 40         118 push @blocks, $self->_make_block($hunk, $lineno);
46 40         164 $hunk =~ s/\n/$lineno++/ge;
  170         377  
47             }
48 18         97 return @blocks;
49             }
50              
51             sub _make_block {
52 41     41   80 my ($self, $hunk, $lineno) = @_;
53              
54 41         124 my $cd = $self->block_delim;
55 41         262 my $dd = $self->data_delim;
56 41 50       715 $hunk =~ s/\A\Q${cd}\E[ \t]*(.*)\s+// or die;
57 41         158 my $name = $1;
58 41         642 my @parts = split /^\Q${dd}\E +\(?(\w+)\)? *(.*)?\n/m, $hunk;
59 41         105 my $description = shift @parts;
60 41   50     217 $description ||= '';
61 41 50       118 unless ($description =~ /\S/) {
62 41         67 $description = $name;
63             }
64 41         196 $description =~ s/\s*\z//;
65 41         160 my $block = $self->block_class->new(
66             description => $description,
67             name => $name,
68             _lineno => $lineno,
69             );
70            
71 41         95 my $filter_map = {};
72 41         65 my $section_order = [];
73 41         157 while (@parts) {
74 63         156 my ($type, $filters, $value) = splice(@parts, 0, 3);
75 63         165 $self->_check_reserved($type);
76 63 100       159 $value = '' unless defined $value;
77 63 100       139 $filters = '' unless defined $filters;
78 63 100       228 if ($filters =~ /:(\s|\z)/) {
79 34 50       94 Carp::croak "Extra lines not allowed in '$type' section"
80             if $value =~ /\S/;
81 34         170 ($filters, $value) = split /\s*:(?:\s+|\z)/, $filters, 2;
82 34 50       127 $value = '' unless defined $value;
83 34         209 $value =~ s/^\s*(.*?)\s*$/$1/;
84             }
85 63         230 $block->push_section($type, $value, $filters);
86             }
87 41         149 return $block;
88             }
89              
90             my $reserved_section_names = {};
91             {
92             %$reserved_section_names = map {
93             ($_, 1);
94             } keys(%Text::TestBase::Block::), qw( new DESTROY );
95             }
96             sub _check_reserved {
97 63     63   91 my $id = shift;
98             Carp::croak "'$id' is a reserved name. Use something else.\n"
99 63 50 33     679 if $reserved_section_names->{$id} or
      33        
100             $id =~ /^_/ or $id =~ /^(get_|set_|push_)/;
101             }
102              
103              
104             1;
105             __END__