File Coverage

inc/Test/Base.pm
Criterion Covered Total %
statement 218 358 60.8
branch 55 172 31.9
condition 16 71 22.5
subroutine 39 59 66.1
pod 0 25 0.0
total 328 685 47.8


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