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__ |