File Coverage

inc/Test2/API/Context.pm
Criterion Covered Total %
statement 64 177 36.1
branch 15 68 22.0
condition 5 43 11.6
subroutine 16 32 50.0
pod 16 18 88.8
total 116 338 34.3


line stmt bran cond sub pod time code
1             #line 1
2 6     6   44 package Test2::API::Context;
  6         14  
  6         177  
3 6     6   30 use strict;
  6         11  
  6         310  
4             use warnings;
5              
6             our $VERSION = '1.302073';
7              
8 6     6   37  
  6         14  
  6         368  
9 6     6   35 use Carp qw/confess croak longmess/;
  6         13  
  6         352  
10 6     6   38 use Scalar::Util qw/weaken blessed/;
  6         11  
  6         318  
11             use Test2::Util qw/get_tid try pkg_to_file get_tid/;
12 6     6   39  
  6         12  
  6         86  
13 6     6   40 use Test2::Util::Trace();
  6         12  
  6         660  
14             use Test2::API();
15              
16             # Preload some key event types
17             my %LOADED = (
18             map {
19             my $pkg = "Test2::Event::$_";
20             my $file = "Test2/Event/$_.pm";
21             require $file unless $INC{$file};
22             ( $pkg => $pkg, $_ => $pkg )
23             } qw/Ok Diag Note Info Plan Bail Exception Waiting Skip Subtest/
24             );
25 6     6   42  
  6         11  
  6         546  
26 6         44 use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/;
27             use Test2::Util::HashBase qw{
28             stack hub trace _on_release _depth _is_canon _is_spawn _aborted
29 6     6   41 errno eval_error child_error thrown
  6         14  
30             };
31              
32             # Private, not package vars
33             # It is safe to cache these.
34             my $ON_RELEASE = Test2::API::_context_release_callbacks_ref();
35             my $CONTEXTS = Test2::API::_contexts_ref();
36              
37 6     6 0 28 sub init {
38             my $self = shift;
39              
40 6 50       29 confess "The 'trace' attribute is required"
41             unless $self->{+TRACE};
42              
43 6 50       25 confess "The 'hub' attribute is required"
44             unless $self->{+HUB};
45 6 50       33  
46             $self->{+_DEPTH} = 0 unless defined $self->{+_DEPTH};
47 6 50       79  
48 6 50       29 $self->{+ERRNO} = $! unless exists $self->{+ERRNO};
49 6 50       33 $self->{+EVAL_ERROR} = $@ unless exists $self->{+EVAL_ERROR};
50             $self->{+CHILD_ERROR} = $? unless exists $self->{+CHILD_ERROR};
51             }
52 9     9 1 22  
  9         83  
