root/Encode-DoubleEncodedUTF8/trunk/inc/Test/Base.pm

Revision 2162 (checked in by miyagawa, 13 years ago)

import

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