File Coverage

blib/lib/Test2/IPC/Driver/Files.pm
Criterion Covered Total %
statement 169 169 100.0
branch 75 92 81.5
condition 11 15 73.3
subroutine 25 25 100.0
pod 8 12 66.6
total 288 313 92.0


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__