File Coverage

inc/Test/Base.pm
Criterion Covered Total %
statement 216 381 56.6
branch 60 192 31.2
condition 17 83 20.4
subroutine 39 64 60.9
pod 0 29 0.0
total 332 749 44.3


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