line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Test::Spec::Context; |
2
|
14
|
|
|
14
|
|
86
|
use strict; |
|
14
|
|
|
|
|
31
|
|
|
14
|
|
|
|
|
395
|
|
3
|
14
|
|
|
14
|
|
72
|
use warnings; |
|
14
|
|
|
|
|
30
|
|
|
14
|
|
|
|
|
376
|
|
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
######################################################################## |
6
|
|
|
|
|
|
|
# NO USER-SERVICEABLE PARTS INSIDE. |
7
|
|
|
|
|
|
|
######################################################################## |
8
|
|
|
|
|
|
|
|
9
|
14
|
|
|
14
|
|
78
|
use Carp (); |
|
14
|
|
|
|
|
31
|
|
|
14
|
|
|
|
|
200
|
|
10
|
14
|
|
|
14
|
|
89
|
use List::Util (); |
|
14
|
|
|
|
|
35
|
|
|
14
|
|
|
|
|
219
|
|
11
|
14
|
|
|
14
|
|
77
|
use Scalar::Util (); |
|
14
|
|
|
|
|
29
|
|
|
14
|
|
|
|
|
240
|
|
12
|
14
|
|
|
14
|
|
61
|
use Test::More (); |
|
14
|
|
|
|
|
28
|
|
|
14
|
|
|
|
|
294
|
|
13
|
14
|
|
|
14
|
|
67
|
use Test::Spec qw(*TODO $Debug :constants); |
|
14
|
|
|
|
|
27
|
|
|
14
|
|
|
|
|
132
|
|
14
|
14
|
|
|
14
|
|
4400
|
use Test::Spec::Example; |
|
14
|
|
|
|
|
35
|
|
|
14
|
|
|
|
|
407
|
|
15
|
14
|
|
|
14
|
|
3708
|
use Test::Spec::TodoExample; |
|
14
|
|
|
|
|
35
|
|
|
14
|
|
|
|
|
31590
|
|
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
our $_StackDepth = 0; |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
sub new { |
20
|
180
|
|
|
180
|
0
|
378
|
my $class = shift; |
21
|
180
|
|
|
|
|
425
|
my $self = bless {}, $class; |
22
|
|
|
|
|
|
|
|
23
|
180
|
50
|
|
|
|
449
|
if (@_) { |
24
|
0
|
|
|
|
|
0
|
my $args = shift; |
25
|
0
|
0
|
0
|
|
|
0
|
if (@_ || ref($args) ne 'HASH') { |
26
|
0
|
|
|
|
|
0
|
Carp::croak "usage: $class->new(\\%args)"; |
27
|
|
|
|
|
|
|
} |
28
|
0
|
|
|
|
|
0
|
while (my ($name,$val) = each (%$args)) { |
29
|
0
|
|
|
|
|
0
|
$self->$name($val); |
30
|
|
|
|
|
|
|
} |
31
|
|
|
|
|
|
|
} |
32
|
|
|
|
|
|
|
|
33
|
180
|
|
|
|
|
283
|
my $this = $self; |
34
|
180
|
|
|
|
|
690
|
Scalar::Util::weaken($this); |
35
|
|
|
|
|
|
|
$self->on_enter(sub { |
36
|
|
|
|
|
|
|
$this && $this->_debug(sub { |
37
|
0
|
|
|
|
|
0
|
printf STDERR "%s[%s]\n", ' ' x $_StackDepth, $this->_debug_name; |
38
|
0
|
|
|
|
|
0
|
$_StackDepth++; |
39
|
526
|
50
|
|
526
|
|
2597
|
}); |
40
|
180
|
|
|
|
|
999
|
}); |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
$self->on_leave(sub { |
43
|
|
|
|
|
|
|
$this && $this->_debug(sub { |
44
|
0
|
|
|
|
|
0
|
$_StackDepth--; |
45
|
0
|
|
|
|
|
0
|
printf STDERR "%s[/%s]\n", ' ' x $_StackDepth, $this->_debug_name; |
46
|
526
|
50
|
|
526
|
|
2562
|
}); |
47
|
180
|
|
|
|
|
816
|
}); |
48
|
|
|
|
|
|
|
|
49
|
180
|
|
|
|
|
586
|
return $self; |
50
|
|
|
|
|
|
|
} |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
sub clone { |
53
|
4
|
|
|
4
|
0
|
7
|
my $orig = shift; |
54
|
4
|
|
|
|
|
17
|
my $clone = bless { %$orig }, ref($orig); |
55
|
|
|
|
|
|
|
|
56
|
4
|
|
|
|
|
9
|
my $orig_contexts = $clone->context_lookup; |
57
|
4
|
|
|
|
|
9
|
my $new_contexts = Test::Spec::_ixhash(); |
58
|
|
|
|
|
|
|
|
59
|
4
|
|
|
|
|
21
|
while (my ($name,$ctx) = each %$orig_contexts) { |
60
|
0
|
|
|
|
|
0
|
my $new_ctx = $ctx->clone; |
61
|
0
|
|
|
|
|
0
|
$new_ctx->parent($clone); |
62
|
0
|
|
|
|
|
0
|
$new_contexts->{$name} = $new_ctx; |
63
|
|
|
|
|
|
|
} |
64
|
4
|
|
|
|
|
72
|
$clone->{_context_lookup} = $new_contexts; |
65
|
|
|
|
|
|
|
|
66
|
4
|
|
|
|
|
23
|
return $clone; |
67
|
|
|
|
|
|
|
} |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
# The reference we keep to our parent causes the garbage collector to |
70
|
|
|
|
|
|
|
# destroy the innermost context first, which is what we want. If that |
71
|
|
|
|
|
|
|
# becomes untrue at some point, it will be easy enough to descend the |
72
|
|
|
|
|
|
|
# hierarchy and run the after("all") tests that way. |
73
|
|
|
|
|
|
|
sub DESTROY { |
74
|
179
|
|
|
179
|
|
406
|
my $self = shift; |
75
|
|
|
|
|
|
|
# no need to tear down what was never set up |
76
|
179
|
100
|
|
|
|
413
|
if ($self->_has_run_before_all) { |
77
|
55
|
|
|
|
|
129
|
$self->_run_after_all_once; |
78
|
|
|
|
|
|
|
} |
79
|
|
|
|
|
|
|
} |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
sub name { |
82
|
528
|
|
|
528
|
0
|
717
|
my $self = shift; |
83
|
528
|
100
|
|
|
|
1158
|
$self->{_name} = shift if @_; |
84
|
|
|
|
|
|
|
return exists($self->{_name}) |
85
|
|
|
|
|
|
|
? $self->{_name} |
86
|
528
|
50
|
|
|
|
1355
|
: ($self->{_name} = ''); |
87
|
|
|
|
|
|
|
} |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
sub parent { |
90
|
6918
|
|
|
6918
|
0
|
8913
|
my $self = shift; |
91
|
6918
|
100
|
|
|
|
10961
|
if (@_) { |
92
|
161
|
|
|
|
|
285
|
$self->{_parent} = shift; |
93
|
161
|
50
|
|
|
|
625
|
Scalar::Util::weaken($self->{_parent}) if ref($self->{_parent}); |
94
|
|
|
|
|
|
|
} |
95
|
6918
|
|
|
|
|
14662
|
return $self->{_parent}; |
96
|
|
|
|
|
|
|
} |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
sub class { |
99
|
1546
|
|
|
1546
|
0
|
2023
|
my $self = shift; |
100
|
1546
|
100
|
|
|
|
2737
|
$self->{_class} = shift if @_; |
101
|
1546
|
100
|
|
|
|
2802
|
if ($self->{_class}) { |
|
|
50
|
|
|
|
|
|
102
|
658
|
|
|
|
|
2202
|
return $self->{_class}; |
103
|
|
|
|
|
|
|
} |
104
|
|
|
|
|
|
|
elsif ($self->parent) { |
105
|
888
|
|
|
|
|
1380
|
return $self->parent->class; |
106
|
|
|
|
|
|
|
} |
107
|
|
|
|
|
|
|
else { |
108
|
0
|
|
|
|
|
0
|
return undef; |
109
|
|
|
|
|
|
|
} |
110
|
|
|
|
|
|
|
} |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
sub context_lookup { |
113
|
257
|
|
|
257
|
0
|
332
|
my $self = shift; |
114
|
257
|
|
66
|
|
|
868
|
return $self->{_context_lookup} ||= Test::Spec::_ixhash(); |
115
|
|
|
|
|
|
|
} |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
sub before_blocks { |
118
|
429
|
|
|
429
|
0
|
625
|
my $self = shift; |
119
|
429
|
|
100
|
|
|
1496
|
return $self->{_before_blocks} ||= []; |
120
|
|
|
|
|
|
|
} |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
sub after_blocks { |
123
|
401
|
|
|
401
|
0
|
615
|
my $self = shift; |
124
|
401
|
|
100
|
|
|
1549
|
return $self->{_after_blocks} ||= []; |
125
|
|
|
|
|
|
|
} |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
sub tests { |
128
|
325
|
|
|
325
|
0
|
446
|
my $self = shift; |
129
|
325
|
|
100
|
|
|
1425
|
return $self->{_tests} ||= []; |
130
|
|
|
|
|
|
|
} |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
sub on_enter_blocks { |
133
|
1635
|
|
|
1635
|
0
|
2294
|
my $self = shift; |
134
|
1635
|
|
100
|
|
|
4654
|
return $self->{_on_enter_blocks} ||= []; |
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
sub on_leave_blocks { |
138
|
1635
|
|
|
1635
|
0
|
2206
|
my $self = shift; |
139
|
1635
|
|
100
|
|
|
4897
|
return $self->{_on_leave_blocks} ||= []; |
140
|
|
|
|
|
|
|
} |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
# private attributes |
143
|
|
|
|
|
|
|
sub _has_run_before_all { |
144
|
580
|
|
|
580
|
|
869
|
my $self = shift; |
145
|
580
|
100
|
|
|
|
1108
|
$self->{__has_run_before_all} = shift if @_; |
146
|
580
|
|
|
|
|
2215
|
return $self->{__has_run_before_all}; |
147
|
|
|
|
|
|
|
} |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
sub _has_run_after_all { |
150
|
110
|
|
|
110
|
|
162
|
my $self = shift; |
151
|
110
|
100
|
|
|
|
264
|
$self->{__has_run_after_all} = shift if @_; |
152
|
110
|
|
|
|
|
221
|
return $self->{__has_run_after_all}; |
153
|
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
sub _debug { |
156
|
1052
|
|
|
1052
|
|
2116
|
my ($self,$code) = @_; |
157
|
1052
|
50
|
|
|
|
1783
|
return unless $self->_debugging; |
158
|
0
|
|
|
|
|
0
|
$code->(); |
159
|
|
|
|
|
|
|
} |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
sub _debug_name { |
162
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
163
|
0
|
0
|
|
|
|
0
|
$self->name || '(anonymous)'; |
164
|
|
|
|
|
|
|
} |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
sub _debugging { |
167
|
1052
|
|
|
1052
|
|
1446
|
my $self = shift; |
168
|
|
|
|
|
|
|
# env var can be set greater than 1 for definition phase debug. |
169
|
|
|
|
|
|
|
# otherwise, any true value means debug execution |
170
|
1052
|
50
|
33
|
|
|
2988
|
if ($Debug > 1) { |
|
|
50
|
|
|
|
|
|
171
|
0
|
|
|
|
|
0
|
return 1; |
172
|
|
|
|
|
|
|
} |
173
|
|
|
|
|
|
|
elsif ($Debug && $self->class->phase == EXECUTION_PHASE) { |
174
|
0
|
|
|
|
|
0
|
return 1; |
175
|
|
|
|
|
|
|
} |
176
|
1052
|
|
|
|
|
2531
|
return; |
177
|
|
|
|
|
|
|
} |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
sub on_enter { |
180
|
252
|
|
|
252
|
0
|
525
|
my ($self,$callback) = @_; |
181
|
252
|
|
|
|
|
363
|
push @{ $self->on_enter_blocks }, $callback; |
|
252
|
|
|
|
|
527
|
|
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
# Handle case where an on_enter was added during a context declaration. |
184
|
|
|
|
|
|
|
# This allows stubs being set up to be valid both in that current Perl |
185
|
|
|
|
|
|
|
# context and later in spec context. |
186
|
252
|
100
|
|
|
|
908
|
if (Test::Spec->in_context($self)) { |
187
|
72
|
50
|
|
|
|
305
|
if (not $self->{_has_run_on_enter}{$callback}++) { |
188
|
72
|
|
|
|
|
174
|
$callback->(); |
189
|
|
|
|
|
|
|
} |
190
|
|
|
|
|
|
|
} |
191
|
252
|
|
|
|
|
511
|
return; |
192
|
|
|
|
|
|
|
} |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
sub on_leave { |
195
|
252
|
|
|
252
|
0
|
513
|
my ($self,$callback) = @_; |
196
|
252
|
|
|
|
|
379
|
push @{ $self->on_leave_blocks }, $callback; |
|
252
|
|
|
|
|
523
|
|
197
|
|
|
|
|
|
|
} |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
sub ancestors { |
200
|
157
|
|
|
157
|
0
|
356
|
my ($self) = @_; |
201
|
157
|
50
|
|
|
|
358
|
return $self->parent ? ($self->parent, $self->parent->ancestors) : (); |
202
|
|
|
|
|
|
|
} |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
sub ancestor_of { |
205
|
157
|
|
|
157
|
0
|
368
|
my ($self,$other) = @_; |
206
|
157
|
|
|
0
|
|
740
|
return !!List::Util::first { $other == $_ } $self->ancestors; |
|
0
|
|
|
|
|
0
|
|
207
|
|
|
|
|
|
|
} |
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
sub contexts { |
210
|
216
|
|
|
216
|
0
|
288
|
my $self = shift; |
211
|
216
|
|
|
|
|
265
|
my @ctx = values %{ $self->context_lookup }; |
|
216
|
|
|
|
|
325
|
|
212
|
216
|
50
|
|
|
|
2528
|
return wantarray ? @ctx : \@ctx; |
213
|
|
|
|
|
|
|
} |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
# recurse into child contexts to count total tests for a package |
216
|
|
|
|
|
|
|
sub _count_tests { |
217
|
153
|
|
|
153
|
|
202
|
my $self = shift; |
218
|
153
|
|
|
|
|
241
|
my @descendant = map { $_->_count_tests } $self->contexts; |
|
38
|
|
|
|
|
90
|
|
219
|
153
|
|
|
|
|
191
|
return @{$self->tests} + List::Util::sum(0, @descendant); |
|
153
|
|
|
|
|
247
|
|
220
|
|
|
|
|
|
|
} |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
sub _run_callback { |
223
|
800
|
|
|
800
|
|
1621
|
my ($self,$type,$pool,@args) = @_; |
224
|
800
|
|
|
|
|
1439
|
my @subs = map { $_->{code} } grep { $_->{type} eq $type } @$pool; |
|
114
|
|
|
|
|
360
|
|
|
176
|
|
|
|
|
711
|
|
225
|
800
|
|
|
|
|
2823
|
for my $code (@subs) { |
226
|
114
|
|
|
|
|
349
|
$code->(@args); |
227
|
|
|
|
|
|
|
} |
228
|
|
|
|
|
|
|
} |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
sub _run_before { |
231
|
401
|
|
|
401
|
|
698
|
my $self = shift; |
232
|
401
|
|
|
|
|
791
|
my $type = shift; |
233
|
401
|
|
|
|
|
840
|
return $self->_run_callback($type,$self->before_blocks,@_); |
234
|
|
|
|
|
|
|
} |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
sub _run_before_all_once { |
237
|
344
|
|
|
344
|
|
509
|
my $self = shift; |
238
|
344
|
100
|
|
|
|
656
|
return if $self->_has_run_before_all; |
239
|
57
|
|
|
|
|
178
|
$self->_has_run_before_all(1); |
240
|
57
|
|
|
|
|
163
|
return $self->_run_before('all',@_); |
241
|
|
|
|
|
|
|
} |
242
|
|
|
|
|
|
|
|
243
|
|
|
|
|
|
|
sub _run_after { |
244
|
399
|
|
|
399
|
|
693
|
my $self = shift; |
245
|
399
|
|
|
|
|
639
|
my $type = shift; |
246
|
399
|
|
|
|
|
834
|
return $self->_run_callback($type,$self->after_blocks,@_); |
247
|
|
|
|
|
|
|
} |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
sub _run_after_all_once { |
250
|
55
|
|
|
55
|
|
92
|
my $self = shift; |
251
|
55
|
50
|
|
|
|
117
|
return if $self->_has_run_after_all; |
252
|
55
|
|
|
|
|
156
|
$self->_has_run_after_all(1); |
253
|
55
|
|
|
|
|
124
|
return $self->_run_after('all',@_); |
254
|
|
|
|
|
|
|
} |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
# join by spaces and strip leading/extra spaces |
257
|
|
|
|
|
|
|
sub _concat { |
258
|
122
|
|
|
122
|
|
290
|
my ($self,@pieces) = @_; |
259
|
122
|
|
|
|
|
442
|
my $str = join(' ', @pieces); |
260
|
122
|
|
|
|
|
1371
|
$str =~ s{\A\s+|\s+\z}{}s; |
261
|
122
|
|
|
|
|
917
|
$str =~ s{\s+}{ }sg; |
262
|
122
|
|
|
|
|
313
|
return $str; |
263
|
|
|
|
|
|
|
} |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
sub _materialize_tests { |
266
|
59
|
|
|
59
|
|
320
|
my ($self, $digits, @context_stack) = @_; |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
# include the name of the context in test reports |
269
|
59
|
|
|
|
|
106
|
push @context_stack, $self; |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
# need to know how many tests there are, so we can make a lexically |
272
|
|
|
|
|
|
|
# sortable test name using numeric prefix. |
273
|
59
|
100
|
|
|
|
174
|
if (not defined $digits) { |
274
|
|
|
|
|
|
|
my $top_level_sum = List::Util::sum( |
275
|
23
|
|
|
|
|
75
|
map { $_->_count_tests } $self->class->contexts |
|
115
|
|
|
|
|
228
|
|
276
|
|
|
|
|
|
|
); |
277
|
23
|
50
|
|
|
|
96
|
if ($top_level_sum == 0) { |
278
|
0
|
|
|
|
|
0
|
warn "no examples defined in spec package " . $self->class; |
279
|
0
|
|
|
|
|
0
|
return; |
280
|
|
|
|
|
|
|
} |
281
|
23
|
|
|
|
|
134
|
$digits = 1 + int( log($top_level_sum) / log(10) ); |
282
|
|
|
|
|
|
|
} |
283
|
|
|
|
|
|
|
|
284
|
|
|
|
|
|
|
# Create a test sub like 't001_enough_mucus' |
285
|
59
|
|
|
|
|
158
|
my $format = "t%0${digits}d_%s"; |
286
|
|
|
|
|
|
|
|
287
|
59
|
|
|
|
|
90
|
for my $t (@{ $self->tests }) { |
|
59
|
|
|
|
|
119
|
|
288
|
122
|
|
|
|
|
236
|
my $description = $self->_concat((map { $_->name } @context_stack), $t->{name}); |
|
344
|
|
|
|
|
530
|
|
289
|
122
|
|
|
|
|
265
|
my $test_number = 1 + scalar($self->class->tests); |
290
|
122
|
|
|
|
|
268
|
my $sub_name = sprintf $format, $test_number, $self->_make_safe($description); |
291
|
|
|
|
|
|
|
|
292
|
|
|
|
|
|
|
# create a test subroutine in the correct package |
293
|
122
|
|
|
|
|
219
|
my $example; |
294
|
122
|
50
|
33
|
|
|
486
|
if (!$t->{code} || $t->{todo}) { |
295
|
|
|
|
|
|
|
$example = Test::Spec::TodoExample->new({ |
296
|
|
|
|
|
|
|
name => $sub_name, |
297
|
|
|
|
|
|
|
reason => $t->{tdoo}, |
298
|
0
|
|
|
|
|
0
|
description => $description, |
299
|
|
|
|
|
|
|
builder => $self->_builder, |
300
|
|
|
|
|
|
|
}); |
301
|
|
|
|
|
|
|
} |
302
|
|
|
|
|
|
|
else { |
303
|
|
|
|
|
|
|
$example = Test::Spec::Example->new({ |
304
|
|
|
|
|
|
|
name => $sub_name, |
305
|
|
|
|
|
|
|
description => $description, |
306
|
|
|
|
|
|
|
code => $t->{code}, |
307
|
122
|
|
|
|
|
338
|
context => $self, |
308
|
|
|
|
|
|
|
builder => $self->_builder, |
309
|
|
|
|
|
|
|
}); |
310
|
|
|
|
|
|
|
} |
311
|
|
|
|
|
|
|
|
312
|
122
|
|
|
|
|
388
|
$self->class->add_test($example); |
313
|
|
|
|
|
|
|
} |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
# recurse to child contexts |
316
|
59
|
|
|
|
|
153
|
for my $ctx ($self->contexts) { |
317
|
36
|
|
|
|
|
167
|
$ctx->_materialize_tests($digits, @context_stack); |
318
|
|
|
|
|
|
|
} |
319
|
|
|
|
|
|
|
} |
320
|
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
sub _builder { |
322
|
122
|
|
|
122
|
|
244
|
shift->class->builder; |
323
|
|
|
|
|
|
|
} |
324
|
|
|
|
|
|
|
|
325
|
|
|
|
|
|
|
sub _make_safe { |
326
|
122
|
|
|
122
|
|
220
|
my ($self,$str) = @_; |
327
|
122
|
50
|
33
|
|
|
462
|
return '' unless (defined($str) && length($str)); |
328
|
122
|
|
|
|
|
293
|
$str = lc($str); |
329
|
122
|
|
|
|
|
299
|
$str =~ s{'}{}g; |
330
|
122
|
|
|
|
|
851
|
$str =~ s{\W+}{_}g; |
331
|
122
|
|
|
|
|
860
|
$str =~ s{_+}{_}g; |
332
|
122
|
|
|
|
|
526
|
return $str; |
333
|
|
|
|
|
|
|
} |
334
|
|
|
|
|
|
|
|
335
|
|
|
|
|
|
|
# Recurse to run the entire on_enter chain, starting from the top. |
336
|
|
|
|
|
|
|
# Propagate exceptions in the same way that _run_on_leave does, for the same |
337
|
|
|
|
|
|
|
# reasons. |
338
|
|
|
|
|
|
|
sub _run_on_enter { |
339
|
1383
|
|
|
1383
|
|
1975
|
my $self = shift; |
340
|
1383
|
|
|
|
|
1617
|
my @errs; |
341
|
1383
|
100
|
|
|
|
2172
|
if ($self->parent) { |
342
|
857
|
|
|
|
|
1230
|
eval { $self->parent->_run_on_enter }; |
|
857
|
|
|
|
|
1310
|
|
343
|
857
|
50
|
|
|
|
1490
|
push @errs, $@ if $@; |
344
|
|
|
|
|
|
|
} |
345
|
1383
|
|
|
|
|
1849
|
for my $on_enter (@{ $self->on_enter_blocks }) { |
|
1383
|
|
|
|
|
2297
|
|
346
|
3838
|
100
|
|
|
|
10112
|
next if $self->{_has_run_on_enter}{$on_enter}++; |
347
|
1221
|
|
|
|
|
1766
|
eval { $on_enter->() }; |
|
1221
|
|
|
|
|
2722
|
|
348
|
1221
|
50
|
|
|
|
3806
|
push @errs, $@ if $@; |
349
|
|
|
|
|
|
|
} |
350
|
1383
|
50
|
|
|
|
2623
|
die join("\n", @errs) if @errs; |
351
|
1383
|
|
|
|
|
2319
|
return; |
352
|
|
|
|
|
|
|
} |
353
|
|
|
|
|
|
|
|
354
|
|
|
|
|
|
|
# Recurse to run the entire on_leave chain, starting from the bottom (and in |
355
|
|
|
|
|
|
|
# reverse "unwinding" order). |
356
|
|
|
|
|
|
|
# Propagate all exceptions only after running all on_leave blocks. This allows |
357
|
|
|
|
|
|
|
# mocks (and whatever else) to test their expectations after the test has |
358
|
|
|
|
|
|
|
# completed. |
359
|
|
|
|
|
|
|
sub _run_on_leave { |
360
|
1383
|
|
|
1383
|
|
2035
|
my $self = shift; |
361
|
1383
|
|
|
|
|
1805
|
my @errs; |
362
|
1383
|
|
|
|
|
1754
|
for my $on_leave (reverse @{ $self->on_leave_blocks }) { |
|
1383
|
|
|
|
|
2213
|
|
363
|
3910
|
100
|
|
|
|
10665
|
next if $self->{_has_run_on_leave}{$on_leave}++; |
364
|
1293
|
|
|
|
|
1904
|
eval { $on_leave->() }; |
|
1293
|
|
|
|
|
2834
|
|
365
|
1293
|
50
|
|
|
|
3776
|
push @errs, $@ if $@; |
366
|
|
|
|
|
|
|
} |
367
|
1383
|
100
|
|
|
|
2580
|
if ($self->parent) { |
368
|
857
|
|
|
|
|
1165
|
eval { $self->parent->_run_on_leave }; |
|
857
|
|
|
|
|
1348
|
|
369
|
857
|
50
|
|
|
|
1502
|
push @errs, $@ if $@; |
370
|
|
|
|
|
|
|
} |
371
|
1383
|
50
|
|
|
|
2421
|
die join("\n", @errs) if @errs; |
372
|
1383
|
|
|
|
|
2066
|
return; |
373
|
|
|
|
|
|
|
} |
374
|
|
|
|
|
|
|
|
375
|
|
|
|
|
|
|
# for giving individual tests mortal, anonymous contexts that are used for |
376
|
|
|
|
|
|
|
# mocking/stubbing hooks. |
377
|
|
|
|
|
|
|
sub _in_anonymous_context { |
378
|
123
|
|
|
123
|
|
290
|
my ($self,$code,$example) = @_; |
379
|
123
|
|
|
|
|
497
|
my $context = Test::Spec::Context->new; |
380
|
123
|
|
|
|
|
384
|
$context->name(''); |
381
|
123
|
|
|
|
|
319
|
$context->parent($self); |
382
|
123
|
|
|
|
|
296
|
$context->class($self->class); |
383
|
123
|
|
|
|
|
354
|
$context->contextualize($code, $example); |
384
|
|
|
|
|
|
|
} |
385
|
|
|
|
|
|
|
|
386
|
|
|
|
|
|
|
# Runs $code within a context (specifically, having been wrapped with |
387
|
|
|
|
|
|
|
# on_enter/on_leave setup and teardown). |
388
|
|
|
|
|
|
|
sub contextualize { |
389
|
526
|
|
|
526
|
0
|
1084
|
my ($self,$code,$example) = @_; |
390
|
526
|
|
|
|
|
848
|
local $Test::Spec::_Current_Context = $self; |
391
|
526
|
|
|
|
|
1238
|
local $self->{_has_run_on_enter} = {}; |
392
|
526
|
|
|
|
|
1073
|
local $self->{_has_run_on_leave} = {}; |
393
|
526
|
|
|
|
|
823
|
local $TODO = $TODO; |
394
|
526
|
|
|
|
|
682
|
my @errs; |
395
|
|
|
|
|
|
|
|
396
|
526
|
|
|
|
|
740
|
eval { $self->_run_on_enter }; |
|
526
|
|
|
|
|
1038
|
|
397
|
526
|
50
|
|
|
|
948
|
push @errs, $@ if $@; |
398
|
|
|
|
|
|
|
|
399
|
526
|
50
|
|
|
|
994
|
if (not @errs) { |
400
|
526
|
|
|
|
|
683
|
eval { $code->($example) }; |
|
526
|
|
|
|
|
1316
|
|
401
|
526
|
50
|
|
|
|
51696
|
push @errs, $@ if $@; |
402
|
|
|
|
|
|
|
} |
403
|
|
|
|
|
|
|
|
404
|
|
|
|
|
|
|
# always run despite errors, since on_enter might have set up stuff that |
405
|
|
|
|
|
|
|
# needs to be torn down, before another on_enter died |
406
|
526
|
|
|
|
|
843
|
eval { $self->_run_on_leave }; |
|
526
|
|
|
|
|
1227
|
|
407
|
526
|
50
|
|
|
|
965
|
push @errs, $@ if $@; |
408
|
|
|
|
|
|
|
|
409
|
526
|
50
|
|
|
|
975
|
if (@errs) { |
410
|
0
|
0
|
|
|
|
0
|
if ($TODO) { |
411
|
|
|
|
|
|
|
# make it easy for tests to declare todo status, just "$TODO++" |
412
|
0
|
0
|
|
|
|
0
|
$TODO = "(unimplemented)" if $TODO =~ /^\d+$/; |
413
|
|
|
|
|
|
|
# expected to fail |
414
|
0
|
|
|
|
|
0
|
Test::More::ok(1); |
415
|
|
|
|
|
|
|
} |
416
|
|
|
|
|
|
|
else { |
417
|
|
|
|
|
|
|
# rethrow |
418
|
0
|
|
|
|
|
0
|
die join("\n", @errs); |
419
|
|
|
|
|
|
|
} |
420
|
|
|
|
|
|
|
} |
421
|
|
|
|
|
|
|
|
422
|
526
|
|
|
|
|
3042
|
return; |
423
|
|
|
|
|
|
|
} |
424
|
|
|
|
|
|
|
|
425
|
|
|
|
|
|
|
# |
426
|
|
|
|
|
|
|
# Copyright (c) 2010-2011 by Informatics Corporation of America. |
427
|
|
|
|
|
|
|
# |
428
|
|
|
|
|
|
|
# This program is free software; you can redistribute it and/or modify it |
429
|
|
|
|
|
|
|
# under the same terms as Perl itself. |
430
|
|
|
|
|
|
|
# |
431
|
|
|
|
|
|
|
|
432
|
|
|
|
|
|
|
1; |