File Coverage

inc/Test2/API/Instance.pm
Criterion Covered Total %
statement 128 285 44.9
branch 28 152 18.4
condition 15 86 17.4
subroutine 22 41 53.6
pod 17 20 85.0
total 210 584 35.9


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