summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Test2/API/Instance.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Test2/API/Instance.pm')
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Test2/API/Instance.pm132
1 files changed, 19 insertions, 113 deletions
diff --git a/Master/tlpkg/tlperl/lib/Test2/API/Instance.pm b/Master/tlpkg/tlperl/lib/Test2/API/Instance.pm
index 0522dd77aa4..1cf224cf063 100755
--- a/Master/tlpkg/tlperl/lib/Test2/API/Instance.pm
+++ b/Master/tlpkg/tlperl/lib/Test2/API/Instance.pm
@@ -2,8 +2,7 @@ package Test2::API::Instance;
use strict;
use warnings;
-our $VERSION = '1.302133';
-
+our $VERSION = '1.302162';
our @CARP_NOT = qw/Test2::API Test2::API::Instance Test2::IPC::Driver Test2::Formatter/;
use Carp qw/confess carp/;
@@ -26,9 +25,6 @@ use Test2::Util::HashBase qw{
-preload
ipc_disabled
- ipc_shm_size
- ipc_shm_last
- ipc_shm_id
ipc_polling
ipc_drivers
ipc_timeout
@@ -216,7 +212,6 @@ sub _finalize {
for my $driver (@{$self->{+IPC_DRIVERS}}) {
next unless $driver->can('is_viable') && $driver->is_viable;
$self->{+IPC} = $driver->new or next;
- $self->ipc_enable_shm if $self->{+IPC}->use_shm;
return;
}
@@ -366,91 +361,36 @@ sub enable_ipc_polling {
# $_[0] is a context object
sub {
return unless $self->{+IPC_POLLING};
- return $_[0]->{hub}->cull unless $self->{+IPC_SHM_ID};
-
- my $val;
- if(shmread($self->{+IPC_SHM_ID}, $val, 0, $self->{+IPC_SHM_SIZE})) {
- return if $val eq $self->{+IPC_SHM_LAST};
- $self->{+IPC_SHM_LAST} = $val;
- }
- else {
- warn "SHM Read error: $!\n";
- }
-
- $_[0]->{hub}->cull;
+ return unless $self->{+IPC};
+ return unless $self->{+IPC}->pending();
+ return $_[0]->{hub}->cull;
}
) unless defined $self->ipc_polling;
$self->set_ipc_polling(1);
}
-sub ipc_enable_shm {
+sub get_ipc_pending {
my $self = shift;
-
- return 1 if defined $self->{+IPC_SHM_ID};
-
- $self->{+_PID} = $$ unless defined $self->{+_PID};
- $self->{+_TID} = get_tid() unless defined $self->{+_TID};
-
- my ($ok, $err) = try {
- # SysV IPC can be available but not enabled.
- #
- # In some systems (*BSD) accessing the SysV IPC APIs without
- # them being enabled can cause a SIGSYS. We suppress the SIGSYS
- # and then get ENOSYS from the calls.
- local $SIG{SYS} = 'IGNORE' if CAN_SIGSYS;
-
- require IPC::SysV;
-
- my $ipc_key = IPC::SysV::IPC_PRIVATE();
- my $shm_size = $self->{+IPC}->can('shm_size') ? $self->{+IPC}->shm_size : 64;
- my $shm_id = shmget($ipc_key, $shm_size, 0666) or die "Could not get shm: $!";
-
- my $initial = 'a' x $shm_size;
- shmwrite($shm_id, $initial, 0, $shm_size) or die "Could not write to shm: $!";
- my $val;
- shmread($shm_id, $val, 0, $shm_size) or die "Could not read from shm: $!";
- die "Read SHM value does not match the initial value ('$val' vs '$initial')"
- unless $val eq $initial;
-
- $self->{+IPC_SHM_SIZE} = $shm_size;
- $self->{+IPC_SHM_ID} = $shm_id;
- $self->{+IPC_SHM_LAST} = $initial;
- };
-
- return $ok;
+ return -1 unless $self->{+IPC};
+ $self->{+IPC}->pending();
}
-sub ipc_free_shm {
+sub _check_pid {
my $self = shift;
-
- my $id = delete $self->{+IPC_SHM_ID};
- return unless defined $id;
-
- shmctl($id, IPC::SysV::IPC_RMID(), 0);
-}
-
-sub get_ipc_pending {
- my $self = shift;
- return -1 unless defined $self->{+IPC_SHM_ID};
- my $val;
- shmread($self->{+IPC_SHM_ID}, $val, 0, $self->{+IPC_SHM_SIZE}) or return -1;
- return 0 if $val eq $self->{+IPC_SHM_LAST};
- $self->{+IPC_SHM_LAST} = $val;
- return 1;
+ my ($pid) = @_;
+ return kill(0, $pid);
}
sub set_ipc_pending {
my $self = shift;
-
- return undef unless defined $self->{+IPC_SHM_ID};
-
+ return unless $self->{+IPC};
my ($val) = @_;
confess "value is required for set_ipc_pending"
unless $val;
- shmwrite($self->{+IPC_SHM_ID}, $val, 0, $self->{+IPC_SHM_SIZE});
+ $self->{+IPC}->set_pending($val);
}
sub disable_ipc_polling {
@@ -517,18 +457,6 @@ sub _ipc_wait {
return 255;
}
-sub DESTROY {
- my $self = shift;
-
- return if $self->{+PRELOAD};
-
- return unless defined($self->{+_PID}) && $self->{+_PID} == $$;
- return unless defined($self->{+_TID}) && $self->{+_TID} == get_tid();
-
- shmctl($self->{+IPC_SHM_ID}, IPC::SysV::IPC_RMID(), 0)
- if defined $self->{+IPC_SHM_ID};
-}
-
sub set_exit {
my $self = shift;
@@ -740,42 +668,20 @@ This is intended to be called in an C<END { ... }> block. This will look at
test state and set $?. This will also call any end callbacks, and wait on child
processes/threads.
-=item $obj->ipc_enable_shm()
-
-Turn on SHM for IPC (if possible)
-
-=item $shm_id = $obj->ipc_shm_id()
-
-If SHM is enabled for IPC this will be the shm_id for it.
-
-=item $shm_size = $obj->ipc_shm_size()
-
-If SHM is enabled for IPC this will be the size of it.
-
-=item $shm_last_val = $obj->ipc_shm_last()
-
-If SHM is enabled for IPC this will return the last SHM value seen.
-
=item $obj->set_ipc_pending($val)
-use the IPC SHM to tell other processes and threads there is a pending event.
-C<$val> should be a unique value no other thread/process will generate.
+Tell other processes and threads there is a pending event. C<$val> should be a
+unique value no other thread/process will generate.
-B<Note:> This will also make the current process see a pending event. It does
-not set C<ipc_shm_last()>, this is important because doing so could hide a
-previous change.
+B<Note:> This will also make the current process see a pending event.
=item $pending = $obj->get_ipc_pending()
-This returns -1 if SHM is not enabled for IPC.
-
-This returns 0 if the SHM value matches the last known value, which means there
-are no pending events.
+This returns -1 if it is not possible to know.
-This returns 1 if the SHM value has changed, which means there are probably
-pending events.
+This returns 0 if there are no pending events.
-When 1 is returned this will set C<< $obj->ipc_shm_last() >>.
+This returns 1 if there are pending events.
=item $timeout = $obj->ipc_timeout;
@@ -906,7 +812,7 @@ F<http://github.com/Test-More/test-more/>.
=head1 COPYRIGHT
-Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+Copyright 2019 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.