File Coverage

blib/lib/Test2/Hub.pm
Criterion Covered Total %
statement 247 249 99.2
branch 97 114 85.0
condition 86 117 73.5
subroutine 34 34 100.0
pod 20 26 76.9
total 484 540 89.6


line stmt bran cond sub pod time code
1             package Test2::Hub;
2 54     54   663 use strict;
  54         55  
  54         1139  
3 54     54   139 use warnings;
  54         52  
  54         1636  
4              
5             our $VERSION = '0.000042';
6              
7 54     54   167 use Carp qw/carp croak confess/;
  54         43  
  54         2317  
8 54     54   213 use Test2::Util qw/get_tid/;
  54         56  
  54         1749  
9              
10 54     54   173 use Scalar::Util qw/weaken/;
  54         48  
  54         1869  
11              
12 54     54   16413 use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/;
  54         73  
  54         3461  
13 54         240 use Test2::Util::HashBase qw{
14             pid tid hid ipc
15             no_ending
16             _filters
17             _pre_filters
18             _listeners
19             _follow_ups
20             _formatter
21             _context_acquire
22             _context_init
23             _context_release
24              
25             count
26             failed
27             ended
28             bailed_out
29             _passing
30             _plan
31             skip_reason
32 54     54   213 };
  54         51  
