[perl5.git] / cpan / Test-Simple / lib / Test2 / IPC / Driver / Files.pm

package Test2::IPC::Driver::Files;
use strict;
use warnings;

our $VERSION = '1.302141';


BEGIN { require Test2::IPC::Driver; our @ISA = qw(Test2::IPC::Driver) }

use Test2::Util::HashBase qw{tempdir event_ids read_ids timeouts tid pid globals};

use Scalar::Util qw/blessed/;
use File::Temp();
use Storable();
use File::Spec();
use POSIX();

use Test2::Util qw/try get_tid pkg_to_file IS_WIN32 ipc_separator do_rename do_unlink try_sig_mask/;
use Test2::API qw/test2_ipc_set_pending/;

sub use_shm { 1 }
sub shm_size() { 64 }

sub is_viable { 1 }

sub init {
    my $self = shift;

    my $tmpdir = File::Temp::tempdir(
        $ENV{T2_TEMPDIR_TEMPLATE} || "test2" . ipc_separator . $$ . ipc_separator . "XXXXXX",
        CLEANUP => 0,
        TMPDIR => 1,
    );

    $self->abort_trace("Could not get a temp dir") unless $tmpdir;

    $self->{+TEMPDIR} = File::Spec->canonpath($tmpdir);

    print STDERR "\nIPC Temp Dir: $tmpdir\n\n"
        if $ENV{T2_KEEP_TEMPDIR};

    $self->{+EVENT_IDS} = {};
    $self->{+READ_IDS} = {};
    $self->{+TIMEOUTS} = {};

    $self->{+TID} = get_tid();
    $self->{+PID} = $$;

    $self->{+GLOBALS} = {};

    return $self;
}

sub hub_file {
    my $self = shift;
    my ($hid) = @_;
    my $tdir = $self->{+TEMPDIR};
    return File::Spec->catfile($tdir, "HUB" . ipc_separator . $hid);
}

sub event_file {
    my $self = shift;
    my ($hid, $e) = @_;

    my $tempdir = $self->{+TEMPDIR};
    my $type = blessed($e) or $self->abort("'$e' is not a blessed object!");

    $self->abort("'$e' is not an event object!")
        unless $type->isa('Test2::Event');

    my $tid = get_tid();
    my $eid = $self->{+EVENT_IDS}->{$hid}->{$$}->{$tid} += 1;

    my @type = split '::', $type;
    my $name = join(ipc_separator, $hid, $$, $tid, $eid, @type);

    return File::Spec->catfile($tempdir, $name);
}

sub add_hub {
    my $self = shift;
    my ($hid) = @_;

    my $hfile = $self->hub_file($hid);

    $self->abort_trace("File for hub '$hid' already exists")
        if -e $hfile;

    open(my $fh, '>', $hfile) or $self->abort_trace("Could not create hub file '$hid': $!");
    print $fh "$$\n" . get_tid() . "\n";
    close($fh);
}

sub drop_hub {
    my $self = shift;
    my ($hid) = @_;

    my $tdir = $self->{+TEMPDIR};
    my $hfile = $self->hub_file($hid);

    $self->abort_trace("File for hub '$hid' does not exist")
        unless -e $hfile;

    open(my $fh, '<', $hfile) or $self->abort_trace("Could not open hub file '$hid': $!");
    my ($pid, $tid) = <$fh>;
    close($fh);

    $self->abort_trace("A hub file can only be closed by the process that started it\nExpected $pid, got $$")
        unless $pid == $$;

    $self->abort_trace("A hub file can only be closed by the thread that started it\nExpected $tid, got " . get_tid())
        unless get_tid() == $tid;

    if ($ENV{T2_KEEP_TEMPDIR}) {
        my ($ok, $err) = do_rename($hfile, File::Spec->canonpath("$hfile.complete"));
        $self->abort_trace("Could not rename file '$hfile' -> '$hfile.complete': $err") unless $ok
    }
    else {
        my ($ok, $err) = do_unlink($hfile);
        $self->abort_trace("Could not remove file for hub '$hid': $err") unless $ok
    }

    opendir(my $dh, $tdir) or $self->abort_trace("Could not open temp dir!");
    for my $file (readdir($dh)) {
        next if $file =~ m{\.complete$};
        next unless $file =~ m{^$hid};
        $self->abort_trace("Not all files from hub '$hid' have been collected!");
    }
    closedir($dh);
}

