1package Test2::IPC::Driver::Files;
2use strict;
3use warnings;
4
5our $VERSION = '1.302162';
6
7BEGIN { require Test2::IPC::Driver; our @ISA = qw(Test2::IPC::Driver) }
8
9use Test2::Util::HashBase qw{tempdir event_ids read_ids timeouts tid pid globals};
10
11use Scalar::Util qw/blessed/;
12use File::Temp();
13use Storable();
14use File::Spec();
15use POSIX();
16
17use Test2::Util qw/try get_tid pkg_to_file IS_WIN32 ipc_separator do_rename do_unlink try_sig_mask/;
18use Test2::API qw/test2_ipc_set_pending/;
19
20sub is_viable { 1 }
21
22sub init {
23    my $self = shift;
24
25    my $tmpdir = File::Temp::tempdir(
26        $ENV{T2_TEMPDIR_TEMPLATE} || "test2" . ipc_separator . $$ . ipc_separator . "XXXXXX",
27        CLEANUP => 0,
28        TMPDIR => 1,
29    );
30
31    $self->abort_trace("Could not get a temp dir") unless $tmpdir;
32
33    $self->{+TEMPDIR} = File::Spec->canonpath($tmpdir);
34
35    print STDERR "\nIPC Temp Dir: $tmpdir\n\n"
36        if $ENV{T2_KEEP_TEMPDIR};
37
38    $self->{+EVENT_IDS} = {};
39    $self->{+READ_IDS} = {};
40    $self->{+TIMEOUTS} = {};
41
42    $self->{+TID} = get_tid();
43    $self->{+PID} = $$;
44
45    $self->{+GLOBALS} = {};
46
47    return $self;
48}
49
50sub hub_file {
51    my $self = shift;
52    my ($hid) = @_;
53    my $tdir = $self->{+TEMPDIR};
54    return File::Spec->catfile($tdir, "HUB" . ipc_separator . $hid);
55}
56
57sub event_file {
58    my $self = shift;
59    my ($hid, $e) = @_;
60
61    my $tempdir = $self->{+TEMPDIR};
62    my $type = blessed($e) or $self->abort("'$e' is not a blessed object!");
63
64    $self->abort("'$e' is not an event object!")
65        unless $type->isa('Test2::Event');
66
67    my $tid = get_tid();
68    my $eid = $self->{+EVENT_IDS}->{$hid}->{$$}->{$tid} += 1;
69
70    my @type = split '::', $type;
71    my $name = join(ipc_separator, $hid, $$, $tid, $eid, @type);
72
73    return File::Spec->catfile($tempdir, $name);
74}
75
76sub add_hub {
77    my $self = shift;
78    my ($hid) = @_;
79
80    my $hfile = $self->hub_file($hid);
81
82    $self->abort_trace("File for hub '$hid' already exists")
83        if -e $hfile;
84
85    open(my $fh, '>', $hfile) or $self->abort_trace("Could not create hub file '$hid': $!");
86    print $fh "$$\n" . get_tid() . "\n";
87    close($fh);
88}
89
90sub drop_hub {
91    my $self = shift;
92    my ($hid) = @_;
93
94    my $tdir = $self->{+TEMPDIR};
95    my $hfile = $self->hub_file($hid);
96
97    $self->abort_trace("File for hub '$hid' does not exist")
98        unless -e $hfile;
99
100    open(my $fh, '<', $hfile) or $self->abort_trace("Could not open hub file '$hid': $!");
101    my ($pid, $tid) = <$fh>;
102    close($fh);
103
104    $self->abort_trace("A hub file can only be closed by the process that started it\nExpected $pid, got $$")
105        unless $pid == $$;
106
107    $self->abort_trace("A hub file can only be closed by the thread that started it\nExpected $tid, got " . get_tid())
108        unless get_tid() == $tid;
109
110    if ($ENV{T2_KEEP_TEMPDIR}) {
111        my ($ok, $err) = do_rename($hfile, File::Spec->canonpath("$hfile.complete"));
112        $self->abort_trace("Could not rename file '$hfile' -> '$hfile.complete': $err") unless $ok
113    }
114    else {
115        my ($ok, $err) = do_unlink($hfile);
116        $self->abort_trace("Could not remove file for hub '$hid': $err") unless $ok
117    }
118
119    opendir(my $dh, $tdir) or $self->abort_trace("Could not open temp dir!");
120    for my $file (readdir($dh)) {
121        next if $file =~ m{\.complete$};
122        next unless $file =~ m{^$hid};
123        $self->abort_trace("Not all files from hub '$hid' have been collected!");
124    }
125    closedir($dh);
126}
127
128sub send {
129    my $self = shift;
130    my ($hid, $e, $global) = @_;
131
132    my $tempdir = $self->{+TEMPDIR};
133    my $hfile = $self->hub_file($hid);
134    my $dest = $global ? 'GLOBAL' : $hid;
135
136    $self->abort(<<"    EOT") unless $global || -f $hfile;
137hub '$hid' is not available, failed to send event!
138
139There was an attempt to send an event to a hub in a parent process or thread,
140but that hub appears to be gone. This can happen if you fork, or start a new
141thread from inside subtest, and the parent finishes the subtest before the
142child returns.
143
144This can also happen if the parent process is done testing before the child
145finishes. Test2 normally waits automatically in the root process, but will not
146do so if Test::Builder is loaded for legacy reasons.
147    EOT
148
149    my $file = $self->event_file($dest, $e);
150    my $ready = File::Spec->canonpath("$file.ready");
151
152    if ($global) {
153        my $name = $ready;
154        $name =~ s{^.*(GLOBAL)}{GLOBAL};
155        $self->{+GLOBALS}->{$hid}->{$name}++;
156    }
157
158    # Write and rename the file.
159    my ($ren_ok, $ren_err);
160    my ($ok, $err) = try_sig_mask {
161        Storable::store($e, $file);
162        ($ren_ok, $ren_err) = do_rename("$file", $ready);
163    };
164
165    if ($ok) {
166        $self->abort("Could not rename file '$file' -> '$ready': $ren_err") unless $ren_ok;
167        test2_ipc_set_pending($file);
168    }
169    else {
170        my $src_file = __FILE__;
171        $err =~ s{ at \Q$src_file\E.*$}{};
172        chomp($err);
173        my $tid = get_tid();
174        my $trace = $e->trace->debug;
175        my $type = blessed($e);
176
177        $self->abort(<<"        EOT");
178
179*******************************************************************************
180There was an error writing an event:
181Destination: $dest
182Origin PID:  $$
183Origin TID:  $tid
184Event Type:  $type
185Event Trace: $trace
186File Name:   $file
187Ready Name:  $ready
188Error: $err
189*******************************************************************************
190
191        EOT
192    }
193
194    return 1;
195}
196
197sub driver_abort {
198    my $self = shift;
199    my ($msg) = @_;
200
201    local ($@, $!, $?, $^E);
202    eval {
203        my $abort = File::Spec->catfile($self->{+TEMPDIR}, "ABORT");
204        open(my $fh, '>>', $abort) or die "Could not open abort file: $!";
205        print $fh $msg, "\n";
206        close($fh) or die "Could not close abort file: $!";
207        1;
208    } or warn $@;
209}
210
211sub cull {
212    my $self = shift;
213    my ($hid) = @_;
214
215    my $tempdir = $self->{+TEMPDIR};
216
217    opendir(my $dh, $tempdir) or $self->abort("could not open IPC temp dir ($tempdir)!");
218
219    my $read = $self->{+READ_IDS};
220    my $timeouts = $self->{+TIMEOUTS};
221
222    my @out;
223    for my $info (sort cmp_events map { $self->should_read_event($hid, $_) } readdir($dh)) {
224        unless ($info->{global}) {
225            my $next = $self->{+READ_IDS}->{$info->{hid}}->{$info->{pid}}->{$info->{tid}} ||= 1;
226
227            $timeouts->{$info->{file}} ||= time;
228
229            if ($next != $info->{eid}) {
230                # Wait up to N seconds for missing events
231                next unless 5 < time - $timeouts->{$info->{file}};
232                $self->abort("Missing event HID: $info->{hid}, PID: $info->{pid}, TID: $info->{tid}, EID: $info->{eid}.");
233            }
234
235            $self->{+READ_IDS}->{$info->{hid}}->{$info->{pid}}->{$info->{tid}} = $info->{eid} + 1;
236        }
237
238        my $full = $info->{full_path};
239        my $obj = $self->read_event_file($full);
240        push @out => $obj;
241
242        # Do not remove global events
243        next if $info->{global};
244
245        if ($ENV{T2_KEEP_TEMPDIR}) {
246            my $complete = File::Spec->canonpath("$full.complete");
247            my ($ok, $err) = do_rename($full, $complete);
248            $self->abort("Could not rename IPC file '$full', '$complete': $err") unless $ok;
249        }
250        else {
251            my ($ok, $err) = do_unlink("$full");
252            $self->abort("Could not unlink IPC file '$full': $err") unless $ok;
253        }
254    }
255
256    closedir($dh);
257    return @out;
258}
259
260sub parse_event_filename {
261    my $self = shift;
262    my ($file) = @_;
263
264    # The || is to force 0 in false
265    my $complete = substr($file, -9, 9) eq '.complete' || 0 and substr($file, -9, 9, "");
266    my $ready    = substr($file, -6, 6) eq '.ready'    || 0 and substr($file, -6, 6, "");
267
268    my @parts = split ipc_separator, $file;
269    my ($global, $hid) = $parts[0] eq 'GLOBAL' ? (1, shift @parts) : (0, join ipc_separator, splice(@parts, 0, 4));
270    my ($pid, $tid, $eid) = splice(@parts, 0, 3);
271    my $type = join '::' => @parts;
272
273    return {
274        file     => $file,
275        ready    => $ready,
276        complete => $complete,
277        global   => $global,
278        type     => $type,
279        hid      => $hid,
280        pid      => $pid,
281        tid      => $tid,
282        eid      => $eid,
283    };
284}
285
286sub should_read_event {
287    my $self = shift;
288    my ($hid, $file) = @_;
289
290    return if substr($file, 0, 1) eq '.';
291    return if substr($file, 0, 3) eq 'HUB';
292    CORE::exit(255) if $file eq 'ABORT';
293
294    my $parsed = $self->parse_event_filename($file);
295
296    return if $parsed->{complete};
297    return unless $parsed->{ready};
298    return unless $parsed->{global} || $parsed->{hid} eq $hid;
299
300    return if $parsed->{global} && $self->{+GLOBALS}->{$hid}->{$file}++;
301
302    # Untaint the path.
303    my $full = File::Spec->catfile($self->{+TEMPDIR}, $file);
304    ($full) = ($full =~ m/^(.*)$/gs) if ${^TAINT};
305
306    $parsed->{full_path} = $full;
307
308    return $parsed;
309}
310
311sub cmp_events {
312    # Globals first
313    return -1 if $a->{global} && !$b->{global};
314    return  1 if $b->{global} && !$a->{global};
315
316    return $a->{pid} <=> $b->{pid}
317        || $a->{tid} <=> $b->{tid}
318        || $a->{eid} <=> $b->{eid};
319}
320
321sub read_event_file {
322    my $self = shift;
323    my ($file) = @_;
324
325    my $obj = Storable::retrieve($file);
326    $self->abort("Got an unblessed object: '$obj'")
327        unless blessed($obj);
328
329    unless ($obj->isa('Test2::Event')) {
330        my $pkg  = blessed($obj);
331        my $mod_file = pkg_to_file($pkg);
332        my ($ok, $err) = try { require $mod_file };
333
334        $self->abort("Event has unknown type ($pkg), tried to load '$mod_file' but failed: $err")
335            unless $ok;
336
337        $self->abort("'$obj' is not a 'Test2::Event' object")
338            unless $obj->isa('Test2::Event');
339    }
340
341    return $obj;
342}
343
344sub waiting {
345    my $self = shift;
346    require Test2::Event::Waiting;
347    $self->send(
348        GLOBAL => Test2::Event::Waiting->new(
349            trace => Test2::EventFacet::Trace->new(frame => [caller()]),
350        ),
351        'GLOBAL'
352    );
353    return;
354}
355
356sub DESTROY {
357    my $self = shift;
358
359    return unless defined $self->pid;
360    return unless defined $self->tid;
361
362    return unless $$        == $self->pid;
363    return unless get_tid() == $self->tid;
364
365    my $tempdir = $self->{+TEMPDIR};
366
367    my $aborted = 0;
368    my $abort_file = File::Spec->catfile($self->{+TEMPDIR}, "ABORT");
369    if (-e $abort_file) {
370        $aborted = 1;
371        my ($ok, $err) = do_unlink($abort_file);
372        warn $err unless $ok;
373    }
374
375    opendir(my $dh, $tempdir) or $self->abort("Could not open temp dir! ($tempdir)");
376    while(my $file = readdir($dh)) {
377        next if $file =~ m/^\.+$/;
378        next if $file =~ m/\.complete$/;
379        my $full = File::Spec->catfile($tempdir, $file);
380
381        my $sep = ipc_separator;
382        if ($aborted || $file =~ m/^(GLOBAL|HUB$sep)/) {
383            $full =~ m/^(.*)$/;
384            $full = $1; # Untaint it
385            next if $ENV{T2_KEEP_TEMPDIR};
386            my ($ok, $err) = do_unlink($full);
387            $self->abort("Could not unlink IPC file '$full': $err") unless $ok;
388            next;
389        }
390
391        $self->abort("Leftover files in the directory ($full)!\n");
392    }
393    closedir($dh);
394
395    if ($ENV{T2_KEEP_TEMPDIR}) {
396        print STDERR "# Not removing temp dir: $tempdir\n";
397        return;
398    }
399
400    my $abort = File::Spec->catfile($self->{+TEMPDIR}, "ABORT");
401    unlink($abort) if -e $abort;
402    rmdir($tempdir) or warn "Could not remove IPC temp dir ($tempdir)";
403}
404
4051;
406
407__END__
408
409=pod
410
411=encoding UTF-8
412
413=head1 NAME
414
415Test2::IPC::Driver::Files - Temp dir + Files concurrency model.
416
417=head1 DESCRIPTION
418
419This is the default, and fallback concurrency model for L<Test2>. This
420sends events between processes and threads using serialized files in a
421temporary directory. This is not particularly fast, but it works everywhere.
422
423=head1 SYNOPSIS
424
425    use Test2::IPC::Driver::Files;
426
427    # IPC is now enabled
428
429=head1 ENVIRONMENT VARIABLES
430
431=over 4
432
433=item T2_KEEP_TEMPDIR=0
434
435When true, the tempdir used by the IPC driver will not be deleted when the test
436is done.
437
438=item T2_TEMPDIR_TEMPLATE='test2-XXXXXX'
439
440This can be used to set the template for the IPC temp dir. The template should
441follow template specifications from L<File::Temp>.
442
443=back
444
445=head1 SEE ALSO
446
447See L<Test2::IPC::Driver> for methods.
448
449=head1 SOURCE
450
451The source code repository for Test2 can be found at
452F<http://github.com/Test-More/test-more/>.
453
454=head1 MAINTAINERS
455
456=over 4
457
458=item Chad Granum E<lt>exodist@cpan.orgE<gt>
459
460=back
461
462=head1 AUTHORS
463
464=over 4
465
466=item Chad Granum E<lt>exodist@cpan.orgE<gt>
467
468=back
469
470=head1 COPYRIGHT
471
472Copyright 2019 Chad Granum E<lt>exodist@cpan.orgE<gt>.
473
474This program is free software; you can redistribute it and/or
475modify it under the same terms as Perl itself.
476
477See F<http://dev.perl.org/licenses/>
478
479=cut
480