File Coverage

inc/Test/Base.pm
Criterion Covered Total %
statement 225 382 58.9
branch 57 192 29.6
condition 14 83 16.8
subroutine 43 64 67.1
pod 0 29 0.0
total 339 750 45.2


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;