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