File Coverage

blib/lib/Test/Spec/Context.pm
Criterion Covered Total %
statement 211 237 89.0
branch 55 90 61.1
condition 15 25 60.0
subroutine 46 48 95.8
pod 0 17 0.0
total 327 417 78.4


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;