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__ |