sub send {
    my $self = shift;
    my ($hid, $e, $global) = @_;

    my $tempdir = $self->{+TEMPDIR};
    my $hfile = $self->hub_file($hid);
    my $dest = $global ? 'GLOBAL' : $hid;

    $self->abort(<<"    EOT") unless $global || -f $hfile;
hub '$hid' is not available, failed to send event!

There was an attempt to send an event to a hub in a parent process or thread,
but that hub appears to be gone. This can happen if you fork, or start a new
thread from inside subtest, and the parent finishes the subtest before the
child returns.

This can also happen if the parent process is done testing before the child
finishes. Test2 normally waits automatically in the root process, but will not
do so if Test::Builder is loaded for legacy reasons.
    EOT

    my $file = $self->event_file($dest, $e);
    my $ready = File::Spec->canonpath("$file.ready");

    if ($global) {
        my $name = $ready;
        $name =~ s{^.*(GLOBAL)}{GLOBAL};
        $self->{+GLOBALS}->{$hid}->{$name}++;
    }

    # Write and rename the file.
    my ($ren_ok, $ren_err);
    my ($ok, $err) = try_sig_mask {
        Storable::store($e, $file);
        ($ren_ok, $ren_err) = do_rename("$file", $ready);
    };

    if ($ok) {
        $self->abort("Could not rename file '$file' -> '$ready': $ren_err") unless $ren_ok;
        test2_ipc_set_pending(substr($file, -(shm_size)));
    }
    else {
        my $src_file = __FILE__;
        $err =~ s{ at \Q$src_file\E.*$}{};
        chomp($err);
        my $tid = get_tid();
        my $trace = $e->trace->debug;
        my $type = blessed($e);

        $self->abort(<<"        EOT");

*******************************************************************************
There was an error writing an event:
Destination: $dest
Origin PID:  $$
Origin TID:  $tid
Event Type:  $type
Event Trace: $trace
File Name:   $file
Ready Name:  $ready
Error: $err
*******************************************************************************

        EOT
    }

    return 1;
}

sub driver_abort {
    my $self = shift;
    my ($msg) = @_;

    local ($@, $!, $?, $^E);
    eval {
        my $abort = File::Spec->catfile($self->{+TEMPDIR}, "ABORT");
        open(my $fh, '>>', $abort) or die "Could not open abort file: $!";
        print $fh $msg, "\n";
        close($fh) or die "Could not close abort file: $!";
        1;
    } or warn $@;
}

sub cull {
    my $self = shift;
    my ($hid) = @_;

    my $tempdir = $self->{+TEMPDIR};

    opendir(my $dh, $tempdir) or $self->abort("could not open IPC temp dir ($tempdir)!");

    my $read = $self->{+READ_IDS};
    my $timeouts = $self->{+TIMEOUTS};

    my @out;
    for my $info (sort cmp_events map { $self->should_read_event($hid, $_) } readdir($dh)) {
        unless ($info->{global}) {
            my $next = $self->{+READ_IDS}->{$info->{hid}}->{$info->{pid}}->{$info->{tid}} ||= 1;

            $timeouts->{$info->{file}} ||= time;

            if ($next != $info->{eid}) {
                # Wait up to N seconds for missing events
                next unless 5 < time - $timeouts->{$info->{file}};
                $self->abort("Missing event HID: $info->{hid}, PID: $info->{pid}, TID: $info->{tid}, EID: $info->{eid}.");
            }

            $self->{+READ_IDS}->{$info->{hid}}->{$info->{pid}}->{$info->{tid}} = $info->{eid} + 1;
        }

        my $full = $info->{full_path};
        my $obj = $self->read_event_file($full);
        push @out => $obj;

        # Do not remove global events
        next if $info->{global};

        if ($ENV{T2_KEEP_TEMPDIR}) {
            my $complete = File::Spec->canonpath("$full.complete");
            my ($ok, $err) = do_rename($full, $complete);
            $self->abort("Could not rename IPC file '$full', '$complete': $err") unless $ok;
        }
        else {
            my ($ok, $err) = do_unlink("$full");
            $self->abort("Could not unlink IPC file '$full': $err") unless $ok;
        }
    }

    closedir($dh);
    return @out;
}

