File Coverage

inc/Test/Base.pm
Criterion Covered Total %
statement 218 364 59.8
branch 52 178 29.2
condition 16 74 21.6
subroutine 38 60 63.3
pod 0 26 0.0
total 324 702 46.1


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