Initial Commit
This commit is contained in:
Riley Schneider
287
database/perl/lib/Test2/IPC/Driver.pm
Normal file
287
database/perl/lib/Test2/IPC/Driver.pm
Normal file
@@ -0,0 +1,287 @@
|
||||
package Test2::IPC::Driver;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302183';
|
||||
|
||||
|
||||
use Carp qw/confess/;
|
||||
use Test2::Util::HashBase qw{no_fatal no_bail};
|
||||
|
||||
use Test2::API qw/test2_ipc_add_driver/;
|
||||
|
||||
my %ADDED;
|
||||
sub import {
|
||||
my $class = shift;
|
||||
return if $class eq __PACKAGE__;
|
||||
return if $ADDED{$class}++;
|
||||
test2_ipc_add_driver($class);
|
||||
}
|
||||
|
||||
sub pending { -1 }
|
||||
sub set_pending { -1 }
|
||||
|
||||
for my $meth (qw/send cull add_hub drop_hub waiting is_viable/) {
|
||||
no strict 'refs';
|
||||
*$meth = sub {
|
||||
my $thing = shift;
|
||||
confess "'$thing' did not define the required method '$meth'."
|
||||
};
|
||||
}
|
||||
|
||||
# Print the error and call exit. We are not using 'die' cause this is a
|
||||
# catastrophic error that should never be caught. If we get here it
|
||||
# means some serious shit has happened in a child process, the only way
|
||||
# to inform the parent may be to exit false.
|
||||
|
||||
sub abort {
|
||||
my $self = shift;
|
||||
chomp(my ($msg) = @_);
|
||||
|
||||
$self->driver_abort($msg) if $self->can('driver_abort');
|
||||
|
||||
print STDERR "IPC Fatal Error: $msg\n";
|
||||
print STDOUT "Bail out! IPC Fatal Error: $msg\n" unless $self->no_bail;
|
||||
|
||||
CORE::exit(255) unless $self->no_fatal;
|
||||
}
|
||||
|
||||
sub abort_trace {
|
||||
my $self = shift;
|
||||
my ($msg) = @_;
|
||||
# Older versions of Carp do not export longmess() function, so it needs to be called with package name
|
||||
$self->abort(Carp::longmess($msg));
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::IPC::Driver - Base class for Test2 IPC drivers.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package Test2::IPC::Driver::MyDriver;
|
||||
|
||||
use base 'Test2::IPC::Driver';
|
||||
|
||||
...
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $self->abort($msg)
|
||||
|
||||
If an IPC encounters a fatal error it should use this. This will print the
|
||||
message to STDERR with C<'IPC Fatal Error: '> prefixed to it, then it will
|
||||
forcefully exit 255. IPC errors may occur in threads or processes other than
|
||||
the main one, this method provides the best chance of the harness noticing the
|
||||
error.
|
||||
|
||||
=item $self->abort_trace($msg)
|
||||
|
||||
This is the same as C<< $ipc->abort($msg) >> except that it uses
|
||||
C<Carp::longmess> to add a stack trace to the message.
|
||||
|
||||
=back
|
||||
|
||||
=head1 LOADING DRIVERS
|
||||
|
||||
Test2::IPC::Driver has an C<import()> method. All drivers inherit this import
|
||||
method. This import method registers the driver.
|
||||
|
||||
In most cases you just need to load the desired IPC driver to make it work. You
|
||||
should load this driver as early as possible. A warning will be issued if you
|
||||
load it too late for it to be effective.
|
||||
|
||||
use Test2::IPC::Driver::MyDriver;
|
||||
...
|
||||
|
||||
=head1 WRITING DRIVERS
|
||||
|
||||
package Test2::IPC::Driver::MyDriver;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base 'Test2::IPC::Driver';
|
||||
|
||||
sub is_viable {
|
||||
return 0 if $^O eq 'win32'; # Will not work on windows.
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub add_hub {
|
||||
my $self = shift;
|
||||
my ($hid) = @_;
|
||||
|
||||
... # Make it possible to contact the hub
|
||||
}
|
||||
|
||||
sub drop_hub {
|
||||
my $self = shift;
|
||||
my ($hid) = @_;
|
||||
|
||||
... # Nothing should try to reach the hub anymore.
|
||||
}
|
||||
|
||||
sub send {
|
||||
my $self = shift;
|
||||
my ($hid, $e, $global) = @_;
|
||||
|
||||
... # Send the event to the proper hub.
|
||||
|
||||
# This may notify other procs/threads that there is a pending event.
|
||||
Test2::API::test2_ipc_set_pending($uniq_val);
|
||||
}
|
||||
|
||||
sub cull {
|
||||
my $self = shift;
|
||||
my ($hid) = @_;
|
||||
|
||||
my @events = ...; # Here is where you get the events for the hub
|
||||
|
||||
return @events;
|
||||
}
|
||||
|
||||
sub waiting {
|
||||
my $self = shift;
|
||||
|
||||
... # Notify all listening procs and threads that the main
|
||||
... # process/thread is waiting for them to finish.
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head2 METHODS SUBCLASSES MUST IMPLEMENT
|
||||
|
||||
=over 4
|
||||
|
||||
=item $ipc->is_viable
|
||||
|
||||
This should return true if the driver works in the current environment. This
|
||||
should return false if it does not. This is a CLASS method.
|
||||
|
||||
=item $ipc->add_hub($hid)
|
||||
|
||||
This is used to alert the driver that a new hub is expecting events. The driver
|
||||
should keep track of the process and thread ids, the hub should only be dropped
|
||||
by the proc+thread that started it.
|
||||
|
||||
sub add_hub {
|
||||
my $self = shift;
|
||||
my ($hid) = @_;
|
||||
|
||||
... # Make it possible to contact the hub
|
||||
}
|
||||
|
||||
=item $ipc->drop_hub($hid)
|
||||
|
||||
This is used to alert the driver that a hub is no longer accepting events. The
|
||||
driver should keep track of the process and thread ids, the hub should only be
|
||||
dropped by the proc+thread that started it (This is the drivers responsibility
|
||||
to enforce).
|
||||
|
||||
sub drop_hub {
|
||||
my $self = shift;
|
||||
my ($hid) = @_;
|
||||
|
||||
... # Nothing should try to reach the hub anymore.
|
||||
}
|
||||
|
||||
=item $ipc->send($hid, $event);
|
||||
|
||||
=item $ipc->send($hid, $event, $global);
|
||||
|
||||
Used to send events from the current process/thread to the specified hub in its
|
||||
process+thread.
|
||||
|
||||
sub send {
|
||||
my $self = shift;
|
||||
my ($hid, $e) = @_;
|
||||
|
||||
... # Send the event to the proper hub.
|
||||
|
||||
# This may notify other procs/threads that there is a pending event.
|
||||
Test2::API::test2_ipc_set_pending($uniq_val);
|
||||
}
|
||||
|
||||
If C<$global> is true then the driver should send the event to all hubs in all
|
||||
processes and threads.
|
||||
|
||||
=item @events = $ipc->cull($hid)
|
||||
|
||||
Used to collect events that have been sent to the specified hub.
|
||||
|
||||
sub cull {
|
||||
my $self = shift;
|
||||
my ($hid) = @_;
|
||||
|
||||
my @events = ...; # Here is where you get the events for the hub
|
||||
|
||||
return @events;
|
||||
}
|
||||
|
||||
=item $ipc->waiting()
|
||||
|
||||
This is called in the parent process when it is complete and waiting for all
|
||||
child processes and threads to complete.
|
||||
|
||||
sub waiting {
|
||||
my $self = shift;
|
||||
|
||||
... # Notify all listening procs and threads that the main
|
||||
... # process/thread is waiting for them to finish.
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=head2 METHODS SUBCLASSES MAY IMPLEMENT OR OVERRIDE
|
||||
|
||||
=over 4
|
||||
|
||||
=item $ipc->driver_abort($msg)
|
||||
|
||||
This is a hook called by C<< Test2::IPC::Driver->abort() >>. This is your
|
||||
chance to cleanup when an abort happens. You cannot prevent the abort, but you
|
||||
can gracefully except it.
|
||||
|
||||
=back
|
||||
|
||||
=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 2020 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
|
||||
503
database/perl/lib/Test2/IPC/Driver/Files.pm
Normal file
503
database/perl/lib/Test2/IPC/Driver/Files.pm
Normal file
@@ -0,0 +1,503 @@
|
||||
package Test2::IPC::Driver::Files;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302183';
|
||||
|
||||
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 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!");
|
||||
|
||||
my %bad;
|
||||
for my $file (readdir($dh)) {
|
||||
next if $file =~ m{\.complete$};
|
||||
next unless $file =~ m{^$hid};
|
||||
|
||||
eval { $bad{$file} = $self->read_event_file(File::Spec->catfile($tdir, $file)); 1 } or $bad{$file} = $@ || "Unknown error reading file";
|
||||
}
|
||||
closedir($dh);
|
||||
|
||||
return unless keys %bad;
|
||||
|
||||
my $data;
|
||||
my $ok = eval {
|
||||
require JSON::PP;
|
||||
local *UNIVERSAL::TO_JSON = sub { +{ %{$_[0]} } };
|
||||
my $json = JSON::PP->new->ascii->pretty->canonical->allow_unknown->allow_blessed->convert_blessed;
|
||||
$data = $json->encode(\%bad);
|
||||
1;
|
||||
};
|
||||
$ok ||= eval {
|
||||
require Data::Dumper;
|
||||
local $Data::Dumper::Sortkeys = 1;
|
||||
$data = Data::Dumper::Dumper(\%bad);
|
||||
1;
|
||||
};
|
||||
|
||||
$data = "Could not dump data... sorry." unless defined $data;
|
||||
|
||||
$self->abort_trace("Not all files from hub '$hid' have been collected!\nHere is the leftover data:\n========================\n$data\n===================\n");
|
||||
}
|
||||
|
||||
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(sub {
|
||||
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($file);
|
||||
}
|
||||
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 2020 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
|
||||
Reference in New Issue
Block a user