File Coverage

inc/Test/Base.pm
Criterion Covered Total %
statement 267 384 69.5
branch 77 202 38.1
condition 22 83 26.5
subroutine 47 63 74.6
pod 0 29 0.0
total 413 761 54.2


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