sub parse_event_filename {
    my $self = shift;
    my ($file) = @_;

    # The || is to force 0 in false
    my $complete = substr($file, -9, 9) eq '.complete' || 0 and substr($file, -9, 9, "");
    my $ready    = substr($file, -6, 6) eq '.ready'    || 0 and substr($file, -6, 6, "");

    my @parts = split ipc_separator, $file;
    my ($global, $hid) = $parts[0] eq 'GLOBAL' ? (1, shift @parts) : (0, join ipc_separator, splice(@parts, 0, 4));
    my ($pid, $tid, $eid) = splice(@parts, 0, 3);
    my $type = join '::' => @parts;

    return {
        file     => $file,
        ready    => $ready,
        complete => $complete,
        global   => $global,
        type     => $type,
        hid      => $hid,
        pid      => $pid,
        tid      => $tid,
        eid      => $eid,
    };
}

sub should_read_event {
    my $self = shift;
    my ($hid, $file) = @_;

    return if substr($file, 0, 1) eq '.';
    return if substr($file, 0, 3) eq 'HUB';
    CORE::exit(255) if $file eq 'ABORT';

    my $parsed = $self->parse_event_filename($file);

    return if $parsed->{complete};
    return unless $parsed->{ready};
    return unless $parsed->{global} || $parsed->{hid} eq $hid;

    return if $parsed->{global} && $self->{+GLOBALS}->{$hid}->{$file}++;

    # Untaint the path.
    my $full = File::Spec->catfile($self->{+TEMPDIR}, $file);
    ($full) = ($full =~ m/^(.*)$/gs) if ${^TAINT};

    $parsed->{full_path} = $full;

    return $parsed;
}

sub cmp_events {
    # Globals first
    return -1 if $a->{global} && !$b->{global};
    return  1 if $b->{global} && !$a->{global};

    return $a->{pid} <=> $b->{pid}
        || $a->{tid} <=> $b->{tid}
        || $a->{eid} <=> $b->{eid};
}

sub read_event_file {
    my $self = shift;
    my ($file) = @_;

    my $obj = Storable::retrieve($file);
    $self->abort("Got an unblessed object: '$obj'")
        unless blessed($obj);

    unless ($obj->isa('Test2::Event')) {
        my $pkg  = blessed($obj);
        my $mod_file = pkg_to_file($pkg);
        my ($ok, $err) = try { require $mod_file };

        $self->abort("Event has unknown type ($pkg), tried to load '$mod_file' but failed: $err")
            unless $ok;

        $self->abort("'$obj' is not a 'Test2::Event' object")
            unless $obj->isa('Test2::Event');
    }

    return $obj;
}

sub waiting {
    my $self = shift;
    require Test2::Event::Waiting;
    $self->send(
        GLOBAL => Test2::Event::Waiting->new(
            trace => Test2::EventFacet::Trace->new(frame => [caller()]),
        ),
        'GLOBAL'
    );
    return;
}

