File Coverage

blib/lib/Test2/API/Instance.pm
Criterion Covered Total %
statement 242 254 95.2
branch 92 118 77.9
condition 36 58 62.0
subroutine 36 37 97.3
pod 15 17 88.2
total 421 484 86.9


line stmt bran cond sub pod time code
1             package Test2::API::Instance;
2 59     59   894 use strict;
  54         50  
  54         1137  
3 54     54   142 use warnings;
  54         48  
  54         2280  
4              
5             our $VERSION = '0.000042';
6              
7             our @CARP_NOT = qw/Test2::API Test2::API::Instance Test2::IPC::Driver Test2::Formatter/;
8 54     54   185 use Carp qw/confess carp/;
  54         58  
  54         2660  
9 54     54   183 use Scalar::Util qw/reftype/;
  54         56  
  54         2759  
10              
11 54     54   7167 use Test2::Util qw/get_tid USE_THREADS CAN_FORK pkg_to_file try/;
  54         81  
  54         2491  
12              
13 54     54   16794 use Test2::Util::Trace();
  54         67  
  54         736  
14 54     54   16762 use Test2::API::Stack();
  54         78  
  54         1569  
15              
16 54         176 use Test2::Util::HashBase qw{
17             pid tid
18             no_wait
19             finalized loaded
20             ipc stack formatter
21             contexts
22              
23             ipc_shm_size
24             ipc_shm_last
25             ipc_shm_id
26             ipc_polling
27             ipc_drivers
28             formatters
29              
30             exit_callbacks
31             post_load_callbacks
32             context_acquire_callbacks
33             context_init_callbacks
34             context_release_callbacks
35 54     54   213 };
  54         52  
