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