sub DESTROY {
    my $self = shift;

    return unless defined $self->pid;
    return unless defined $self->tid;

    return unless $$        == $self->pid;
    return unless get_tid() == $self->tid;

    my $tempdir = $self->{+TEMPDIR};

    my $aborted = 0;
    my $abort_file = File::Spec->catfile($self->{+TEMPDIR}, "ABORT");
    if (-e $abort_file) {
        $aborted = 1;
        my ($ok, $err) = do_unlink($abort_file);
        warn $err unless $ok;
    }

    opendir(my $dh, $tempdir) or $self->abort("Could not open temp dir! ($tempdir)");
    while(my $file = readdir($dh)) {
        next if $file =~ m/^\.+$/;
        next if $file =~ m/\.complete$/;
        my $full = File::Spec->catfile($tempdir, $file);

        my $sep = ipc_separator;
        if ($aborted || $file =~ m/^(GLOBAL|HUB$sep)/) {
            $full =~ m/^(.*)$/;
            $full = $1; # Untaint it
            next if $ENV{T2_KEEP_TEMPDIR};
            my ($ok, $err) = do_unlink($full);
            $self->abort("Could not unlink IPC file '$full': $err") unless $ok;
            next;
        }

        $self->abort("Leftover files in the directory ($full)!\n");
    }
    closedir($dh);

    if ($ENV{T2_KEEP_TEMPDIR}) {
        print STDERR "# Not removing temp dir: $tempdir\n";
        return;
    }

    my $abort = File::Spec->catfile($self->{+TEMPDIR}, "ABORT");
    unlink($abort) if -e $abort;
    rmdir($tempdir) or warn "Could not remove IPC temp dir ($tempdir)";
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::IPC::Driver::Files - Temp dir + Files concurrency model.

=head1 DESCRIPTION

This is the default, and fallback concurrency model for L<Test2>. This
sends events between processes and threads using serialized files in a
temporary directory. This is not particularly fast, but it works everywhere.

=head1 SYNOPSIS

    use Test2::IPC::Driver::Files;

    # IPC is now enabled

=head1 ENVIRONMENT VARIABLES

=over 4

=item T2_KEEP_TEMPDIR=0

When true, the tempdir used by the IPC driver will not be deleted when the test
is done.

=item T2_TEMPDIR_TEMPLATE='test2-XXXXXX'

This can be used to set the template for the IPC temp dir. The template should
follow template specifications from L<File::Temp>.

=back

=head1 SEE ALSO

See L<Test2::IPC::Driver> for methods.

=head1 SOURCE

The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>.

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

See F<http://dev.perl.org/licenses/>

=cut
Commit	Line	Data
b4514920 CG	1	package Test2::IPC::Driver::Files;
	2	use strict;
	3	use warnings;
	4
11d2c931	5	our $VERSION = '1.302141';
b4514920 CG	6
b4514920 CG	7
58818a66	8	BEGIN { require Test2::IPC::Driver; our @ISA = qw(Test2::IPC::Driver) }
b4514920	9
e26b661b	10	use Test2::Util::HashBase qw{tempdir event_ids read_ids timeouts tid pid globals};
b4514920 CG	11
	12	use Scalar::Util qw/blessed/;
	13	use File::Temp();
	14	use Storable();
	15	use File::Spec();
58818a66	16	use POSIX();
b4514920	17
07bc328a	18	use Test2::Util qw/try get_tid pkg_to_file IS_WIN32 ipc_separator do_rename do_unlink try_sig_mask/;
b4514920 CG	19	use Test2::API qw/test2_ipc_set_pending/;
	20
	21	sub use_shm { 1 }
	22	sub shm_size() { 64 }
	23
	24	sub is_viable { 1 }
	25
	26	sub init {
	27	my $self = shift;
	28
	29	my $tmpdir = File::Temp::tempdir(
fa951d2c	30	$ENV{T2_TEMPDIR_TEMPLATE} \|\| "test2" . ipc_separator . $$ . ipc_separator . "XXXXXX",
b4514920 CG	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
e26b661b SH	42	$self->{+EVENT_IDS} = {};
	43	$self->{+READ_IDS} = {};
	44	$self->{+TIMEOUTS} = {};
b4514920 CG	45
	46	$self->{+TID} = get_tid();
	47	$self->{+PID} = $$;
	48
	49	$self->{+GLOBALS} = {};
	50
	51	return $self;
	52	}
	53
	54	sub hub_file {
	55	my $self = shift;
	56	my ($hid) = @_;
	57	my $tdir = $self->{+TEMPDIR};
fa951d2c	58	return File::Spec->catfile($tdir, "HUB" . ipc_separator . $hid);
b4514920 CG	59	}
	60
	61	sub 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
e26b661b SH	71	my $tid = get_tid();
	72	my $eid = $self->{+EVENT_IDS}->{$hid}->{$$}->{$tid} += 1;
	73
b4514920	74	my @type = split '::', $type;
e26b661b	75	my $name = join(ipc_separator, $hid, $$, $tid, $eid, @type);
b4514920	76
58818a66	77	return File::Spec->catfile($tempdir, $name);
b4514920 CG	78	}
	79
	80	sub 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
	94	sub 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}) {
0b4ffce6 SH	115	my ($ok, $err) = do_rename($hfile, File::Spec->canonpath("$hfile.complete"));
0b4ffce6 SH	116	$self->abort_trace("Could not rename file '$hfile' -> '$hfile.complete': $err") unless $ok
b4514920 CG	117	}
b4514920 CG	118	else {
0b4ffce6 SH	119	my ($ok, $err) = do_unlink($hfile);
0b4ffce6 SH	120	$self->abort_trace("Could not remove file for hub '$hid': $err") unless $ok
b4514920 CG	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
	132	sub 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;
	141	hub '$hid' is not available, failed to send event!
	142
	143	There was an attempt to send an event to a hub in a parent process or thread,
	144	but that hub appears to be gone. This can happen if you fork, or start a new
	145	thread from inside subtest, and the parent finishes the subtest before the
	146	child returns.
	147
	148	This can also happen if the parent process is done testing before the child
	149	finishes. Test2 normally waits automatically in the root process, but will not
	150	do 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
58818a66	162	# Write and rename the file.
07bc328a SH	163	my ($ren_ok, $ren_err);
07bc328a SH	164	my ($ok, $err) = try_sig_mask {
b4514920	165	Storable::store($e, $file);
07bc328a	166	($ren_ok, $ren_err) = do_rename("$file", $ready);
b4514920	167	};
58818a66	168
07bc328a SH	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 {
b4514920 CG	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	*******************************************************************************
	184	There was an error writing an event:
	185	Destination: $dest
	186	Origin PID: $$
	187	Origin TID: $tid
	188	Event Type: $type
	189	Event Trace: $trace
	190	File Name: $file
	191	Ready Name: $ready
	192	Error: $err
	193	*******************************************************************************
	194
	195	EOT
	196	}
	197
	198	return 1;
	199	}
	200