53             sub snapshot { bless {%{$_[0]}, _is_canon => undef, _is_spawn => undef, _aborted => undef}, __PACKAGE__ }
54              
55 0     0 1 0 sub restore_error_vars {
56 0         0 my $self = shift;
57             ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR};
58             }
59              
60 246 50 33 246   2492 sub DESTROY {
61 0 0 0     0 return unless $_[0]->{+_IS_CANON} || $_[0]->{+_IS_SPAWN};
  0         0  
62 0         0 return if $_[0]->{+_ABORTED} && ${$_[0]->{+_ABORTED}};
63             my ($self) = @_;
64 0         0  
65 0         0 my $hub = $self->{+HUB};
66             my $hid = $hub->{hid};
67              
68             # Do not show the warning if it looks like an exception has been thrown, or
69             # if the context is not local to this process or thread.
70             {
71             # Sometimes $@ is uninitialized, not a problem in this case so do not
72 6     6   47 # show the warning about using eq.
  6         21  
  6         11577  
  0         0  
73 0 0 0     0 no warnings 'uninitialized';
74 0   0     0 if($self->{+EVAL_ERROR} eq $@ && $hub->is_local) {
75 0         0 my $frame = $self->{+_IS_SPAWN} || $self->{+TRACE}->frame;
76             warn <<" EOT";
77             A context appears to have been destroyed without first calling release().
78             Based on \$@ it does not look like an exception was thrown (this is not always
79             a reliable test)
80              
81             This is a problem because the global error variables (\$!, \$@, and \$?) will
82             not be restored. In addition some release callbacks will not work properly from
83             inside a DESTROY method.
84              
85             Here are the context creation details, just in case a tool forgot to call
86             release():
87             File: $frame->[1]
88             Line: $frame->[2]
89             Tool: $frame->[3]
90              
91             Cleaning up the CONTEXT stack...
92             EOT
93             }
94             }
95 0 0       0  
96             return if $self->{+_IS_SPAWN};
97              
98 0         0 # Remove the key itself to avoid a slow memory leak
99 0         0 delete $CONTEXTS->{$hid};
100             $self->{+_IS_CANON} = undef;
101 0 0       0  
102 0         0 if (my $cbk = $self->{+_ON_RELEASE}) {
103             $_->($self) for reverse @$cbk;
104 0 0       0 }
105 0         0 if (my $hcbk = $hub->{_context_release}) {
106             $_->($self) for reverse @$hcbk;
107 0         0 }
108             $_->($self) for reverse @$ON_RELEASE;
109             }
110              
111             # release exists to implement behaviors like die-on-fail. In die-on-fail you
112             # want to die after a failure, but only after diagnostics have been reported.
113             # The ideal time for the die to happen is when the context is released.
114             # Unfortunately die does not work in a DESTROY block.
115 231     231 1 584 sub release {
116             my ($self) = @_;
117 231 50 0     554  
118             ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} and return if $self->{+THROWN};
119              
120 231 100 50     1240 ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} and return $self->{+_IS_SPAWN} = undef
121             if $self->{+_IS_SPAWN};
122              
123 92 50       208 croak "release() should not be called on context that is neither canon nor a child"
124             unless $self->{+_IS_CANON};
125 92         158  
126 92         172 my $hub = $self->{+HUB};
127             my $hid = $hub->{hid};
128              
129 92 50 33     464 croak "context thinks it is canon, but it is not"
130             unless $CONTEXTS->{$hid} && $CONTEXTS->{$hid} == $self;
131              
132 92         211 # Remove the key itself to avoid a slow memory leak
133 92         231 $self->{+_IS_CANON} = undef;
134             delete $CONTEXTS->{$hid};
135 92 50       208  
136 0         0 if (my $cbk = $self->{+_ON_RELEASE}) {
137             $_->($self) for reverse @$cbk;
138 92 50       210 }
139 0         0 if (my $hcbk = $hub->{_context_release}) {
140             $_->($self) for reverse @$hcbk;
141 92         217 }
142             $_->($self) for reverse @$ON_RELEASE;
143              
144             # Do this last so that nothing else changes them.
145             # If one of the hooks dies then these do not get restored, this is
146 92         390 # intentional
147             ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR};
148 92         228  
149             return;
150             }
151              
152 0     0 1 0 sub do_in_context {
153 0         0 my $self = shift;
154             my ($sub, @args) = @_;
155              
156 0         0 # We need to update the pid/tid and error vars.
157 0         0 my $clone = $self->snapshot;
158 0         0 @$clone{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} = ($!, $@, $?);
159 0         0 $clone->{+TRACE} = $clone->{+TRACE}->snapshot;
160 0         0 $clone->{+TRACE}->set_pid($$);
161             $clone->{+TRACE}->set_tid(get_tid());
162 0         0  
163 0         0 my $hub = $clone->{+HUB};
164             my $hid = $hub->hid;
165 0         0  
166             my $old = $CONTEXTS->{$hid};
167 0         0  
168 0         0 $clone->{+_IS_CANON} = 1;
169 0         0 $CONTEXTS->{$hid} = $clone;
170 0         0 weaken($CONTEXTS->{$hid});
171 0     0   0 my ($ok, $err) = &try($sub, @args);
  0         0  
172 0         0 my ($rok, $rerr) = try { $clone->release };
173             delete $clone->{+_IS_CANON};
174 0 0       0  
175 0         0 if ($old) {
176 0         0 $CONTEXTS->{$hid} = $old;
177             weaken($CONTEXTS->{$hid});
178             }
179 0         0 else {
180             delete $CONTEXTS->{$hid};
181             }
182 0 0       0  
183 0 0       0 die $err unless $ok;
184             die $rerr unless $rok;
185             }
186              
187 0     0 1 0 sub done_testing {
188 0         0 my $self = shift;
189 0         0 $self->hub->finalize($self->trace, 1);
190             return;
191             }
192              
193 0     0 1 0 sub throw {
194 0         0 my ($self, $msg) = @_;
195 0 0       0 $self->{+THROWN} = 1;
  0         0  
196 0 0 0     0 ${$self->{+_ABORTED}}++ if $self->{+_ABORTED};
197 0         0 $self->release if $self->{+_IS_CANON} || $self->{+_IS_SPAWN};
198             $self->trace->throw($msg);
199             }
200              
201 0     0 1 0 sub alert {
202 0         0 my ($self, $msg) = @_;
203             $self->trace->alert($msg);
204             }
205              
206 9     9 1 24 sub send_event {
207 9         20 my $self = shift;
208 9         32 my $event = shift;
209             my %args = @_;
210 9   33     41  
211             my $pkg = $LOADED{$event} || $self->_parse_event($event);
212              
213 9         65 my $e = $pkg->new(
214             trace => $self->{+TRACE}->snapshot,
215             %args,
216             );
217 9 50 33     85  
  0         0  
218 9         94 ${$self->{+_ABORTED}}++ if $self->{+_ABORTED} && defined $e->terminate;
219             $self->{+HUB}->send($e);
220             }
221              
222 0     0 1 0 sub build_event {
223 0         0 my $self = shift;
224 0         0 my $event = shift;
225             my %args = @_;
226 0   0     0  
227             my $pkg = $LOADED{$event} || $self->_parse_event($event);
228              
229 0         0 $pkg->new(
230             trace => $self->{+TRACE}->snapshot,
231             %args,
232             );
233             }
234              
235 0     0 1 0 sub ok {
236 0         0 my $self = shift;
237             my ($pass, $name, $on_fail) = @_;
238 0         0  
239             my $hub = $self->{+HUB};
240              
241 0         0 my $e = bless {
  0         0  
242             trace => bless( {%{$self->{+TRACE}}}, 'Test2::Util::Trace'),
243             pass => $pass,
244             name => $name,
245 0         0 }, 'Test2::Event::Ok';
246             $e->init;
247 0         0  
248 0 0       0 $hub->send($e);
249             return $e if $pass;
250 0         0  
251             $self->failure_diag($e);
252 0 0 0     0  
253 0         0 if ($on_fail && @$on_fail) {
254 0 0 0     0 for my $of (@$on_fail) {
      0        
255 0         0 if (ref($of) eq 'CODE' || (blessed($of) && $of->can('render'))) {
256             $self->info($of, diagnostics => 1);
257             }
258 0         0 else {
259             $self->diag($of);
260             }
261             }
262             }
263 0         0  
264             return $e;
265             }
266              
267 0     0 0 0 sub failure_diag {
268 0         0 my $self = shift;
269             my ($e) = @_;
270              
271             # This behavior is inherited from Test::Builder which injected a newline at
272             # the start of the first diagnostics when the harness is active, but not
273             # verbose. This is important to keep the diagnostics from showing up
274             # appended to the existing line, which is hard to read. In a verbose
275 0 0 0     0 # harness there is no need for this.
276             my $prefix = $ENV{HARNESS_ACTIVE} && !$ENV{HARNESS_IS_VERBOSE} ? "\n" : "";
277              
278             # Figure out the debug info, this is typically the file name and line
279             # number, but can also be a custom message. If no trace object is provided
280 0         0 # then we have nothing useful to display.
281 0         0 my $name = $e->name;
282 0 0       0 my $trace = $e->trace;
283             my $debug = $trace ? $trace->debug : "[No trace info available]";
284              
285             # Create the initial diagnostics. If the test has a name we put the debug
286 0 0       0 # info on a second line, this behavior is inherited from Test::Builder.
287             my $msg = defined($name)
288             ? qq[${prefix}Failed test '$name'\n$debug.\n]
289             : qq[${prefix}Failed test $debug.\n];
290 0         0  
291             $self->diag($msg);
292             }
293              
294 0     0 1 0 sub skip {
295 0         0 my $self = shift;
296 0         0 my ($name, $reason, @extra) = @_;
297             $self->send_event(
298             'Skip',
299             name => $name,
300             reason => $reason,
301             pass => 1,
302             @extra,
303             );
304             }
305              
306 0     0 1 0 sub info {
307 0         0 my $self = shift;
308 0         0 my ($renderer, %params) = @_;
309             $self->send_event('Info', renderer => $renderer, %params);
310             }
311              
312 9     9 1 19 sub note {
313 9         25 my $self = shift;
314 9         42 my ($message) = @_;
315             $self->send_event('Note', message => $message);
316             }
317              
318 0     0 1   sub diag {
319 0           my $self = shift;
320 0           my ($message) = @_;
321 0           my $hub = $self->{+HUB};
322             $self->send_event(
323             'Diag',
324             message => $message,
325             );
326             }
327              
328 0     0 1   sub plan {
329 0           my ($self, $max, $directive, $reason) = @_;
330             $self->send_event('Plan', max => $max, directive => $directive, reason => $reason);
331             }
332              
333 0     0 1   sub bail {
334 0           my ($self, $reason) = @_;
335             $self->send_event('Bail', reason => $reason);
336             }
337              
338 0     0     sub _parse_event {
339 0           my $self = shift;
340             my $event = shift;
341 0            
342 0 0         my $pkg;
343 0           if ($event =~ m/^\+(.*)/) {
344             $pkg = $1;
345             }
346 0           else {
347             $pkg = "Test2::Event::$event";
348             }
349 0 0          
350 0           unless ($LOADED{$pkg}) {
351 0     0     my $file = pkg_to_file($pkg);
  0            
352 0 0         my ($ok, $err) = try { require $file };
353             $self->throw("Could not load event module '$pkg': $err")
354             unless $ok;
355 0            
356             $LOADED{$pkg} = $pkg;
357             }
358 0 0          
359             confess "'$pkg' is not a subclass of 'Test2::Event'"
360             unless $pkg->isa('Test2::Event');
361 0            
362             $LOADED{$event} = $pkg;
363 0            
364             return $pkg;
365             }
366              
367             1;
368              
369             __END__