36              
37             # Wrap around the getters that should call _finalize.
38             BEGIN {
39 54     54   99 for my $finalizer (IPC, FORMATTER) {
40 108         902 my $orig = __PACKAGE__->can($finalizer);
41             my $new = sub {
42 201     201   300 my $self = shift;
43 201 100       520 $self->_finalize unless $self->{+FINALIZED};
44 195         519 $self->$orig;
45 108         1819 };
46              
47 54     54   247 no strict 'refs';
  54         58  
  54         1250  
48 54     54   157 no warnings 'redefine';
  54         51  
  54         1897  
49 108         91 *{$finalizer} = $new;
  108         111045  
50             }
51             }
52              
53             sub import {
54 74     74   2229 my $class = shift;
55 74 100       565 return unless @_;
56 54         647 my ($ref) = @_;
57 54         133 $$ref = $class->new;
58             }
59              
60 59     59 0 119 sub init { $_[0]->reset }
61              
62             sub reset {
63 148     148 1 1070 my $self = shift;
64              
65 148         655 $self->{+PID} = $$;
66 148         164 $self->{+TID} = get_tid();
67 148         220 $self->{+CONTEXTS} = {};
68              
69 148         201 $self->{+IPC_DRIVERS} = [];
70 148         173 $self->{+IPC_POLLING} = undef;
71              
72 148         142 $self->{+FORMATTERS} = [];
73 148         137 $self->{+FORMATTER} = undef;
74              
75 148         532 $self->{+FINALIZED} = undef;
76 148         160 $self->{+IPC} = undef;
77              
78 148         171 $self->{+NO_WAIT} = 0;
79 148         148 $self->{+LOADED} = 0;
80              
81 148         170 $self->{+EXIT_CALLBACKS} = [];
82 148         158 $self->{+POST_LOAD_CALLBACKS} = [];
83 148         151 $self->{+CONTEXT_ACQUIRE_CALLBACKS} = [];
84 148         149 $self->{+CONTEXT_INIT_CALLBACKS} = [];
85 148         292 $self->{+CONTEXT_RELEASE_CALLBACKS} = [];
86              
87 148         615 $self->{+STACK} = Test2::API::Stack->new;
88             }
89              
90             sub _finalize {
91 91     91   216 my $self = shift;
92 91         135 my ($caller) = @_;
93 91   50     909 $caller ||= [caller(1)];
94              
95 91         152 $self->{+FINALIZED} = $caller;
96              
97 91 100       226 unless ($self->{+FORMATTER}) {
98 86         98 my ($formatter, $source);
99 86 100       227 if ($ENV{T2_FORMATTER}) {
    100          
100 15         10 $source = "set by the 'T2_FORMATTER' environment variable";
101              
102 15 50       70 if ($ENV{T2_FORMATTER} =~ m/^(\+)?(.*)$/) {
103 15 100       55 $formatter = $1 ? $2 : "Test2::Formatter::$2"
104             }
105             else {
106 0         0 $formatter = '';
107             }
108             }
109 71         206 elsif (@{$self->{+FORMATTERS}}) {
110 1         1 ($formatter) = @{$self->{+FORMATTERS}};
  1         3  
111 1         1 $source = "Most recently added";
112             }
113             else {
114 70         131 $formatter = 'Test2::Formatter::TAP';
115 70         102 $source = 'default formatter';
116             }
117              
118 86 100 66     952 unless (ref($formatter) || $formatter->can('write')) {
119 57         229 my $file = pkg_to_file($formatter);
120 57     57   285 my ($ok, $err) = try { require $file };
  57         21740  
121 57 100       279 unless ($ok) {
122 5         15 my $line = "* COULD NOT LOAD FORMATTER '$formatter' ($source) *";
123 5         10 my $border = '*' x length($line);
124 5         30 die "\n\n $border\n $line\n $border\n\n$err";
125             }
126             }
127              
128 81         176 $self->{+FORMATTER} = $formatter;
129             }
130              
131             # Turn on IPC if threads are on, drivers are reigstered, or the Test2::IPC
132             # module is loaded.
133 86 100 100     263 return unless USE_THREADS || $INC{'Test2/IPC.pm'} || @{$self->{+IPC_DRIVERS}};
  37         200  
134              
135             # Turn on polling by default, people expect it.
136 52         143 $self->enable_ipc_polling;
137              
138 52 100       41 unless (@{$self->{+IPC_DRIVERS}}) {
  52         126  
139 49     49   239 my ($ok, $error) = try { require Test2::IPC::Driver::Files };
  49         8135  
140 49 50       168 die $error unless $ok;
141 49         44 push @{$self->{+IPC_DRIVERS}} => 'Test2::IPC::Driver::Files';
  49         128  
142             }
143              
144 52         70 for my $driver (@{$self->{+IPC_DRIVERS}}) {
  52         97  
145 52 100 66     554 next unless $driver->can('is_viable') && $driver->is_viable;
146 51 50       177 $self->{+IPC} = $driver->new or next;
147 51 50       131 $self->ipc_enable_shm if $self->{+IPC}->use_shm;
148 51         71 return;
149             }
150              
151 1         6 die "IPC has been requested, but no viable drivers were found. Aborting...\n";
152             }
153              
154 11 100   11 1 142 sub formatter_set { $_[0]->{+FORMATTER} ? 1 : 0 }
155              
156             sub add_formatter {
157 1     1 1 1 my $self = shift;
158 1         1 my ($formatter) = @_;
159 1         1 unshift @{$self->{+FORMATTERS}} => $formatter;
  1         3  
160              
161 1 50       22 return unless $self->{+FINALIZED};
162              
163             # Why is the @CARP_NOT entry not enough?
164 0         0 local %Carp::Internal = %Carp::Internal;
165 0         0 $Carp::Internal{'Test2::Formatter'} = 1;
166              
167 0         0 carp "Formatter $formatter loaded too late to be used as the global formatter";
168             }
169              
170             sub add_context_acquire_callback {
171 3     3 0 3 my $self = shift;
172 3         3 my ($code) = @_;
173              
174 3   50     11 my $rtype = reftype($code) || "";
175              
176 3 50 33     15 confess "Context-acquire callbacks must be coderefs"
177             unless $code && $rtype eq 'CODE';
178              
179 3         4 push @{$self->{+CONTEXT_ACQUIRE_CALLBACKS}} => $code;
  3         6  
180             }
181              
182             sub add_context_init_callback {
183 56     56 1 53 my $self = shift;
184 56         54 my ($code) = @_;
185              
186 56   50     318 my $rtype = reftype($code) || "";
187              
188 56 50 33     248 confess "Context-init callbacks must be coderefs"
189             unless $code && $rtype eq 'CODE';
190              
191 56         56 push @{$self->{+CONTEXT_INIT_CALLBACKS}} => $code;
  56         117  
192             }
193              
194             sub add_context_release_callback {
195 4     4 1 6 my $self = shift;
196 4         5 my ($code) = @_;
197              
198 4   50     18 my $rtype = reftype($code) || "";
199              
200 4 50 33     22 confess "Context-release callbacks must be coderefs"
201             unless $code && $rtype eq 'CODE';
202              
203 4         4 push @{$self->{+CONTEXT_RELEASE_CALLBACKS}} => $code;
  4         12  
204             }
205              
206             sub add_post_load_callback {
207 18     18 1 57 my $self = shift;
208 18         24 my ($code) = @_;
209              
210 18   50     62 my $rtype = reftype($code) || "";
211              
212 18 100 66     715 confess "Post-load callbacks must be coderefs"
213             unless $code && $rtype eq 'CODE';
214              
215 13         13 push @{$self->{+POST_LOAD_CALLBACKS}} => $code;
  13         24  
216 13 100       38 $code->() if $self->{+LOADED};
217             }
218              
219             sub load {
220 64     64 1 104 my $self = shift;
221 64 100       192 unless ($self->{+LOADED}) {
222             # This is for https://github.com/Test-More/Test2/issues/16
223             # and https://rt.perl.org/Public/Bug/Display.html?id=127774
224             # END blocks run in reverse order. This insures the END block is loaded
225             # as late as possible. It will not solve all cases, but it helps.
226 52 50   52   6789 eval "END { Test2::API->_set_is_end() }; 1" or die $@;
  59         3361  
227              
228 59         218 $self->{+LOADED} = 1;
229 59         84 $_->() for @{$self->{+POST_LOAD_CALLBACKS}};
  59         212  
230             }
231 64         139 return $self->{+LOADED};
232             }
233              
234             sub add_exit_callback {
235 18     18 1 64 my $self = shift;
236 18         16 my ($code) = @_;
237 18   50     64 my $rtype = reftype($code) || "";
238              
239 18 100 66     565 confess "End callbacks must be coderefs"
240             unless $code && $rtype eq 'CODE';
241              
242 13         12 push @{$self->{+EXIT_CALLBACKS}} => $code;
  13         21  
243             }
244              
245             sub add_ipc_driver {
246 5     5 1 18 my $self = shift;
247 5         7 my ($driver) = @_;
248 5         5 unshift @{$self->{+IPC_DRIVERS}} => $driver;
  5         12  
249              
250 5 100       38 return unless $self->{+FINALIZED};
251              
252             # Why is the @CARP_NOT entry not enough?
253 2         9 local %Carp::Internal = %Carp::Internal;
254 2         3 $Carp::Internal{'Test2::IPC::Driver'} = 1;
255              
256 2         366 carp "IPC driver $driver loaded too late to be used as the global ipc driver";
257             }
258              
259             sub enable_ipc_polling {
260 55     55 1 66 my $self = shift;
261              
262             $self->add_context_init_callback(
263             # This is called every time a context is created, it needs to be fast.
264             # $_[0] is a context object
265             sub {
266 584 100   584   997 return unless $self->{+IPC_POLLING};
267 582 100       853 return $_[0]->{hub}->cull unless $self->{+IPC_SHM_ID};
268              
269 572         436 my $val;
270             {
271 572 50       397 shmread($self->{+IPC_SHM_ID}, $val, 0, $self->{+IPC_SHM_SIZE}) or return;
  572         9122  
272              
273 572 100       2611 return if $val eq $self->{+IPC_SHM_LAST};
274 8         30 $self->{+IPC_SHM_LAST} = $val;
275             }
276              
277 8         45 $_[0]->{hub}->cull;
278             }
279 55 100       155 ) unless defined $self->ipc_polling;
280              
281 55         150 $self->set_ipc_polling(1);
282             }
283              
284             sub ipc_enable_shm {
285 51     51 1 59 my $self = shift;
286              
287 51 100       136 return 1 if defined $self->{+IPC_SHM_ID};
288              
289             my ($ok, $err) = try {
290 26     26   8807 require IPC::SysV;
291              
292 26         16546 my $ipc_key = IPC::SysV::IPC_PRIVATE();
293 26 50       523 my $shm_size = $self->{+IPC}->can('shm_size') ? $self->{+IPC}->shm_size : 64;
294 26 100       584 my $shm_id = shmget($ipc_key, $shm_size, 0666) or die;
295              
296 22         59 my $initial = 'a' x $shm_size;
297 22 50       564 shmwrite($shm_id, $initial, 0, $shm_size) or die;
298              
299 22         48 $self->{+IPC_SHM_SIZE} = $shm_size;
300 22         36 $self->{+IPC_SHM_ID} = $shm_id;
301 22         74 $self->{+IPC_SHM_LAST} = $initial;
302 26         156 };
303              
304 26         140 return $ok;
305             }
306              
307             sub get_ipc_pending {
308 0     0 1 0 my $self = shift;
309 0 0       0 return -1 unless defined $self->{+IPC_SHM_ID};
310 0         0 my $val;
311 0 0       0 shmread($self->{+IPC_SHM_ID}, $val, 0, $self->{+IPC_SHM_SIZE}) or return -1;
312 0 0       0 return 0 if $val eq $self->{+IPC_SHM_LAST};
313 0         0 $self->{+IPC_SHM_LAST} = $val;
314 0         0 return 1;
315             }
316              
317             sub set_ipc_pending {
318 32     32 1 57 my $self = shift;
319              
320 32 100       123 return undef unless defined $self->{+IPC_SHM_ID};
321              
322 19         27 my ($val) = @_;
323              
324 19 50       41 confess "value is required for set_ipc_pending"
325             unless $val;
326              
327 19         342 shmwrite($self->{+IPC_SHM_ID}, $val, 0, $self->{+IPC_SHM_SIZE});
328             }
329              
330             sub disable_ipc_polling {
331 3     3 1 7 my $self = shift;
332 3 100       8 return unless defined $self->{+IPC_POLLING};
333 2         4 $self->{+IPC_POLLING} = 0;
334             }
335              
336             sub _ipc_wait {
337 22     22   2498 my $fail = 0;
338              
339 22         57 while (CAN_FORK) {
340 36         14932318 my $pid = CORE::wait();
341 36         138 my $err = $?;
342 36 100       164 last if $pid == -1;
343 14 100       88 next unless $err;
344 6         21 $fail++;
345 6         16 $err = $err >> 8;
346 6         237 warn "Process $pid did not exit cleanly (status: $err)\n";
347             }
348              
349 22         42 if (USE_THREADS) {
350             for my $t (threads->list()) {
351             $t->join;
352             # In older threads we cannot check if a thread had an error unless
353             # we control it and its return.
354             my $err = $t->can('error') ? $t->error : undef;
355             next unless $err;
356             my $tid = $t->tid();
357             $fail++;
358             chomp($err);
359             warn "Thread $tid did not end cleanly: $err\n";
360             }
361             }
362              
363 22 100       134 return 0 unless $fail;
364 6         43 return 255;
365             }
366              
367             sub set_exit {
368 82     82 1 247 my $self = shift;
369              
370 82         137 my $exit = $?;
371 82         109 my $new_exit = $exit;
372              
373 82         99 for my $ctx (values %{$self->{+CONTEXTS}}) {
  82         319  
374 5 100       21 next unless $ctx;
375              
376 1 50 33     12 next if $ctx->_aborted && ${$ctx->_aborted};
  0         0  
377              
378             # Only worry about contexts in this PID
379 1   50     5 my $trace = $ctx->trace || next;
380 1 50       7 next unless $trace->pid == $$;
381              
382             # Do not worry about contexts that have no hub
383 1   50     4 my $hub = $ctx->hub || next;
384              
385             # Do not worry if the state came to a sudden end.
386 1 50       4 next if $hub->bailed_out;
387 1 50       5 next if defined $hub->skip_reason;
388              
389             # now we worry
390 1         5 $trace->alert("context object was never released! This means a testing tool is behaving very badly");
391              
392 1         6 $exit = 255;
393 1         3 $new_exit = 255;
394             }
395              
396 82 100 100     594 if ($self->{+PID} != $$ or $self->{+TID} != get_tid()) {
397 13         24 $? = $exit;
398 13         6 return;
399             }
400              
401 69 50       363 my @hubs = $self->{+STACK} ? $self->{+STACK}->all : ();
402              
403 69 100 66     415 if (@hubs and $self->{+IPC} and !$self->{+NO_WAIT}) {
      66        
404 15         39 local $?;
405 15         29 my %seen;
406 15         32 for my $hub (reverse @hubs) {
407 15 50       68 my $ipc = $hub->ipc or next;
408 15 50       281 next if $seen{$ipc}++;
409 15         73 $ipc->waiting();
410             }
411              
412 15         41 my $ipc_exit = _ipc_wait();
413 15   100     118 $new_exit ||= $ipc_exit;
414             }
415              
416             # None of this is necessary if we never got a root hub
417 69 100       207 if(my $root = shift @hubs) {
418 63         417 my $trace = Test2::Util::Trace->new(
419             frame => [__PACKAGE__, __FILE__, 0, __PACKAGE__ . '::END'],
420             detail => __PACKAGE__ . ' END Block finalization',
421             );
422 63         253 my $ctx = Test2::API::Context->new(
423             trace => $trace,
424             hub => $root,
425             );
426              
427 63 100       181 if (@hubs) {
428 6         27 $ctx->diag("Test ended with extra hubs on the stack!");
429 6         12 $new_exit = 255;
430             }
431              
432 63 100       212 unless ($root->no_ending) {
433 60         154 local $?;
434 60 100       177 $root->finalize($trace) unless $root->ended;
435 60         88 $_->($ctx, $exit, \$new_exit) for @{$self->{+EXIT_CALLBACKS}};
  60         233  
436 60   100     374 $new_exit ||= $root->failed;
437             }
438             }
439              
440 69 100       195 $new_exit = 255 if $new_exit > 255;
441              
442 69         57 $? = $new_exit;
443             }
444              
445             1;
446              
447             __END__