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__ |