diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Test2/IPC/Driver.pm')
-rwxr-xr-x | Master/tlpkg/tlperl/lib/Test2/IPC/Driver.pm | 292 |
1 files changed, 292 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Test2/IPC/Driver.pm b/Master/tlpkg/tlperl/lib/Test2/IPC/Driver.pm new file mode 100755 index 00000000000..cd34f7c0258 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/IPC/Driver.pm @@ -0,0 +1,292 @@ +package Test2::IPC::Driver; +use strict; +use warnings; + +our $VERSION = '1.302073'; + + +use Carp qw/confess longmess/; +use Test2::Util::HashBase qw{no_fatal}; + +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 use_shm { 0 } + +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) = @_); + print STDERR "IPC Fatal Error: $msg\n"; + print STDOUT "not ok - IPC Fatal Error\n"; + + CORE::exit(255) unless $self->no_fatal; +} + +sub abort_trace { + my $self = shift; + my ($msg) = @_; + $self->abort(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. + +=item $false = $self->use_shm + +The base class always returns false for this method. You may override it if you +wish to use the SHM made available in L<Test2::API>/L<Test2::API::Instance>. + +=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. + + # If you are using the SHM you should 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. + + # If you are using the SHM you should 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 $bool = $ipc->use_shm() + +True if you want to make use of the L<Test2::API>/L<Test2::API::Instance> SHM. + +=item $bites = $ipc->shm_size() + +Use this to customize the size of the SHM space. There are no guarantees about +what the size will be if you do not implement this. + +=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 2016 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 |