line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Test2::IPC::Driver::Files; |
2
|
22
|
|
|
22
|
|
889
|
use strict; |
|
22
|
|
|
|
|
30
|
|
|
22
|
|
|
|
|
514
|
|
3
|
22
|
|
|
22
|
|
63
|
use warnings; |
|
22
|
|
|
|
|
21
|
|
|
22
|
|
|
|
|
684
|
|
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
our $VERSION = '0.000042'; |
6
|
|
|
|
|
|
|
|
7
|
22
|
|
|
22
|
|
62
|
use base 'Test2::IPC::Driver'; |
|
22
|
|
|
|
|
21
|
|
|
22
|
|
|
|
|
8526
|
|
8
|
|
|
|
|
|
|
|
9
|
22
|
|
|
22
|
|
83
|
use Test2::Util::HashBase qw{tempdir event_id tid pid globals}; |
|
22
|
|
|
|
|
29
|
|
|
22
|
|
|
|
|
62
|
|
10
|
|
|
|
|
|
|
|
11
|
22
|
|
|
22
|
|
80
|
use Scalar::Util qw/blessed/; |
|
22
|
|
|
|
|
28
|
|
|
22
|
|
|
|
|
811
|
|
12
|
22
|
|
|
22
|
|
13236
|
use File::Temp(); |
|
22
|
|
|
|
|
254437
|
|
|
22
|
|
|
|
|
423
|
|
13
|
22
|
|
|
22
|
|
11152
|
use Storable(); |
|
22
|
|
|
|
|
46875
|
|
|
22
|
|
|
|
|
454
|
|
14
|
22
|
|
|
22
|
|
99
|
use File::Spec(); |
|
22
|
|
|
|
|
22
|
|
|
22
|
|
|
|
|
342
|
|
15
|
|
|
|
|
|
|
|
16
|
22
|
|
|
22
|
|
61
|
use Test2::Util qw/try get_tid pkg_to_file/; |
|
22
|
|
|
|
|
22
|
|
|
22
|
|
|
|
|
997
|
|
17
|
22
|
|
|
22
|
|
74
|
use Test2::API qw/test2_ipc_set_pending/; |
|
22
|
|
|
|
|
30
|
|
|
22
|
|
|
|
|
31245
|
|
18
|
|
|
|
|
|
|
|
19
|
51
|
|
|
51
|
1
|
180
|
sub use_shm { 1 } |
20
|
26
|
|
|
26
|
1
|
48
|
sub shm_size { 64 } |
21
|
|
|
|
|
|
|
|
22
|
51
|
|
|
51
|
1
|
184
|
sub is_viable { 1 } |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
sub init { |
25
|
72
|
|
|
72
|
0
|
69
|
my $self = shift; |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
my $tmpdir = File::Temp::tempdir( |
28
|
72
|
|
33
|
|
|
498
|
$ENV{T2_TEMPDIR_TEMPLATE} || "test2-$$-XXXXXX", |
29
|
|
|
|
|
|
|
CLEANUP => 0, |
30
|
|
|
|
|
|
|
TMPDIR => 1, |
31
|
|
|
|
|
|
|
); |
32
|
|
|
|
|
|
|
|
33
|
72
|
50
|
|
|
|
543312
|
$self->abort_trace("Could not get a temp dir") unless $tmpdir; |
34
|
|
|
|
|
|
|
|
35
|
72
|
|
|
|
|
365
|
$self->{+TEMPDIR} = File::Spec->canonpath($tmpdir); |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
print STDERR "\nIPC Temp Dir: $tmpdir\n\n" |
38
|
72
|
100
|
|
|
|
175
|
if $ENV{T2_KEEP_TEMPDIR}; |
39
|
|
|
|
|
|
|
|
40
|
72
|
|
|
|
|
99
|
$self->{+EVENT_ID} = 1; |
41
|
|
|
|
|
|
|
|
42
|
72
|
|
|
|
|
88
|
$self->{+TID} = get_tid(); |
43
|
72
|
|
|
|
|
134
|
$self->{+PID} = $$; |
44
|
|
|
|
|
|
|
|
45
|
72
|
|
|
|
|
102
|
$self->{+GLOBALS} = {}; |
46
|
|
|
|
|
|
|
|
47
|
72
|
|
|
|
|
139
|
return $self; |
48
|
|
|
|
|
|
|
} |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
sub hub_file { |
51
|
178
|
|
|
178
|
0
|
169
|
my $self = shift; |
52
|
178
|
|
|
|
|
168
|
my ($hid) = @_; |
53
|
178
|
|
|
|
|
195
|
my $tdir = $self->{+TEMPDIR}; |
54
|
178
|
|
|
|
|
1105
|
return File::Spec->canonpath("$tdir/HUB-$hid"); |
55
|
|
|
|
|
|
|
} |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
sub event_file { |
58
|
35
|
|
|
35
|
0
|
755
|
my $self = shift; |
59
|
35
|
|
|
|
|
51
|
my ($hid, $e) = @_; |
60
|
|
|
|
|
|
|
|
61
|
35
|
|
|
|
|
57
|
my $tempdir = $self->{+TEMPDIR}; |
62
|
35
|
100
|
|
|
|
184
|
my $type = blessed($e) or $self->abort("'$e' is not a blessed object!"); |
63
|
|
|
|
|
|
|
|
64
|
34
|
100
|
|
|
|
243
|
$self->abort("'$e' is not an event object!") |
65
|
|
|
|
|
|
|
unless $type->isa('Test2::Event'); |
66
|
|
|
|
|
|
|
|
67
|
33
|
|
|
|
|
136
|
my @type = split '::', $type; |
68
|
33
|
|
|
|
|
167
|
my $name = join('-', $hid, $$, get_tid(), $self->{+EVENT_ID}++, @type); |
69
|
|
|
|
|
|
|
|
70
|
33
|
|
|
|
|
152
|
return File::Spec->canonpath("$tempdir/$name"); |
71
|
|
|
|
|
|
|
} |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
sub add_hub { |
74
|
85
|
|
|
85
|
1
|
105
|
my $self = shift; |
75
|
85
|
|
|
|
|
132
|
my ($hid) = @_; |
76
|
|
|
|
|
|
|
|
77
|
85
|
|
|
|
|
142
|
my $hfile = $self->hub_file($hid); |
78
|
|
|
|
|
|
|
|
79
|
85
|
100
|
|
|
|
1565
|
$self->abort_trace("File for hub '$hid' already exists") |
80
|
|
|
|
|
|
|
if -e $hfile; |
81
|
|
|
|
|
|
|
|
82
|
84
|
50
|
|
|
|
3861
|
open(my $fh, '>', $hfile) or $self->abort_trace("Could not create hub file '$hid': $!"); |
83
|
84
|
|
|
|
|
724
|
print $fh "$$\n" . get_tid() . "\n"; |
84
|
84
|
|
|
|
|
2529
|
close($fh); |
85
|
|
|
|
|
|
|
} |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
sub drop_hub { |
88
|
56
|
|
|
56
|
1
|
75
|
my $self = shift; |
89
|
56
|
|
|
|
|
67
|
my ($hid) = @_; |
90
|
|
|
|
|
|
|
|
91
|
56
|
|
|
|
|
69
|
my $tdir = $self->{+TEMPDIR}; |
92
|
56
|
|
|
|
|
117
|
my $hfile = $self->hub_file($hid); |
93
|
|
|
|
|
|
|
|
94
|
56
|
100
|
|
|
|
782
|
$self->abort_trace("File for hub '$hid' does not exist") |
95
|
|
|
|
|
|
|
unless -e $hfile; |
96
|
|
|
|
|
|
|
|
97
|
55
|
50
|
|
|
|
1165
|
open(my $fh, '<', $hfile) or $self->abort_trace("Could not open hub file '$hid': $!"); |
98
|
55
|
|
|
|
|
649
|
my ($pid, $tid) = <$fh>; |
99
|
55
|
|
|
|
|
268
|
close($fh); |
100
|
|
|
|
|
|
|
|
101
|
55
|
50
|
|
|
|
187
|
$self->abort_trace("A hub file can only be closed by the process that started it\nExpected $pid, got $$") |
102
|
|
|
|
|
|
|
unless $pid == $$; |
103
|
|
|
|
|
|
|
|
104
|
55
|
50
|
|
|
|
94
|
$self->abort_trace("A hub file can only be closed by the thread that started it\nExpected $tid, got " . get_tid()) |
105
|
|
|
|
|
|
|
unless get_tid() == $tid; |
106
|
|
|
|
|
|
|
|
107
|
55
|
100
|
|
|
|
123
|
if ($ENV{T2_KEEP_TEMPDIR}) { |
108
|
1
|
50
|
|
|
|
36
|
rename($hfile, File::Spec->canonpath("$hfile.complete")) or $self->abort_trace("Could not rename file '$hfile' -> '$hfile.complete'"); |
109
|
|
|
|
|
|
|
} |
110
|
|
|
|
|
|
|
else { |
111
|
54
|
50
|
|
|
|
2430
|
unlink($hfile) or $self->abort_trace("Could not remove file for hub '$hid'"); |
112
|
|
|
|
|
|
|
} |
113
|
|
|
|
|
|
|
|
114
|
55
|
50
|
|
|
|
885
|
opendir(my $dh, $tdir) or $self->abort_trace("Could not open temp dir!"); |
115
|
55
|
|
|
|
|
631
|
for my $file (readdir($dh)) { |
116
|
173
|
100
|
|
|
|
297
|
next if $file =~ m{\.complete$}; |
117
|
171
|
100
|
|
|
|
991
|
next unless $file =~ m{^$hid}; |
118
|
1
|
|
|
|
|
5
|
$self->abort_trace("Not all files from hub '$hid' have been collected!"); |
119
|
|
|
|
|
|
|
} |
120
|
54
|
|
|
|
|
3447
|
closedir($dh); |
121
|
|
|
|
|
|
|
} |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
sub send { |
124
|
37
|
|
|
37
|
1
|
129
|
my $self = shift; |
125
|
37
|
|
|
|
|
99
|
my ($hid, $e, $global) = @_; |
126
|
|
|
|
|
|
|
|
127
|
37
|
|
|
|
|
94
|
my $tempdir = $self->{+TEMPDIR}; |
128
|
37
|
|
|
|
|
271
|
my $hfile = $self->hub_file($hid); |
129
|
37
|
100
|
|
|
|
148
|
my $dest = $global ? 'GLOBAL' : $hid; |
130
|
|
|
|
|
|
|
|
131
|
37
|
100
|
100
|
|
|
556
|
$self->abort(<<" EOT") unless $global || -f $hfile; |
132
|
|
|
|
|
|
|
hub '$hid' is not available, failed to send event! |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
There was an attempt to send an event to a hub in a parent process or thread, |
135
|
|
|
|
|
|
|
but that hub appears to be gone. This can happen if you fork, or start a new |
136
|
|
|
|
|
|
|
thread from inside subtest, and the parent finishes the subtest before the |
137
|
|
|
|
|
|
|
child returns. |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
This can also happen if the parent process is done testing before the child |
140
|
|
|
|
|
|
|
finishes. Test2 normally waits automatically in the root process, but will not |
141
|
|
|
|
|
|
|
do so if Test::Builder is loaded for legacy reasons. |
142
|
|
|
|
|
|
|
EOT |
143
|
|
|
|
|
|
|
|
144
|
35
|
|
|
|
|
112
|
my $file = $self->event_file($dest, $e); |
145
|
33
|
|
|
|
|
89
|
my $ready = File::Spec->canonpath("$file.ready"); |
146
|
|
|
|
|
|
|
|
147
|
33
|
100
|
|
|
|
84
|
if ($global) { |
148
|
18
|
|
|
|
|
17
|
my $name = $ready; |
149
|
18
|
|
|
|
|
119
|
$name =~ s{^.*(GLOBAL)}{GLOBAL}; |
150
|
18
|
|
|
|
|
60
|
$self->{+GLOBALS}->{$hid}->{$name}++; |
151
|
|
|
|
|
|
|
} |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
my ($ok, $err) = try { |
154
|
33
|
|
|
33
|
|
172
|
Storable::store($e, $file); |
155
|
32
|
50
|
|
|
|
8023
|
rename($file, $ready) or $self->abort("Could not rename file '$file' -> '$ready'"); |
156
|
32
|
|
|
|
|
260
|
test2_ipc_set_pending($file); |
157
|
33
|
|
|
|
|
353
|
}; |
158
|
33
|
100
|
|
|
|
191
|
if (!$ok) { |
159
|
1
|
|
|
|
|
2
|
my $src_file = __FILE__; |
160
|
1
|
|
|
|
|
16
|
$err =~ s{ at \Q$src_file\E.*$}{}; |
161
|
1
|
|
|
|
|
2
|
chomp($err); |
162
|
1
|
|
|
|
|
1
|
my $tid = get_tid(); |
163
|
1
|
|
|
|
|
5
|
my $trace = $e->trace->debug; |
164
|
1
|
|
|
|
|
18
|
my $type = blessed($e); |
165
|
|
|
|
|
|
|
|
166
|
1
|
|
|
|
|
7
|
$self->abort(<<" EOT"); |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
******************************************************************************* |
169
|
|
|
|
|
|
|
There was an error writing an event: |
170
|
|
|
|
|
|
|
Destination: $dest |
171
|
|
|
|
|
|
|
Origin PID: $$ |
172
|
|
|
|
|
|
|
Origin TID: $tid |
173
|
|
|
|
|
|
|
Event Type: $type |
174
|
|
|
|
|
|
|
Event Trace: $trace |
175
|
|
|
|
|
|
|
File Name: $file |
176
|
|
|
|
|
|
|
Ready Name: $ready |
177
|
|
|
|
|
|
|
Error: $err |
178
|
|
|
|
|
|
|
******************************************************************************* |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
EOT |
181
|
|
|
|
|
|
|
} |
182
|
|
|
|
|
|
|
|
183
|
32
|
|
|
|
|
69
|
return 1; |
184
|
|
|
|
|
|
|
} |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
sub cull { |
187
|
69
|
|
|
69
|
1
|
79
|
my $self = shift; |
188
|
69
|
|
|
|
|
75
|
my ($hid) = @_; |
189
|
|
|
|
|
|
|
|
190
|
69
|
|
|
|
|
79
|
my $tempdir = $self->{+TEMPDIR}; |
191
|
|
|
|
|
|
|
|
192
|
69
|
50
|
|
|
|
1830
|
opendir(my $dh, $tempdir) or $self->abort("could not open IPC temp dir ($tempdir)!"); |
193
|
|
|
|
|
|
|
|
194
|
69
|
|
|
|
|
70
|
my @out; |
195
|
69
|
|
|
|
|
1246
|
for my $file (sort readdir($dh)) { |
196
|
296
|
100
|
|
|
|
515
|
next if substr($file, 0, 1) eq '.'; |
197
|
|
|
|
|
|
|
|
198
|
158
|
100
|
|
|
|
281
|
next unless substr($file, -6, 6) eq '.ready'; |
199
|
|
|
|
|
|
|
|
200
|
38
|
|
|
|
|
59
|
my $global = substr($file, 0, 6) eq 'GLOBAL'; |
201
|
38
|
|
|
|
|
45
|
my $hid_len = length($hid); |
202
|
38
|
|
66
|
|
|
150
|
my $have_hid = !$global && substr($file, 0, $hid_len) eq $hid && substr($file, $hid_len, 1) eq '-'; |
203
|
|
|
|
|
|
|
|
204
|
38
|
50
|
66
|
|
|
128
|
next unless $have_hid || $global; |
205
|
|
|
|
|
|
|
|
206
|
38
|
100
|
100
|
|
|
156
|
next if $global && $self->{+GLOBALS}->{$hid}->{$file}++; |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
# Untaint the path. |
209
|
27
|
|
|
|
|
175
|
my $full = File::Spec->canonpath("$tempdir/$file"); |
210
|
27
|
|
|
|
|
153
|
($full) = ($full =~ m/^(.*)$/gs); |
211
|
|
|
|
|
|
|
|
212
|
27
|
|
|
|
|
65
|
my $obj = $self->read_event_file($full); |
213
|
27
|
|
|
|
|
45
|
push @out => $obj; |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
# Do not remove global events |
216
|
27
|
100
|
|
|
|
58
|
next if $global; |
217
|
|
|
|
|
|
|
|
218
|
13
|
|
|
|
|
58
|
my $complete = File::Spec->canonpath("$full.complete"); |
219
|
13
|
100
|
|
|
|
36
|
if ($ENV{T2_KEEP_TEMPDIR}) { |
220
|
1
|
50
|
|
|
|
36
|
rename($full, $complete) or $self->abort("Could not rename IPC file '$full', '$complete'"); |
221
|
|
|
|
|
|
|
} |
222
|
|
|
|
|
|
|
else { |
223
|
12
|
50
|
|
|
|
634
|
unlink($full) or $self->abort("Could not unlink IPC file: $file"); |
224
|
|
|
|
|
|
|
} |
225
|
|
|
|
|
|
|
} |
226
|
|
|
|
|
|
|
|
227
|
69
|
|
|
|
|
440
|
closedir($dh); |
228
|
69
|
|
|
|
|
388
|
return @out; |
229
|
|
|
|
|
|
|
} |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
sub read_event_file { |
232
|
31
|
|
|
31
|
0
|
143
|
my $self = shift; |
233
|
31
|
|
|
|
|
30
|
my ($file) = @_; |
234
|
|
|
|
|
|
|
|
235
|
31
|
|
|
|
|
96
|
my $obj = Storable::retrieve($file); |
236
|
31
|
100
|
|
|
|
1986
|
$self->abort("Got an unblessed object: '$obj'") |
237
|
|
|
|
|
|
|
unless blessed($obj); |
238
|
|
|
|
|
|
|
|
239
|
30
|
100
|
|
|
|
115
|
unless ($obj->isa('Test2::Event')) { |
240
|
2
|
|
|
|
|
5
|
my $pkg = blessed($obj); |
241
|
2
|
|
|
|
|
5
|
my $mod_file = pkg_to_file($pkg); |
242
|
2
|
|
|
2
|
|
8
|
my ($ok, $err) = try { require $mod_file }; |
|
2
|
|
|
|
|
197
|
|
243
|
|
|
|
|
|
|
|
244
|
2
|
100
|
|
|
|
11
|
$self->abort("Event has unknown type ($pkg), tried to load '$mod_file' but failed: $err") |
245
|
|
|
|
|
|
|
unless $ok; |
246
|
|
|
|
|
|
|
|
247
|
1
|
50
|
|
|
|
7
|
$self->abort("'$obj' is not a 'Test2::Event' object") |
248
|
|
|
|
|
|
|
unless $obj->isa('Test2::Event'); |
249
|
|
|
|
|
|
|
} |
250
|
|
|
|
|
|
|
|
251
|
28
|
|
|
|
|
47
|
return $obj; |
252
|
|
|
|
|
|
|
} |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
sub waiting { |
255
|
15
|
|
|
15
|
1
|
22
|
my $self = shift; |
256
|
15
|
|
|
|
|
81
|
require Test2::Event::Waiting; |
257
|
15
|
|
|
|
|
144
|
$self->send( |
258
|
|
|
|
|
|
|
GLOBAL => Test2::Event::Waiting->new( |
259
|
|
|
|
|
|
|
trace => Test2::Util::Trace->new(frame => [caller()]), |
260
|
|
|
|
|
|
|
), |
261
|
|
|
|
|
|
|
'GLOBAL' |
262
|
|
|
|
|
|
|
); |
263
|
15
|
|
|
|
|
157
|
return; |
264
|
|
|
|
|
|
|
} |
265
|
|
|
|
|
|
|
|
266
|
|
|
|
|
|
|
sub DESTROY { |
267
|
55
|
|
|
55
|
|
107
|
my $self = shift; |
268
|
|
|
|
|
|
|
|
269
|
55
|
100
|
|
|
|
271
|
return unless defined $self->pid; |
270
|
54
|
100
|
|
|
|
112
|
return unless defined $self->tid; |
271
|
|
|
|
|
|
|
|
272
|
53
|
100
|
|
|
|
82
|
return unless $$ == $self->pid; |
273
|
51
|
100
|
|
|
|
87
|
return unless get_tid() == $self->tid; |
274
|
|
|
|
|
|
|
|
275
|
50
|
|
|
|
|
62
|
my $tempdir = $self->{+TEMPDIR}; |
276
|
|
|
|
|
|
|
|
277
|
50
|
50
|
|
|
|
1058
|
opendir(my $dh, $tempdir) or $self->abort("Could not open temp dir! ($tempdir)"); |
278
|
50
|
|
|
|
|
525
|
while(my $file = readdir($dh)) { |
279
|
106
|
100
|
|
|
|
478
|
next if $file =~ m/^\.+$/; |
280
|
8
|
100
|
|
|
|
20
|
next if $file =~ m/\.complete$/; |
281
|
6
|
|
|
|
|
30
|
my $full = File::Spec->canonpath("$tempdir/$file"); |
282
|
|
|
|
|
|
|
|
283
|
6
|
100
|
|
|
|
23
|
if ($file =~ m/^(GLOBAL|HUB-)/) { |
284
|
5
|
|
|
|
|
12
|
$full =~ m/^(.*)$/; |
285
|
5
|
|
|
|
|
7
|
$full = $1; # Untaint it |
286
|
5
|
100
|
|
|
|
22
|
next if $ENV{T2_KEEP_TEMPDIR}; |
287
|
4
|
50
|
|
|
|
166
|
unlink($full) or $self->abort("Could not unlink IPC file: $full"); |
288
|
4
|
|
|
|
|
16
|
next; |
289
|
|
|
|
|
|
|
} |
290
|
|
|
|
|
|
|
|
291
|
1
|
|
|
|
|
4
|
$self->abort("Leftover files in the directory ($full)!\n"); |
292
|
|
|
|
|
|
|
} |
293
|
49
|
|
|
|
|
242
|
closedir($dh); |
294
|
|
|
|
|
|
|
|
295
|
49
|
100
|
|
|
|
105
|
if ($ENV{T2_KEEP_TEMPDIR}) { |
296
|
1
|
|
|
|
|
4
|
print STDERR "# Not removing temp dir: $tempdir\n"; |
297
|
1
|
|
|
|
|
7
|
return; |
298
|
|
|
|
|
|
|
} |
299
|
|
|
|
|
|
|
|
300
|
48
|
50
|
|
|
|
3246
|
rmdir($tempdir) or warn "Could not remove IPC temp dir ($tempdir)"; |
301
|
|
|
|
|
|
|
} |
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
1; |
304
|
|
|
|
|
|
|
|
305
|
|
|
|
|
|
|
__END__ |