e26b661b SH	201	sub 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
b4514920 CG	215	sub 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
e26b661b SH	223	my $read = $self->{+READ_IDS};
	224	my $timeouts = $self->{+TIMEOUTS};
	225
b4514920	226	my @out;
0b4ffce6	227	for my $info (sort cmp_events map { $self->should_read_event($hid, $_) } readdir($dh)) {
e26b661b SH	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
0b4ffce6	242	my $full = $info->{full_path};
b4514920 CG	243	my $obj = $self->read_event_file($full);
	244	push @out => $obj;
	245
	246	# Do not remove global events
0b4ffce6	247	next if $info->{global};
b4514920	248
b4514920	249	if ($ENV{T2_KEEP_TEMPDIR}) {
0b4ffce6 SH	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;
b4514920 CG	253	}
b4514920 CG	254	else {
0b4ffce6 SH	255	my ($ok, $err) = do_unlink("$full");
0b4ffce6 SH	256	$self->abort("Could not unlink IPC file '$full': $err") unless $ok;
b4514920 CG	257	}
	258	}
	259
	260	closedir($dh);
	261	return @out;
	262	}
	263
0b4ffce6 SH	264	sub 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
fa951d2c	272	my @parts = split ipc_separator, $file;
e82ffdf2	273	my ($global, $hid) = $parts[0] eq 'GLOBAL' ? (1, shift @parts) : (0, join ipc_separator, splice(@parts, 0, 4));
0b4ffce6 SH	274	my ($pid, $tid, $eid) = splice(@parts, 0, 3);
	275	my $type = join '::' => @parts;
	276
	277	return {
e26b661b	278	file => $file,
0b4ffce6 SH	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
	290	sub should_read_event {
	291	my $self = shift;
	292	my ($hid, $file) = @_;
	293
	294	return if substr($file, 0, 1) eq '.';
e26b661b SH	295	return if substr($file, 0, 3) eq 'HUB';
e26b661b SH	296	CORE::exit(255) if $file eq 'ABORT';
0b4ffce6 SH	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
	315	sub 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
b4514920 CG	325	sub 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
	348	sub waiting {
	349	my $self = shift;
	350	require Test2::Event::Waiting;
	351	$self->send(
	352	GLOBAL => Test2::Event::Waiting->new(
07bc328a	353	trace => Test2::EventFacet::Trace->new(frame => [caller()]),
b4514920 CG	354	),
	355	'GLOBAL'
	356	);
	357	return;
	358	}
	359
	360	sub 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
e26b661b SH	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
b4514920 CG	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$/;
58818a66	383	my $full = File::Spec->catfile($tempdir, $file);
b4514920	384
fa951d2c	385	my $sep = ipc_separator;
e26b661b	386	if ($aborted \|\| $file =~ m/^(GLOBAL\|HUB$sep)/) {
b4514920 CG	387	$full =~ m/^(.*)$/;
	388	$full = $1; # Untaint it
	389	next if $ENV{T2_KEEP_TEMPDIR};
0b4ffce6 SH	390	my ($ok, $err) = do_unlink($full);
0b4ffce6 SH	391	$self->abort("Could not unlink IPC file '$full': $err") unless $ok;
b4514920 CG	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
e26b661b SH	404	my $abort = File::Spec->catfile($self->{+TEMPDIR}, "ABORT");
e26b661b SH	405	unlink($abort) if -e $abort;
b4514920 CG	406	rmdir($tempdir) or warn "Could not remove IPC temp dir ($tempdir)";
	407	}
	408
	409	1;
	410
	411	__END__
	412
	413	=pod
	414
	415	=encoding UTF-8
	416
	417	=head1 NAME
	418
	419	Test2::IPC::Driver::Files - Temp dir + Files concurrency model.
	420
	421	=head1 DESCRIPTION
	422
	423	This is the default, and fallback concurrency model for L<Test2>. This
	424	sends events between processes and threads using serialized files in a
	425	temporary 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
	439	When true, the tempdir used by the IPC driver will not be deleted when the test
	440	is done.
	441
	442	=item T2_TEMPDIR_TEMPLATE='test2-XXXXXX'
	443
	444	This can be used to set the template for the IPC temp dir. The template should
	445	follow template specifications from L<File::Temp>.
	446
	447	=back
	448
	449	=head1 SEE ALSO
	450
	451	See L<Test2::IPC::Driver> for methods.
	452
	453	=head1 SOURCE
	454
	455	The source code repository for Test2 can be found at
	456	F<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
61979647	476	Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>.
b4514920 CG	477
	478	This program is free software; you can redistribute it and/or
	479	modify it under the same terms as Perl itself.
	480
	481	See F<http://dev.perl.org/licenses/>
	482
	483	=cut