33              
34             my $ID_POSTFIX = 1;
35             sub init {
36 169     169 0 209 my $self = shift;
37              
38 169         454 $self->{+PID} = $$;
39 169         245 $self->{+TID} = get_tid();
40 169         554 $self->{+HID} = join '-', $self->{+PID}, $self->{+TID}, $ID_POSTFIX++;
41              
42 169         213 $self->{+COUNT} = 0;
43 169         193 $self->{+FAILED} = 0;
44 169         200 $self->{+_PASSING} = 1;
45              
46 169 100       361 if (my $formatter = delete $self->{formatter}) {
47 5         9 $self->format($formatter);
48             }
49              
50 169 100       427 if (my $ipc = $self->{+IPC}) {
51 12         40 $ipc->add_hub($self->{+HID});
52             }
53             }
54              
55             sub reset_state {
56 3     3 1 8 my $self = shift;
57              
58 3         9 $self->{+COUNT} = 0;
59 3         4 $self->{+FAILED} = 0;
60 3         3 $self->{+_PASSING} = 1;
61              
62 3         2 delete $self->{+_PLAN};
63 3         4 delete $self->{+ENDED};
64 3         3 delete $self->{+BAILED_OUT};
65 3         5 delete $self->{+SKIP_REASON};
66             }
67              
68             sub inherit {
69 59     59 0 50 my $self = shift;
70 59         84 my ($from, %params) = @_;
71              
72             $self->{+_FORMATTER} = $from->{+_FORMATTER}
73 59 100 33     245 unless $self->{+_FORMATTER} || exists($params{formatter});
74              
75 59 100 66     219 if ($from->{+IPC} && !$self->{+IPC} && !exists($params{ipc})) {
      100        
76 25         28 my $ipc = $from->{+IPC};
77 25         38 $self->{+IPC} = $ipc;
78 25         60 $ipc->add_hub($self->{+HID});
79             }
80              
81 59 100       201 if (my $ls = $from->{+_LISTENERS}) {
82 9         5 push @{$self->{+_LISTENERS}} => grep { $_->{inherit} } @$ls;
  9         21  
  9         13  
83             }
84              
85 59 100       168 if (my $fs = $from->{+_FILTERS}) {
86 12         9 push @{$self->{+_FILTERS}} => grep { $_->{inherit} } @$fs;
  12         42  
  6         27  
87             }
88             }
89              
90             sub format {
91 248     248 1 280 my $self = shift;
92              
93 248         259 my $old = $self->{+_FORMATTER};
94 248 100       556 ($self->{+_FORMATTER}) = @_ if @_;
95              
96 248         832 return $old;
97             }
98              
99             sub is_local {
100 6     6 0 7 my $self = shift;
101             return $$ == $self->{+PID}
102 6   66     39 && get_tid() == $self->{+TID};
103             }
104              
105             sub listen {
106 58     58 1 90 my $self = shift;
107 58         69 my ($sub, %params) = @_;
108              
109             carp "Useless addition of a listener in a child process or thread!"
110 58 50 33     308 if $$ != $self->{+PID} || get_tid() != $self->{+TID};
111              
112 58 100 66     443 croak "listen only takes coderefs for arguments, got '$sub'"
113             unless ref $sub && ref $sub eq 'CODE';
114              
115 57         49 push @{$self->{+_LISTENERS}} => { %params, code => $sub };
  57         169  
116              
117 57         99 $sub; # Intentional return.
118             }
119              
120             sub unlisten {
121 1     1 1 4 my $self = shift;
122              
123             carp "Useless removal of a listener in a child process or thread!"
124 1 50 33     10 if $$ != $self->{+PID} || get_tid() != $self->{+TID};
125              
126 1         3 my %subs = map {$_ => $_} @_;
  1         5  
127              
128 1         1 @{$self->{+_LISTENERS}} = grep { !$subs{$_->{code}} } @{$self->{+_LISTENERS}};
  1         4  
  2         5  
  1         3  
129             }
130              
131             sub filter {
132 11     11 1 57 my $self = shift;
133 11         17 my ($sub, %params) = @_;
134              
135             carp "Useless addition of a filter in a child process or thread!"
136 11 50 33     69 if $$ != $self->{+PID} || get_tid() != $self->{+TID};
137              
138 11 100 66     119 croak "filter only takes coderefs for arguments, got '$sub'"
139             unless ref $sub && ref $sub eq 'CODE';
140              
141 10         10 push @{$self->{+_FILTERS}} => { %params, code => $sub };
  10         36  
142              
143 10         20 $sub; # Intentional Return
144             }
145              
146             sub unfilter {
147 2     2 1 6 my $self = shift;
148             carp "Useless removal of a filter in a child process or thread!"
149 2 50 33     17 if $$ != $self->{+PID} || get_tid() != $self->{+TID};
150 2         4 my %subs = map {$_ => $_} @_;
  2         7  
151 2         3 @{$self->{+_FILTERS}} = grep { !$subs{$_->{code}} } @{$self->{+_FILTERS}};
  2         6  
  3         8  
  2         5  
152             }
153              
154             sub pre_filter {
155 4     4 1 35 my $self = shift;
156 4         5 my ($sub, %params) = @_;
157              
158 4 100 66     79 croak "pre_filter only takes coderefs for arguments, got '$sub'"
159             unless ref $sub && ref $sub eq 'CODE';
160              
161 3         3 push @{$self->{+_PRE_FILTERS}} => { %params, code => $sub };
  3         8  
162              
163 3         4 $sub; # Intentional Return
164             }
165              
166             sub pre_unfilter {
167 1     1 1 4 my $self = shift;
168 1         3 my %subs = map {$_ => $_} @_;
  1         3  
169 1         5 @{$self->{+_PRE_FILTERS}} = grep { !$subs{$_->{code}} } @{$self->{+_PRE_FILTERS}};
  1         3  
  2         5  
  1         1  
170             }
171              
172             sub follow_up {
173 4     4 0 42 my $self = shift;
174 4         6 my ($sub) = @_;
175              
176             carp "Useless addition of a follow-up in a child process or thread!"
177 4 50 33     16 if $$ != $self->{+PID} || get_tid() != $self->{+TID};
178              
179 4 100 66     228 croak "follow_up only takes coderefs for arguments, got '$sub'"
180             unless ref $sub && ref $sub eq 'CODE';
181              
182 2         2 push @{$self->{+_FOLLOW_UPS}} => $sub;
  2         6  
183             }
184              
185             *add_context_aquire = \&add_context_acquire;
186             sub add_context_acquire {
187 1     1 1 10 my $self = shift;
188 1         1 my ($sub) = @_;
189              
190 1 50 33     5 croak "add_context_acquire only takes coderefs for arguments, got '$sub'"
191             unless ref $sub && ref $sub eq 'CODE';
192              
193 1         1 push @{$self->{+_CONTEXT_ACQUIRE}} => $sub;
  1         2  
194              
195 1         2 $sub; # Intentional return.
196             }
197              
198             *remove_context_aquire = \&remove_context_acquire;
199             sub remove_context_acquire {
200 1     1 1 2 my $self = shift;
201 1         8 my %subs = map {$_ => $_} @_;
  1         3  
202 1         1 @{$self->{+_CONTEXT_ACQUIRE}} = grep { !$subs{$_} == $_ } @{$self->{+_CONTEXT_ACQUIRE}};
  1         2  
  1         3  
  1         2  
203             }
204              
205             sub add_context_init {
206 1     1 1 6 my $self = shift;
207 1         1 my ($sub) = @_;
208              
209 1 50 33     6 croak "add_context_init only takes coderefs for arguments, got '$sub'"
210             unless ref $sub && ref $sub eq 'CODE';
211              
212 1         2 push @{$self->{+_CONTEXT_INIT}} => $sub;
  1         3  
213              
214 1         2 $sub; # Intentional return.
215             }
216              
217             sub remove_context_init {
218 1     1 1 6 my $self = shift;
219 1         2 my %subs = map {$_ => $_} @_;
  1         3  
220 1         1 @{$self->{+_CONTEXT_INIT}} = grep { !$subs{$_} == $_ } @{$self->{+_CONTEXT_INIT}};
  1         3  
  1         3  
  1         2  
221             }
222              
223             sub add_context_release {
224 1     1 1 4 my $self = shift;
225 1         2 my ($sub) = @_;
226              
227 1 50 33     5 croak "add_context_release only takes coderefs for arguments, got '$sub'"
228             unless ref $sub && ref $sub eq 'CODE';
229              
230 1         1 push @{$self->{+_CONTEXT_RELEASE}} => $sub;
  1         2  
231              
232 1         2 $sub; # Intentional return.
233             }
234              
235             sub remove_context_release {
236 1     1 1 3 my $self = shift;
237 1         1 my %subs = map {$_ => $_} @_;
  1         3  
238 1         1 @{$self->{+_CONTEXT_RELEASE}} = grep { !$subs{$_} == $_ } @{$self->{+_CONTEXT_RELEASE}};
  1         2  
  1         3  
  1         2  
239             }
240              
241             sub send {
242 1224     1224 1 1711 my $self = shift;
243 1224         1003 my ($e) = @_;
244              
245 1224 100       1915 if ($self->{+_PRE_FILTERS}) {
246 6         3 for (@{$self->{+_PRE_FILTERS}}) {
  6         10  
247 8         12 $e = $_->{code}->($self, $e);
248 8 100       23 return unless $e;
249             }
250             }
251              
252 1221   100     2354 my $ipc = $self->{+IPC} || return $self->process($e);
253              
254 626 100       1532 if($e->global) {
255 1         4 $ipc->send($self->{+HID}, $e, 'GLOBAL');
256 1         5 return $self->process($e);
257             }
258              
259             return $ipc->send($self->{+HID}, $e)
260 625 100 66     2560 if $$ != $self->{+PID} || get_tid() != $self->{+TID};
261              
262 614         920 $self->process($e);
263             }
264              
265             sub process {
266 1232     1232 1 937 my $self = shift;
267 1232         923 my ($e) = @_;
268              
269 1232 100       1713 if ($self->{+_FILTERS}) {
270 18         16 for (@{$self->{+_FILTERS}}) {
  18         34  
271 17         26 $e = $_->{code}->($self, $e);
272 17 100       78 return unless $e;
273             }
274             }
275              
276 1223         1255 my $type = ref($e);
277 1223         1158 my $is_ok = $type eq 'Test2::Event::Ok';
278 1223   100     2816 my $no_fail = $type eq 'Test2::Event::Diag' || $type eq 'Test2::Event::Note';
279 1223 100       2224 my $causes_fail = $is_ok ? !$e->{effective_pass} : $no_fail ? 0 : $e->causes_fail;
    100          
280              
281 1223 100 100     2917 $self->{+COUNT}++ if $is_ok || (!$no_fail && $e->increments_count);
      66        
282 1223 100 100     1709 $self->{+FAILED}++ and $self->{+_PASSING} = 0 if $causes_fail;
283              
284 1223 100 100     2735 my $callback = $e->callback($self) unless $is_ok || $no_fail;
285              
286 1223         1282 my $count = $self->{+COUNT};
287              
288 1223 100       3212 $self->{+_FORMATTER}->write($e, $count) if $self->{+_FORMATTER};
289              
290 1223 100       3075 if ($self->{+_LISTENERS}) {
291 274         188 $_->{code}->($self, $e, $count) for @{$self->{+_LISTENERS}};
  274         884  
292             }
293              
294 1223 100 100     4112 return $e if $is_ok || $no_fail;
295              
296 162         468 my $code = $e->terminate;
297 162 100       385 $self->terminate($code, $e) if defined $code;
298              
299 157         345 return $e;
300             }
301              
302             sub terminate {
303 2     2 0 4 my $self = shift;
304 2         3 my ($code) = @_;
305 2         18 exit($code);
306             }
307              
308             sub cull {
309 139     139 1 149 my $self = shift;
310              
311 139   100     347 my $ipc = $self->{+IPC} || return;
312 69 100 66     401 return if $self->{+PID} != $$ || $self->{+TID} != get_tid();
313              
314             # No need to do IPC checks on culled events
315 63         207 $self->process($_) for $ipc->cull($self->{+HID});
316             }
317              
318             sub finalize {
319 108     108 0 144 my $self = shift;
320 108         141 my ($trace, $do_plan) = @_;
321              
322 108         243 $self->cull();
323              
324 108         170 my $plan = $self->{+_PLAN};
325 108         112 my $count = $self->{+COUNT};
326 108         119 my $failed = $self->{+FAILED};
327              
328             # return if NOTHING was done.
329 108 100 100     593 return unless $do_plan || defined($plan) || $count || $failed;
      100        
      100        
330              
331 94 100       224 unless ($self->{+ENDED}) {
332 91 100       196 if ($self->{+_FOLLOW_UPS}) {
333 2         2 $_->($trace, $self) for reverse @{$self->{+_FOLLOW_UPS}};
  2         10  
334             }
335              
336             # These need to be refreshed now
337 91         106 $plan = $self->{+_PLAN};
338 91         92 $count = $self->{+COUNT};
339 91         93 $failed = $self->{+FAILED};
340              
341 91 100 100     634 if (($plan && $plan eq 'NO PLAN') || ($do_plan && !$plan)) {
      66        
      66        
342 80         401 $self->send(
343             Test2::Event::Plan->new(
344             trace => $trace,
345             max => $count,
346             )
347             );
348             }
349 91         287 $plan = $self->{+_PLAN};
350             }
351              
352 94         220 my $frame = $trace->frame;
353 94 100       218 if($self->{+ENDED}) {
354 3         5 my (undef, $ffile, $fline) = @{$self->{+ENDED}};
  3         8  
355 3         5 my (undef, $sfile, $sline) = @$frame;
356              
357 3         15 die <<" EOT"
358             Test already ended!
359             First End: $ffile line $fline
360             Second End: $sfile line $sline
361             EOT
362             }
363              
364 91         120 $self->{+ENDED} = $frame;
365 91         220 $self->is_passing(); # Generate the final boolean.
366             }
367              
368             sub is_passing {
369 203     203 1 190 my $self = shift;
370              
371 203 100       329 ($self->{+_PASSING}) = @_ if @_;
372              
373             # If we already failed just return 0.
374 203   100     367 my $pass = $self->{+_PASSING} || return 0;
375 191 100       302 return $self->{+_PASSING} = 0 if $self->{+FAILED};
376              
377 183         171 my $count = $self->{+COUNT};
378 183         180 my $ended = $self->{+ENDED};
379 183         174 my $plan = $self->{+_PLAN};
380              
381 183 100 100     435 return $pass if !$count && $plan && $plan =~ m/^SKIP$/;
      66        
382              
383 181 100 100     780 return $self->{+_PASSING} = 0
      100        
384             if $ended && (!$count || !$plan);
385              
386 171 100 66     718 return $pass unless $plan && $plan =~ m/^\d+$/;
387              
388 106 50       178 if ($ended) {
389 106 50       206 return $self->{+_PASSING} = 0 if $count != $plan;
390             }
391             else {
392 0 0       0 return $self->{+_PASSING} = 0 if $count > $plan;
393             }
394              
395 106         213 return $pass;
396             }
397              
398             sub plan {
399 115     115 1 135 my $self = shift;
400              
401 115 100       271 return $self->{+_PLAN} unless @_;
402              
403 106         220 my ($plan) = @_;
404              
405 106 50       216 confess "You cannot unset the plan"
406             unless defined $plan;
407              
408             confess "You cannot change the plan"
409 106 100 100     386 if $self->{+_PLAN} && $self->{+_PLAN} !~ m/^NO PLAN$/;
410              
411 105 100       516 confess "'$plan' is not a valid plan! Plan must be an integer greater than 0, 'NO PLAN', or 'SKIP'"
412             unless $plan =~ m/^(\d+|NO PLAN|SKIP)$/;
413              
414 104         264 $self->{+_PLAN} = $plan;
415             }
416              
417             sub check_plan {
418 39     39 1 24 my $self = shift;
419              
420 39 50       71 return undef unless $self->{+ENDED};
421 39   100     64 my $plan = $self->{+_PLAN} || return undef;
422              
423 31 50       94 return 1 if $plan !~ m/^\d+$/;
424              
425 31 50       85 return 1 if $plan == $self->{+COUNT};
426 0         0 return 0;
427             }
428              
429             sub DESTROY {
430 113     113   734 my $self = shift;
431 113   100     789 my $ipc = $self->{+IPC} || return;
432 51 100       206 return unless $$ == $self->{+PID};
433 50 50       537 return unless get_tid() == $self->{+TID};
434              
435 50         154 $ipc->drop_hub($self->{+HID});
436             }
437              
438             1;
439              
440             __END__