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