File Coverage

inc/Test/Base.pm
Criterion Covered Total %
statement 212 384 55.2
branch 60 202 29.7
condition 10 83 12.0
subroutine 36 63 57.1
pod 20 29 68.9
total 338 761 44.4


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