line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Test::Base; |
2
|
|
|
|
|
|
|
our $VERSION = '0.84'; |
3
|
|
|
|
|
|
|
|
4
|
1
|
|
|
1
|
|
3555
|
use Spiffy -Base; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
6
|
|
5
|
1
|
|
|
1
|
|
13
|
use Spiffy ':XXX'; |
|
1
|
|
|
1
|
|
3
|
|
|
1
|
|
|
1
|
|
41
|
|
|
1
|
|
|
|
|
6
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
36
|
|
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
6
|
|
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
my $HAS_PROVIDER; |
8
|
|
|
|
|
|
|
BEGIN { |
9
|
1
|
|
|
1
|
|
69
|
$HAS_PROVIDER = eval "require Test::Builder::Provider; 1"; |
10
|
|
|
|
|
|
|
|
11
|
1
|
50
|
|
|
|
7
|
if ($HAS_PROVIDER) { |
12
|
0
|
|
|
|
|
0
|
Test::Builder::Provider->import('provides'); |
13
|
|
|
|
|
|
|
} |
14
|
|
|
|
|
|
|
else { |
15
|
1
|
|
|
1
|
|
53
|
*provides = sub { 1 }; |
|
1
|
|
|
|
|
2
|
|
16
|
|
|
|
|
|
|
} |
17
|
|
|
|
|
|
|
} |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
my @test_more_exports; |
21
|
|
|
|
|
|
|
BEGIN { |
22
|
1
|
|
|
1
|
|
28
|
@test_more_exports = qw( |
23
|
|
|
|
|
|
|
ok isnt like unlike is_deeply cmp_ok |
24
|
|
|
|
|
|
|
skip todo_skip pass fail |
25
|
|
|
|
|
|
|
eq_array eq_hash eq_set |
26
|
|
|
|
|
|
|
plan can_ok isa_ok diag |
27
|
|
|
|
|
|
|
use_ok |
28
|
|
|
|
|
|
|
$TODO |
29
|
|
|
|
|
|
|
); |
30
|
|
|
|
|
|
|
} |
31
|
|
|
|
|
|
|
|
32
|
1
|
|
|
1
|
|
1987
|
use Test::More import => \@test_more_exports; |
|
1
|
|
|
|
|
37763
|
|
|
1
|
|
|
|
|
15
|
|
33
|
1
|
|
|
1
|
|
863
|
use Carp; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
839
|
|
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
our @EXPORT = (@test_more_exports, qw( |
36
|
|
|
|
|
|
|
is no_diff |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
blocks next_block first_block |
39
|
|
|
|
|
|
|
delimiters spec_file spec_string |
40
|
|
|
|
|
|
|
filters filters_delay filter_arguments |
41
|
|
|
|
|
|
|
run run_compare run_is run_is_deeply run_like run_unlike |
42
|
|
|
|
|
|
|
skip_all_unless_require is_deep run_is_deep |
43
|
|
|
|
|
|
|
WWW XXX YYY ZZZ |
44
|
|
|
|
|
|
|
tie_output no_diag_on_only |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
find_my_self default_object |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
croak carp cluck confess |
49
|
|
|
|
|
|
|
)); |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
field '_spec_file'; |
52
|
|
|
|
|
|
|
field '_spec_string'; |
53
|
|
|
|
|
|
|
field _filters => [qw(norm trim)]; |
54
|
|
|
|
|
|
|
field _filters_map => {}; |
55
|
|
|
|
|
|
|
field spec => |
56
|
|
|
|
|
|
|
-init => '$self->_spec_init'; |
57
|
|
|
|
|
|
|
field block_list => |
58
|
|
|
|
|
|
|
-init => '$self->_block_list_init'; |
59
|
|
|
|
|
|
|
field _next_list => []; |
60
|
|
|
|
|
|
|
field block_delim => |
61
|
|
|
|
|
|
|
-init => '$self->block_delim_default'; |
62
|
|
|
|
|
|
|
field data_delim => |
63
|
|
|
|
|
|
|
-init => '$self->data_delim_default'; |
64
|
|
|
|
|
|
|
field _filters_delay => 0; |
65
|
|
|
|
|
|
|
field _no_diag_on_only => 0; |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
field block_delim_default => '==='; |
68
|
|
|
|
|
|
|
field data_delim_default => '---'; |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
my $default_class; |
71
|
|
|
|
|
|
|
my $default_object; |
72
|
|
|
|
|
|
|
my $reserved_section_names = {}; |
73
|
|
|
|
|
|
|
|
74
|
6
|
|
|
6
|
0
|
12
|
sub default_object { |
75
|
6
|
|
66
|
|
|
42
|
$default_object ||= $default_class->new; |
76
|
6
|
|
|
|
|
12
|
return $default_object; |
77
|
|
|
|
|
|
|
} |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
my $import_called = 0; |
80
|
|
|
|
|
|
|
sub import() { |
81
|
2
|
|
|
2
|
|
225
|
$import_called = 1; |
82
|
2
|
100
|
|
|
|
19
|
my $class = (grep /^-base$/i, @_) |
83
|
|
|
|
|
|
|
? scalar(caller) |
84
|
|
|
|
|
|
|
: $_[0]; |
85
|
2
|
100
|
|
|
|
10
|
if (not defined $default_class) { |
86
|
1
|
|
|
|
|
2
|
$default_class = $class; |
87
|
|
|
|
|
|
|
} |
88
|
|
|
|
|
|
|
# else { |
89
|
|
|
|
|
|
|
# croak "Can't use $class after using $default_class" |
90
|
|
|
|
|
|
|
# unless $default_class->isa($class); |
91
|
|
|
|
|
|
|
# } |
92
|
|
|
|
|
|
|
|
93
|
2
|
100
|
|
|
|
13
|
unless (grep /^-base$/i, @_) { |
94
|
1
|
|
|
|
|
3
|
my @args; |
95
|
1
|
|
|
|
|
6
|
for (my $ii = 1; $ii <= $#_; ++$ii) { |
96
|
2
|
50
|
|
|
|
7
|
if ($_[$ii] eq '-package') { |
97
|
0
|
|
|
|
|
0
|
++$ii; |
98
|
|
|
|
|
|
|
} else { |
99
|
2
|
|
|
|
|
8
|
push @args, $_[$ii]; |
100
|
|
|
|
|
|
|
} |
101
|
|
|
|
|
|
|
} |
102
|
1
|
50
|
|
|
|
17
|
Test::More->import(import => \@test_more_exports, @args) |
103
|
|
|
|
|
|
|
if @args; |
104
|
|
|
|
|
|
|
} |
105
|
|
|
|
|
|
|
|
106
|
2
|
|
|
|
|
544
|
_strict_warnings(); |
107
|
2
|
|
|
|
|
46
|
goto &Spiffy::import; |
108
|
|
|
|
|
|
|
} |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
# Wrap Test::Builder::plan |
111
|
|
|
|
|
|
|
my $plan_code = \&Test::Builder::plan; |
112
|
|
|
|
|
|
|
my $Have_Plan = 0; |
113
|
|
|
|
|
|
|
{ |
114
|
1
|
|
|
1
|
|
691
|
no warnings 'redefine'; |
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
6600
|
|
115
|
|
|
|
|
|
|
*Test::Builder::plan = sub { |
116
|
1
|
|
|
1
|
|
318
|
$Have_Plan = 1; |
117
|
1
|
|
|
|
|
5
|
goto &$plan_code; |
118
|
|
|
|
|
|
|
}; |
119
|
|
|
|
|
|
|
} |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
my $DIED = 0; |
122
|
|
|
|
|
|
|
$SIG{__DIE__} = sub { $DIED = 1; die @_ }; |
123
|
|
|
|
|
|
|
|
124
|
4
|
|
|
4
|
0
|
6
|
sub block_class { $self->find_class('Block') } |
|
4
|
|
|
|
|
13
|
|
125
|
32
|
|
|
32
|
0
|
46
|
sub filter_class { $self->find_class('Filter') } |
|
32
|
|
|
|
|
60
|
|
126
|
|
|
|
|
|
|
|
127
|
36
|
|
|
36
|
0
|
45
|
sub find_class { |
128
|
36
|
|
|
|
|
36
|
my $suffix = shift; |
129
|
36
|
|
|
|
|
162
|
my $class = ref($self) . "::$suffix"; |
130
|
36
|
100
|
|
|
|
123
|
return $class if $class->can('new'); |
131
|
4
|
|
|
|
|
6
|
$class = __PACKAGE__ . "::$suffix"; |
132
|
4
|
50
|
|
|
|
21
|
return $class if $class->can('new'); |
133
|
0
|
|
|
|
|
0
|
eval "require $class"; |
134
|
0
|
0
|
|
|
|
0
|
return $class if $class->can('new'); |
135
|
0
|
|
|
|
|
0
|
die "Can't find a class for $suffix"; |
136
|
|
|
|
|
|
|
} |
137
|
|
|
|
|
|
|
|
138
|
0
|
|
|
0
|
0
|
0
|
sub check_late { |
139
|
0
|
0
|
|
|
|
0
|
if ($self->{block_list}) { |
140
|
0
|
|
|
|
|
0
|
my $caller = (caller(1))[3]; |
141
|
0
|
|
|
|
|
0
|
$caller =~ s/.*:://; |
142
|
0
|
|
|
|
|
0
|
croak "Too late to call $caller()" |
143
|
|
|
|
|
|
|
} |
144
|
|
|
|
|
|
|
} |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
sub find_my_self() { |
147
|
6
|
50
|
|
6
|
0
|
30
|
my $self = ref($_[0]) eq $default_class |
148
|
|
|
|
|
|
|
? splice(@_, 0, 1) |
149
|
|
|
|
|
|
|
: default_object(); |
150
|
6
|
|
|
|
|
27
|
return $self, @_; |
151
|
|
|
|
|
|
|
} |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
sub blocks() { |
154
|
0
|
|
|
0
|
0
|
0
|
(my ($self), @_) = find_my_self(@_); |
155
|
|
|
|
|
|
|
|
156
|
0
|
0
|
|
|
|
0
|
croak "Invalid arguments passed to 'blocks'" |
157
|
|
|
|
|
|
|
if @_ > 1; |
158
|
0
|
0
|
0
|
|
|
0
|
croak sprintf("'%s' is invalid argument to blocks()", shift(@_)) |
159
|
|
|
|
|
|
|
if @_ && $_[0] !~ /^[a-zA-Z]\w*$/; |
160
|
|
|
|
|
|
|
|
161
|
0
|
|
|
|
|
0
|
my $blocks = $self->block_list; |
162
|
|
|
|
|
|
|
|
163
|
0
|
|
0
|
|
|
0
|
my $section_name = shift || ''; |
164
|
0
|
|
|
|
|
0
|
my @blocks = $section_name |
165
|
0
|
0
|
|
|
|
0
|
? (grep { exists $_->{$section_name} } @$blocks) |
166
|
|
|
|
|
|
|
: (@$blocks); |
167
|
|
|
|
|
|
|
|
168
|
0
|
0
|
|
|
|
0
|
return scalar(@blocks) unless wantarray; |
169
|
|
|
|
|
|
|
|
170
|
0
|
0
|
|
|
|
0
|
return (@blocks) if $self->_filters_delay; |
171
|
|
|
|
|
|
|
|
172
|
0
|
|
|
|
|
0
|
for my $block (@blocks) { |
173
|
0
|
0
|
|
|
|
0
|
$block->run_filters |
174
|
|
|
|
|
|
|
unless $block->is_filtered; |
175
|
|
|
|
|
|
|
} |
176
|
|
|
|
|
|
|
|
177
|
0
|
|
|
|
|
0
|
return (@blocks); |
178
|
|
|
|
|
|
|
} |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
sub next_block() { |
181
|
0
|
|
|
0
|
0
|
0
|
(my ($self), @_) = find_my_self(@_); |
182
|
0
|
|
|
|
|
0
|
my $list = $self->_next_list; |
183
|
0
|
0
|
|
|
|
0
|
if (@$list == 0) { |
184
|
0
|
|
|
|
|
0
|
$list = [@{$self->block_list}, undef]; |
|
0
|
|
|
|
|
0
|
|
185
|
0
|
|
|
|
|
0
|
$self->_next_list($list); |
186
|
|
|
|
|
|
|
} |
187
|
0
|
|
|
|
|
0
|
my $block = shift @$list; |
188
|
0
|
0
|
0
|
|
|
0
|
if (defined $block and not $block->is_filtered) { |
189
|
0
|
|
|
|
|
0
|
$block->run_filters; |
190
|
|
|
|
|
|
|
} |
191
|
0
|
|
|
|
|
0
|
return $block; |
192
|
|
|
|
|
|
|
} |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
sub first_block() { |
195
|
0
|
|
|
0
|
0
|
0
|
(my ($self), @_) = find_my_self(@_); |
196
|
0
|
|
|
|
|
0
|
$self->_next_list([]); |
197
|
0
|
|
|
|
|
0
|
$self->next_block; |
198
|
|
|
|
|
|
|
} |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
sub filters_delay() { |
201
|
0
|
|
|
0
|
0
|
0
|
(my ($self), @_) = find_my_self(@_); |
202
|
0
|
0
|
|
|
|
0
|
$self->_filters_delay(defined $_[0] ? shift : 1); |
203
|
|
|
|
|
|
|
} |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
sub no_diag_on_only() { |
206
|
0
|
|
|
0
|
0
|
0
|
(my ($self), @_) = find_my_self(@_); |
207
|
0
|
0
|
|
|
|
0
|
$self->_no_diag_on_only(defined $_[0] ? shift : 1); |
208
|
|
|
|
|
|
|
} |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
sub delimiters() { |
211
|
0
|
|
|
0
|
0
|
0
|
(my ($self), @_) = find_my_self(@_); |
212
|
0
|
|
|
|
|
0
|
$self->check_late; |
213
|
0
|
|
|
|
|
0
|
my ($block_delimiter, $data_delimiter) = @_; |
214
|
0
|
|
0
|
|
|
0
|
$block_delimiter ||= $self->block_delim_default; |
215
|
0
|
|
0
|
|
|
0
|
$data_delimiter ||= $self->data_delim_default; |
216
|
0
|
|
|
|
|
0
|
$self->block_delim($block_delimiter); |
217
|
0
|
|
|
|
|
0
|
$self->data_delim($data_delimiter); |
218
|
0
|
|
|
|
|
0
|
return $self; |
219
|
|
|
|
|
|
|
} |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
sub spec_file() { |
222
|
0
|
|
|
0
|
0
|
0
|
(my ($self), @_) = find_my_self(@_); |
223
|
0
|
|
|
|
|
0
|
$self->check_late; |
224
|
0
|
|
|
|
|
0
|
$self->_spec_file(shift); |
225
|
0
|
|
|
|
|
0
|
return $self; |
226
|
|
|
|
|
|
|
} |
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
sub spec_string() { |
229
|
0
|
|
|
0
|
0
|
0
|
(my ($self), @_) = find_my_self(@_); |
230
|
0
|
|
|
|
|
0
|
$self->check_late; |
231
|
0
|
|
|
|
|
0
|
$self->_spec_string(shift); |
232
|
0
|
|
|
|
|
0
|
return $self; |
233
|
|
|
|
|
|
|
} |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
sub filters() { |
236
|
1
|
|
|
1
|
0
|
19
|
(my ($self), @_) = find_my_self(@_); |
237
|
1
|
50
|
|
|
|
7
|
if (ref($_[0]) eq 'HASH') { |
238
|
1
|
|
|
|
|
47
|
$self->_filters_map(shift); |
239
|
|
|
|
|
|
|
} |
240
|
|
|
|
|
|
|
else { |
241
|
0
|
|
|
|
|
0
|
my $filters = $self->_filters; |
242
|
0
|
|
|
|
|
0
|
push @$filters, @_; |
243
|
|
|
|
|
|
|
} |
244
|
1
|
|
|
|
|
4
|
return $self; |
245
|
|
|
|
|
|
|
} |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
sub filter_arguments() { |
248
|
0
|
|
|
0
|
0
|
0
|
$Test::Base::Filter::arguments; |
249
|
|
|
|
|
|
|
} |
250
|
|
|
|
|
|
|
|
251
|
0
|
|
|
0
|
0
|
0
|
sub have_text_diff { |
252
|
0
|
0
|
0
|
|
|
0
|
eval { require Text::Diff; 1 } && |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
253
|
|
|
|
|
|
|
$Text::Diff::VERSION >= 0.35 && |
254
|
|
|
|
|
|
|
$Algorithm::Diff::VERSION >= 1.15; |
255
|
|
|
|
|
|
|
} |
256
|
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
provides 'is'; |
258
|
|
|
|
|
|
|
sub is($$;$) { |
259
|
4
|
|
|
4
|
0
|
13
|
(my ($self), @_) = find_my_self(@_); |
260
|
4
|
|
|
|
|
9
|
my ($actual, $expected, $name) = @_; |
261
|
4
|
50
|
|
|
|
13
|
local $Test::Builder::Level = $Test::Builder::Level + 1 unless $HAS_PROVIDER; |
262
|
4
|
50
|
33
|
|
|
66
|
if ($ENV{TEST_SHOW_NO_DIFFS} or |
|
|
|
33
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
|
33
|
|
|
|
|
263
|
|
|
|
|
|
|
not defined $actual or |
264
|
|
|
|
|
|
|
not defined $expected or |
265
|
|
|
|
|
|
|
$actual eq $expected or |
266
|
|
|
|
|
|
|
not($self->have_text_diff) or |
267
|
|
|
|
|
|
|
$expected !~ /\n./s |
268
|
|
|
|
|
|
|
) { |
269
|
4
|
|
|
|
|
15
|
Test::More::is($actual, $expected, $name); |
270
|
|
|
|
|
|
|
} |
271
|
|
|
|
|
|
|
else { |
272
|
0
|
0
|
|
|
|
0
|
$name = '' unless defined $name; |
273
|
0
|
|
|
|
|
0
|
ok $actual eq $expected, $name; |
274
|
0
|
|
|
|
|
0
|
diag Text::Diff::diff(\$expected, \$actual); |
275
|
|
|
|
|
|
|
} |
276
|
|
|
|
|
|
|
} |
277
|
|
|
|
|
|
|
|
278
|
|
|
|
|
|
|
sub run(&;$) { |
279
|
0
|
|
|
0
|
0
|
0
|
(my ($self), @_) = find_my_self(@_); |
280
|
0
|
|
|
|
|
0
|
my $callback = shift; |
281
|
0
|
|
|
|
|
0
|
for my $block (@{$self->block_list}) { |
|
0
|
|
|
|
|
0
|
|
282
|
0
|
0
|
|
|
|
0
|
$block->run_filters unless $block->is_filtered; |
283
|
0
|
|
|
|
|
0
|
&{$callback}($block); |
|
0
|
|
|
|
|
0
|
|
284
|
|
|
|
|
|
|
} |
285
|
|
|
|
|
|
|
} |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
my $name_error = "Can't determine section names"; |
288
|
1
|
|
|
1
|
|
2
|
sub _section_names { |
289
|
1
|
50
|
|
|
|
7
|
return @_ if @_ == 2; |
290
|
0
|
0
|
|
|
|
0
|
my $block = $self->first_block |
291
|
|
|
|
|
|
|
or croak $name_error; |
292
|
0
|
|
|
|
|
0
|
my @names = grep { |
293
|
0
|
0
|
|
|
|
0
|
$_ !~ /^(ONLY|LAST|SKIP)$/; |
294
|
0
|
|
|
|
|
0
|
} @{$block->{_section_order}[0] || []}; |
295
|
0
|
0
|
|
|
|
0
|
croak "$name_error. Need two sections in first block" |
296
|
|
|
|
|
|
|
unless @names == 2; |
297
|
0
|
|
|
|
|
0
|
return @names; |
298
|
|
|
|
|
|
|
} |
299
|
|
|
|
|
|
|
|
300
|
1
|
|
|
1
|
|
3
|
sub _assert_plan { |
301
|
1
|
50
|
|
|
|
4
|
plan('no_plan') unless $Have_Plan; |
302
|
|
|
|
|
|
|
} |
303
|
|
|
|
|
|
|
|
304
|
1
|
|
|
1
|
|
475
|
sub END { |
305
|
1
|
0
|
33
|
|
|
10
|
run_compare() unless $Have_Plan or $DIED or not $import_called; |
|
|
|
33
|
|
|
|
|
306
|
|
|
|
|
|
|
} |
307
|
|
|
|
|
|
|
|
308
|
|
|
|
|
|
|
sub run_compare() { |
309
|
0
|
|
|
0
|
0
|
0
|
(my ($self), @_) = find_my_self(@_); |
310
|
0
|
|
|
|
|
0
|
$self->_assert_plan; |
311
|
0
|
|
|
|
|
0
|
my ($x, $y) = $self->_section_names(@_); |
312
|
0
|
|
|
|
|
0
|
local $Test::Builder::Level = $Test::Builder::Level + 1; |
313
|
0
|
|
|
|
|
0
|
for my $block (@{$self->block_list}) { |
|
0
|
|
|
|
|
0
|
|
314
|
0
|
0
|
0
|
|
|
0
|
next unless exists($block->{$x}) and exists($block->{$y}); |
315
|
0
|
0
|
|
|
|
0
|
$block->run_filters unless $block->is_filtered; |
316
|
0
|
0
|
|
|
|
0
|
if (ref $block->$x) { |
|
|
0
|
|
|
|
|
|
317
|
0
|
0
|
|
|
|
0
|
is_deeply($block->$x, $block->$y, |
318
|
|
|
|
|
|
|
$block->name ? $block->name : ()); |
319
|
|
|
|
|
|
|
} |
320
|
|
|
|
|
|
|
elsif (ref $block->$y eq 'Regexp') { |
321
|
0
|
0
|
|
|
|
0
|
my $regexp = ref $y ? $y : $block->$y; |
322
|
0
|
0
|
|
|
|
0
|
like($block->$x, $regexp, $block->name ? $block->name : ()); |
323
|
|
|
|
|
|
|
} |
324
|
|
|
|
|
|
|
else { |
325
|
0
|
0
|
|
|
|
0
|
is($block->$x, $block->$y, $block->name ? $block->name : ()); |
326
|
|
|
|
|
|
|
} |
327
|
|
|
|
|
|
|
} |
328
|
|
|
|
|
|
|
} |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
sub run_is() { |
331
|
1
|
|
|
1
|
0
|
8
|
(my ($self), @_) = find_my_self(@_); |
332
|
1
|
|
|
|
|
10
|
$self->_assert_plan; |
333
|
1
|
|
|
|
|
8
|
my ($x, $y) = $self->_section_names(@_); |
334
|
1
|
|
|
|
|
4
|
local $Test::Builder::Level = $Test::Builder::Level + 1; |
335
|
1
|
|
|
|
|
2
|
for my $block (@{$self->block_list}) { |
|
1
|
|
|
|
|
28
|
|
336
|
4
|
50
|
33
|
|
|
1295
|
next unless exists($block->{$x}) and exists($block->{$y}); |
337
|
4
|
50
|
|
|
|
72
|
$block->run_filters unless $block->is_filtered; |
338
|
4
|
50
|
|
|
|
15
|
is($block->$x, $block->$y, |
339
|
|
|
|
|
|
|
$block->name ? $block->name : () |
340
|
|
|
|
|
|
|
); |
341
|
|
|
|
|
|
|
} |
342
|
|
|
|
|
|
|
} |
343
|
|
|
|
|
|
|
|
344
|
|
|
|
|
|
|
sub run_is_deeply() { |
345
|
0
|
|
|
0
|
0
|
0
|
(my ($self), @_) = find_my_self(@_); |
346
|
0
|
|
|
|
|
0
|
$self->_assert_plan; |
347
|
0
|
|
|
|
|
0
|
my ($x, $y) = $self->_section_names(@_); |
348
|
0
|
|
|
|
|
0
|
for my $block (@{$self->block_list}) { |
|
0
|
|
|
|
|
0
|
|
349
|
0
|
0
|
0
|
|
|
0
|
next unless exists($block->{$x}) and exists($block->{$y}); |
350
|
0
|
0
|
|
|
|
0
|
$block->run_filters unless $block->is_filtered; |
351
|
0
|
0
|
|
|
|
0
|
is_deeply($block->$x, $block->$y, |
352
|
|
|
|
|
|
|
$block->name ? $block->name : () |
353
|
|
|
|
|
|
|
); |
354
|
|
|
|
|
|
|
} |
355
|
|
|
|
|
|
|
} |
356
|
|
|
|
|
|
|
|
357
|
|
|
|
|
|
|
sub run_like() { |
358
|
0
|
|
|
0
|
0
|
0
|
(my ($self), @_) = find_my_self(@_); |
359
|
0
|
|
|
|
|
0
|
$self->_assert_plan; |
360
|
0
|
|
|
|
|
0
|
my ($x, $y) = $self->_section_names(@_); |
361
|
0
|
|
|
|
|
0
|
for my $block (@{$self->block_list}) { |
|
0
|
|
|
|
|
0
|
|
362
|
0
|
0
|
0
|
|
|
0
|
next unless exists($block->{$x}) and defined($y); |
363
|
0
|
0
|
|
|
|
0
|
$block->run_filters unless $block->is_filtered; |
364
|
0
|
0
|
|
|
|
0
|
my $regexp = ref $y ? $y : $block->$y; |
365
|
0
|
0
|
|
|
|
0
|
like($block->$x, $regexp, |
366
|
|
|
|
|
|
|
$block->name ? $block->name : () |
367
|
|
|
|
|
|
|
); |
368
|
|
|
|
|
|
|
} |
369
|
|
|
|
|
|
|
} |
370
|
|
|
|
|
|
|
|
371
|
|
|
|
|
|
|
sub run_unlike() { |
372
|
0
|
|
|
0
|
0
|
0
|
(my ($self), @_) = find_my_self(@_); |
373
|
0
|
|
|
|
|
0
|
$self->_assert_plan; |
374
|
0
|
|
|
|
|
0
|
my ($x, $y) = $self->_section_names(@_); |
375
|
0
|
|
|
|
|
0
|
for my $block (@{$self->block_list}) { |
|
0
|
|
|
|
|
0
|
|
376
|
0
|
0
|
0
|
|
|
0
|
next unless exists($block->{$x}) and defined($y); |
377
|
0
|
0
|
|
|
|
0
|
$block->run_filters unless $block->is_filtered; |
378
|
0
|
0
|
|
|
|
0
|
my $regexp = ref $y ? $y : $block->$y; |
379
|
0
|
0
|
|
|
|
0
|
unlike($block->$x, $regexp, |
380
|
|
|
|
|
|
|
$block->name ? $block->name : () |
381
|
|
|
|
|
|
|
); |
382
|
|
|
|
|
|
|
} |
383
|
|
|
|
|
|
|
} |
384
|
|
|
|
|
|
|
|
385
|
|
|
|
|
|
|
sub skip_all_unless_require() { |
386
|
0
|
|
|
0
|
0
|
0
|
(my ($self), @_) = find_my_self(@_); |
387
|
0
|
|
|
|
|
0
|
my $module = shift; |
388
|
0
|
0
|
|
|
|
0
|
eval "require $module; 1" |
389
|
|
|
|
|
|
|
or Test::More::plan( |
390
|
|
|
|
|
|
|
skip_all => "$module failed to load" |
391
|
|
|
|
|
|
|
); |
392
|
|
|
|
|
|
|
} |
393
|
|
|
|
|
|
|
|
394
|
|
|
|
|
|
|
sub is_deep() { |
395
|
0
|
|
|
0
|
0
|
0
|
(my ($self), @_) = find_my_self(@_); |
396
|
0
|
|
|
|
|
0
|
require Test::Deep; |
397
|
0
|
|
|
|
|
0
|
Test::Deep::cmp_deeply(@_); |
398
|
|
|
|
|
|
|
} |
399
|
|
|
|
|
|
|
|
400
|
|
|
|
|
|
|
sub run_is_deep() { |
401
|
0
|
|
|
0
|
0
|
0
|
(my ($self), @_) = find_my_self(@_); |
402
|
0
|
|
|
|
|
0
|
$self->_assert_plan; |
403
|
0
|
|
|
|
|
0
|
my ($x, $y) = $self->_section_names(@_); |
404
|
0
|
|
|
|
|
0
|
for my $block (@{$self->block_list}) { |
|
0
|
|
|
|
|
0
|
|
405
|
0
|
0
|
0
|
|
|
0
|
next unless exists($block->{$x}) and exists($block->{$y}); |
406
|
0
|
0
|
|
|
|
0
|
$block->run_filters unless $block->is_filtered; |
407
|
0
|
0
|
|
|
|
0
|
is_deep($block->$x, $block->$y, |
408
|
|
|
|
|
|
|
$block->name ? $block->name : () |
409
|
|
|
|
|
|
|
); |
410
|
|
|
|
|
|
|
} |
411
|
|
|
|
|
|
|
} |
412
|
|
|
|
|
|
|
|
413
|
1
|
|
|
1
|
|
3
|
sub _pre_eval { |
414
|
1
|
|
|
|
|
4
|
my $spec = shift; |
415
|
1
|
50
|
|
|
|
8
|
return $spec unless $spec =~ |
416
|
|
|
|
|
|
|
s/\A\s*<<<(.*?)>>>\s*$//sm; |
417
|
0
|
|
|
|
|
0
|
my $eval_code = $1; |
418
|
0
|
|
|
|
|
0
|
eval "package main; $eval_code"; |
419
|
0
|
0
|
|
|
|
0
|
croak $@ if $@; |
420
|
0
|
|
|
|
|
0
|
return $spec; |
421
|
|
|
|
|
|
|
} |
422
|
|
|
|
|
|
|
|
423
|
1
|
|
|
1
|
|
4
|
sub _block_list_init { |
424
|
1
|
|
|
|
|
27
|
my $spec = $self->spec; |
425
|
1
|
|
|
|
|
10
|
$spec = $self->_pre_eval($spec); |
426
|
1
|
|
|
|
|
28
|
my $cd = $self->block_delim; |
427
|
1
|
|
|
|
|
110
|
my @hunks = ($spec =~ /^(\Q${cd}\E.*?(?=^\Q${cd}\E|\z))/msg); |
428
|
1
|
|
|
|
|
10
|
my $blocks = $self->_choose_blocks(@hunks); |
429
|
1
|
|
|
|
|
16
|
$self->block_list($blocks); # Need to set early for possible filter use |
430
|
1
|
|
|
|
|
1
|
my $seq = 1; |
431
|
1
|
|
|
|
|
3
|
for my $block (@$blocks) { |
432
|
4
|
|
|
|
|
49
|
$block->blocks_object($self); |
433
|
4
|
|
|
|
|
58
|
$block->seq_num($seq++); |
434
|
|
|
|
|
|
|
} |
435
|
1
|
|
|
|
|
8
|
return $blocks; |
436
|
|
|
|
|
|
|
} |
437
|
|
|
|
|
|
|
|
438
|
1
|
|
|
1
|
|
2
|
sub _choose_blocks { |
439
|
1
|
|
|
|
|
3
|
my $blocks = []; |
440
|
1
|
|
|
|
|
5
|
for my $hunk (@_) { |
441
|
4
|
|
|
|
|
14
|
my $block = $self->_make_block($hunk); |
442
|
4
|
50
|
|
|
|
12
|
if (exists $block->{ONLY}) { |
443
|
0
|
0
|
|
|
|
0
|
diag "I found ONLY: maybe you're debugging?" |
444
|
|
|
|
|
|
|
unless $self->_no_diag_on_only; |
445
|
0
|
|
|
|
|
0
|
return [$block]; |
446
|
|
|
|
|
|
|
} |
447
|
4
|
50
|
|
|
|
17
|
next if exists $block->{SKIP}; |
448
|
4
|
|
|
|
|
6
|
push @$blocks, $block; |
449
|
4
|
50
|
|
|
|
11
|
if (exists $block->{LAST}) { |
450
|
0
|
|
|
|
|
0
|
return $blocks; |
451
|
|
|
|
|
|
|
} |
452
|
|
|
|
|
|
|
} |
453
|
1
|
|
|
|
|
3
|
return $blocks; |
454
|
|
|
|
|
|
|
} |
455
|
|
|
|
|
|
|
|
456
|
8
|
|
|
8
|
|
9
|
sub _check_reserved { |
457
|
8
|
|
|
|
|
9
|
my $id = shift; |
458
|
8
|
50
|
33
|
|
|
42
|
croak "'$id' is a reserved name. Use something else.\n" |
459
|
|
|
|
|
|
|
if $reserved_section_names->{$id} or |
460
|
|
|
|
|
|
|
$id =~ /^_/; |
461
|
|
|
|
|
|
|
} |
462
|
|
|
|
|
|
|
|
463
|
4
|
|
|
4
|
|
4
|
sub _make_block { |
464
|
4
|
|
|
|
|
7
|
my $hunk = shift; |
465
|
4
|
|
|
|
|
75
|
my $cd = $self->block_delim; |
466
|
4
|
|
|
|
|
76
|
my $dd = $self->data_delim; |
467
|
4
|
|
|
|
|
17
|
my $block = $self->block_class->new; |
468
|
4
|
50
|
|
|
|
60
|
$hunk =~ s/\A\Q${cd}\E[ \t]*(.*)\s+// or die; |
469
|
4
|
|
|
|
|
9
|
my $name = $1; |
470
|
4
|
|
|
|
|
66
|
my @parts = split /^\Q${dd}\E +\(?(\w+)\)? *(.*)?\n/m, $hunk; |
471
|
4
|
|
|
|
|
8
|
my $description = shift @parts; |
472
|
4
|
|
50
|
|
|
15
|
$description ||= ''; |
473
|
4
|
50
|
|
|
|
19
|
unless ($description =~ /\S/) { |
474
|
4
|
|
|
|
|
5
|
$description = $name; |
475
|
|
|
|
|
|
|
} |
476
|
4
|
|
|
|
|
18
|
$description =~ s/\s*\z//; |
477
|
4
|
|
|
|
|
14
|
$block->set_value(description => $description); |
478
|
|
|
|
|
|
|
|
479
|
4
|
|
|
|
|
8
|
my $section_map = {}; |
480
|
4
|
|
|
|
|
14
|
my $section_order = []; |
481
|
4
|
|
|
|
|
23
|
while (@parts) { |
482
|
8
|
|
|
|
|
19
|
my ($type, $filters, $value) = splice(@parts, 0, 3); |
483
|
8
|
|
|
|
|
23
|
$self->_check_reserved($type); |
484
|
8
|
50
|
|
|
|
17
|
$value = '' unless defined $value; |
485
|
8
|
50
|
|
|
|
12
|
$filters = '' unless defined $filters; |
486
|
8
|
100
|
|
|
|
25
|
if ($filters =~ /:(\s|\z)/) { |
487
|
4
|
50
|
|
|
|
8
|
croak "Extra lines not allowed in '$type' section" |
488
|
|
|
|
|
|
|
if $value =~ /\S/; |
489
|
4
|
|
|
|
|
21
|
($filters, $value) = split /\s*:(?:\s+|\z)/, $filters, 2; |
490
|
4
|
50
|
|
|
|
10
|
$value = '' unless defined $value; |
491
|
4
|
|
|
|
|
25
|
$value =~ s/^\s*(.*?)\s*$/$1/; |
492
|
|
|
|
|
|
|
} |
493
|
8
|
|
|
|
|
25
|
$section_map->{$type} = { |
494
|
|
|
|
|
|
|
filters => $filters, |
495
|
|
|
|
|
|
|
}; |
496
|
8
|
|
|
|
|
12
|
push @$section_order, $type; |
497
|
8
|
|
|
|
|
16
|
$block->set_value($type, $value); |
498
|
|
|
|
|
|
|
} |
499
|
4
|
|
|
|
|
9
|
$block->set_value(name => $name); |
500
|
4
|
|
|
|
|
27
|
$block->set_value(_section_map => $section_map); |
501
|
4
|
|
|
|
|
7
|
$block->set_value(_section_order => $section_order); |
502
|
4
|
|
|
|
|
11
|
return $block; |
503
|
|
|
|
|
|
|
} |
504
|
|
|
|
|
|
|
|
505
|
1
|
|
|
1
|
|
3
|
sub _spec_init { |
506
|
1
|
50
|
|
|
|
34
|
return $self->_spec_string |
507
|
|
|
|
|
|
|
if $self->_spec_string; |
508
|
1
|
|
|
|
|
6
|
local $/; |
509
|
1
|
|
|
|
|
2
|
my $spec; |
510
|
1
|
50
|
|
|
|
26
|
if (my $spec_file = $self->_spec_file) { |
511
|
0
|
|
|
|
|
0
|
warn "$spec_file"; |
512
|
0
|
0
|
|
|
|
0
|
open FILE, $spec_file or die $!; |
513
|
0
|
|
|
|
|
0
|
$spec = ; |
514
|
0
|
|
|
|
|
0
|
close FILE; |
515
|
|
|
|
|
|
|
} |
516
|
|
|
|
|
|
|
else { |
517
|
1
|
|
|
|
|
3
|
$spec = do { |
518
|
|
|
|
|
|
|
package main; |
519
|
1
|
|
|
1
|
|
12
|
no warnings 'once'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
514
|
|
520
|
1
|
|
|
|
|
34
|
; |
521
|
|
|
|
|
|
|
}; |
522
|
|
|
|
|
|
|
} |
523
|
1
|
|
|
|
|
10
|
return $spec; |
524
|
|
|
|
|
|
|
} |
525
|
|
|
|
|
|
|
|
526
|
|
|
|
|
|
|
sub _strict_warnings() { |
527
|
2
|
|
|
2
|
|
15
|
require Filter::Util::Call; |
528
|
2
|
|
|
|
|
4
|
my $done = 0; |
529
|
|
|
|
|
|
|
Filter::Util::Call::filter_add( |
530
|
|
|
|
|
|
|
sub { |
531
|
3
|
100
|
|
3
|
|
25
|
return 0 if $done; |
532
|
2
|
|
|
|
|
7
|
my ($data, $end) = ('', ''); |
533
|
2
|
|
|
|
|
24
|
while (my $status = Filter::Util::Call::filter_read()) { |
534
|
29
|
50
|
|
|
|
58
|
return $status if $status < 0; |
535
|
29
|
100
|
|
|
|
68
|
if (/^__(?:END|DATA)__\r?$/) { |
536
|
1
|
|
|
|
|
3
|
$end = $_; |
537
|
1
|
|
|
|
|
3
|
last; |
538
|
|
|
|
|
|
|
} |
539
|
28
|
|
|
|
|
42
|
$data .= $_; |
540
|
28
|
|
|
|
|
109
|
$_ = ''; |
541
|
|
|
|
|
|
|
} |
542
|
2
|
|
|
|
|
7
|
$_ = "use strict;use warnings;$data$end"; |
543
|
2
|
|
|
|
|
53
|
$done = 1; |
544
|
|
|
|
|
|
|
} |
545
|
2
|
|
|
|
|
18
|
); |
546
|
|
|
|
|
|
|
} |
547
|
|
|
|
|
|
|
|
548
|
|
|
|
|
|
|
sub tie_output() { |
549
|
8
|
|
|
8
|
0
|
115
|
my $handle = shift; |
550
|
8
|
50
|
|
|
|
40
|
die "No buffer to tie" unless @_; |
551
|
8
|
|
|
|
|
37
|
tie *$handle, 'Test::Base::Handle', $_[0]; |
552
|
|
|
|
|
|
|
} |
553
|
|
|
|
|
|
|
|
554
|
0
|
|
|
0
|
0
|
0
|
sub no_diff { |
555
|
0
|
|
|
|
|
0
|
$ENV{TEST_SHOW_NO_DIFFS} = 1; |
556
|
|
|
|
|
|
|
} |
557
|
|
|
|
|
|
|
|
558
|
|
|
|
|
|
|
package Test::Base::Handle; |
559
|
|
|
|
|
|
|
|
560
|
|
|
|
|
|
|
sub TIEHANDLE() { |
561
|
8
|
|
|
8
|
|
12
|
my $class = shift; |
562
|
8
|
|
|
|
|
34
|
bless \ $_[0], $class; |
563
|
|
|
|
|
|
|
} |
564
|
|
|
|
|
|
|
|
565
|
4
|
|
|
4
|
|
8
|
sub PRINT { |
566
|
4
|
|
|
|
|
67
|
$$self .= $_ for @_; |
567
|
|
|
|
|
|
|
} |
568
|
|
|
|
|
|
|
|
569
|
|
|
|
|
|
|
#=============================================================================== |
570
|
|
|
|
|
|
|
# Test::Base::Block |
571
|
|
|
|
|
|
|
# |
572
|
|
|
|
|
|
|
# This is the default class for accessing a Test::Base block object. |
573
|
|
|
|
|
|
|
#=============================================================================== |
574
|
|
|
|
|
|
|
package Test::Base::Block; |
575
|
|
|
|
|
|
|
our @ISA = qw(Spiffy); |
576
|
|
|
|
|
|
|
|
577
|
|
|
|
|
|
|
our @EXPORT = qw(block_accessor); |
578
|
|
|
|
|
|
|
|
579
|
0
|
|
|
0
|
|
0
|
sub AUTOLOAD { |
580
|
0
|
|
|
|
|
0
|
return; |
581
|
|
|
|
|
|
|
} |
582
|
|
|
|
|
|
|
|
583
|
|
|
|
|
|
|
sub block_accessor() { |
584
|
6
|
|
|
6
|
|
11
|
my $accessor = shift; |
585
|
1
|
|
|
1
|
|
7
|
no strict 'refs'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
196
|
|
586
|
6
|
50
|
|
|
|
34
|
return if defined &$accessor; |
587
|
|
|
|
|
|
|
*$accessor = sub { |
588
|
32
|
|
|
32
|
|
35
|
my $self = shift; |
589
|
32
|
50
|
|
|
|
55
|
if (@_) { |
590
|
0
|
|
|
|
|
0
|
Carp::croak "Not allowed to set values for '$accessor'"; |
591
|
|
|
|
|
|
|
} |
592
|
32
|
50
|
|
|
|
32
|
my @list = @{$self->{$accessor} || []}; |
|
32
|
|
|
|
|
98
|
|
593
|
|
|
|
|
|
|
return wantarray |
594
|
32
|
100
|
|
|
|
108
|
? (@list) |
595
|
|
|
|
|
|
|
: $list[0]; |
596
|
6
|
|
|
|
|
50
|
}; |
597
|
|
|
|
|
|
|
} |
598
|
|
|
|
|
|
|
|
599
|
|
|
|
|
|
|
block_accessor 'name'; |
600
|
|
|
|
|
|
|
block_accessor 'description'; |
601
|
|
|
|
|
|
|
Spiffy::field 'seq_num'; |
602
|
|
|
|
|
|
|
Spiffy::field 'is_filtered'; |
603
|
|
|
|
|
|
|
Spiffy::field 'blocks_object'; |
604
|
|
|
|
|
|
|
Spiffy::field 'original_values' => {}; |
605
|
|
|
|
|
|
|
|
606
|
56
|
|
|
56
|
|
276
|
sub set_value { |
607
|
1
|
|
|
1
|
|
6
|
no strict 'refs'; |
|
1
|
|
|
|
|
8
|
|
|
1
|
|
|
|
|
264
|
|
608
|
56
|
|
|
|
|
67
|
my $accessor = shift; |
609
|
56
|
100
|
|
|
|
155
|
block_accessor $accessor |
610
|
|
|
|
|
|
|
unless defined &$accessor; |
611
|
56
|
|
|
|
|
252
|
$self->{$accessor} = [@_]; |
612
|
|
|
|
|
|
|
} |
613
|
|
|
|
|
|
|
|
614
|
4
|
|
|
4
|
|
9
|
sub run_filters { |
615
|
4
|
|
|
|
|
11
|
my $map = $self->_section_map; |
616
|
4
|
|
|
|
|
9
|
my $order = $self->_section_order; |
617
|
4
|
50
|
|
|
|
65
|
Carp::croak "Attempt to filter a block twice" |
618
|
|
|
|
|
|
|
if $self->is_filtered; |
619
|
4
|
|
|
|
|
10
|
for my $type (@$order) { |
620
|
8
|
|
|
|
|
22
|
my $filters = $map->{$type}{filters}; |
621
|
8
|
|
|
|
|
20
|
my @value = $self->$type; |
622
|
8
|
|
|
|
|
139
|
$self->original_values->{$type} = $value[0]; |
623
|
8
|
|
|
|
|
23
|
for my $filter ($self->_get_filters($type, $filters)) { |
624
|
32
|
50
|
|
|
|
72
|
$Test::Base::Filter::arguments = |
625
|
|
|
|
|
|
|
$filter =~ s/=(.*)$// ? $1 : undef; |
626
|
32
|
|
|
|
|
52
|
my $function = "main::$filter"; |
627
|
1
|
|
|
1
|
|
6
|
no strict 'refs'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
593
|
|
628
|
32
|
50
|
|
|
|
144
|
if (defined &$function) { |
629
|
0
|
0
|
0
|
|
|
0
|
local $_ = |
630
|
|
|
|
|
|
|
(@value == 1 and not defined($value[0])) ? undef : |
631
|
|
|
|
|
|
|
join '', @value; |
632
|
0
|
|
|
|
|
0
|
my $old = $_; |
633
|
0
|
|
|
|
|
0
|
@value = &$function(@value); |
634
|
0
|
0
|
0
|
|
|
0
|
if (not(@value) or |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
635
|
|
|
|
|
|
|
@value == 1 and defined($value[0]) and $value[0] =~ /\A(\d+|)\z/ |
636
|
|
|
|
|
|
|
) { |
637
|
0
|
0
|
0
|
|
|
0
|
if ($value[0] && $_ eq $old) { |
638
|
0
|
|
|
|
|
0
|
Test::Base::diag("Filters returning numbers are supposed to do munging \$_: your filter '$function' apparently doesn't."); |
639
|
|
|
|
|
|
|
} |
640
|
0
|
|
|
|
|
0
|
@value = ($_); |
641
|
|
|
|
|
|
|
} |
642
|
|
|
|
|
|
|
} |
643
|
|
|
|
|
|
|
else { |
644
|
32
|
|
|
|
|
596
|
my $filter_object = $self->blocks_object->filter_class->new; |
645
|
32
|
50
|
|
|
|
86
|
die "Can't find a function or method for '$filter' filter\n" |
646
|
|
|
|
|
|
|
unless $filter_object->can($filter); |
647
|
32
|
|
|
|
|
473
|
$filter_object->current_block($self); |
648
|
32
|
|
|
|
|
106
|
@value = $filter_object->$filter(@value); |
649
|
|
|
|
|
|
|
} |
650
|
|
|
|
|
|
|
# Set the value after each filter since other filters may be |
651
|
|
|
|
|
|
|
# introspecting. |
652
|
32
|
|
|
|
|
177
|
$self->set_value($type, @value); |
653
|
|
|
|
|
|
|
} |
654
|
|
|
|
|
|
|
} |
655
|
4
|
|
|
|
|
64
|
$self->is_filtered(1); |
656
|
|
|
|
|
|
|
} |
657
|
|
|
|
|
|
|
|
658
|
8
|
|
|
8
|
|
10
|
sub _get_filters { |
659
|
8
|
|
|
|
|
8
|
my $type = shift; |
660
|
8
|
|
50
|
|
|
30
|
my $string = shift || ''; |
661
|
8
|
|
|
|
|
36
|
$string =~ s/\s*(.*?)\s*/$1/; |
662
|
8
|
|
|
|
|
11
|
my @filters = (); |
663
|
8
|
|
50
|
|
|
115
|
my $map_filters = $self->blocks_object->_filters_map->{$type} || []; |
664
|
8
|
50
|
|
|
|
21
|
$map_filters = [ $map_filters ] unless ref $map_filters; |
665
|
8
|
|
|
|
|
13
|
my @append = (); |
666
|
8
|
|
|
|
|
8
|
for ( |
667
|
8
|
|
|
|
|
115
|
@{$self->blocks_object->_filters}, |
668
|
|
|
|
|
|
|
@$map_filters, |
669
|
|
|
|
|
|
|
split(/\s+/, $string), |
670
|
|
|
|
|
|
|
) { |
671
|
32
|
|
|
|
|
35
|
my $filter = $_; |
672
|
32
|
50
|
|
|
|
70
|
last unless length $filter; |
673
|
32
|
50
|
|
|
|
69
|
if ($filter =~ s/^-//) { |
|
|
50
|
|
|
|
|
|
674
|
0
|
|
|
|
|
0
|
@filters = grep { $_ ne $filter } @filters; |
|
0
|
|
|
|
|
0
|
|
675
|
|
|
|
|
|
|
} |
676
|
|
|
|
|
|
|
elsif ($filter =~ s/^\+//) { |
677
|
0
|
|
|
|
|
0
|
push @append, $filter; |
678
|
|
|
|
|
|
|
} |
679
|
|
|
|
|
|
|
else { |
680
|
32
|
|
|
|
|
63
|
push @filters, $filter; |
681
|
|
|
|
|
|
|
} |
682
|
|
|
|
|
|
|
} |
683
|
8
|
|
|
|
|
29
|
return @filters, @append; |
684
|
|
|
|
|
|
|
} |
685
|
|
|
|
|
|
|
|
686
|
|
|
|
|
|
|
{ |
687
|
|
|
|
|
|
|
%$reserved_section_names = map { |
688
|
|
|
|
|
|
|
($_, 1); |
689
|
|
|
|
|
|
|
} keys(%Test::Base::Block::), qw( new DESTROY ); |
690
|
|
|
|
|
|
|
} |
691
|
|
|
|
|
|
|
|
692
|
|
|
|
|
|
|
1; |