cpan/Test-Simple/lib/Test2/IPC/Driver.pm

   1 package Test2::IPC::Driver;
   2 use strict;
   3 use warnings;
   4
   5 our $VERSION = '1.302170';
   6
   7
   8 use Carp qw/confess/;
   9 use Test2::Util::HashBase qw{no_fatal no_bail};
  10
  11 use Test2::API qw/test2_ipc_add_driver/;
  12
  13 my %ADDED;
  14 sub import {
  15     my $class = shift;
  16     return if $class eq __PACKAGE__;
  17     return if $ADDED{$class}++;
  18     test2_ipc_add_driver($class);
  19 }
  20
  21 sub pending { -1 }
  22 sub set_pending { -1 }
  23
  24 for my $meth (qw/send cull add_hub drop_hub waiting is_viable/) {
  25     no strict 'refs';
  26     *$meth = sub {
  27         my $thing = shift;
  28         confess "'$thing' did not define the required method '$meth'."
  29     };
  30 }
  31
  32 # Print the error and call exit. We are not using 'die' cause this is a
  33 # catastrophic error that should never be caught. If we get here it
  34 # means some serious shit has happened in a child process, the only way
  35 # to inform the parent may be to exit false.
  36
  37 sub abort {
  38     my $self = shift;
  39     chomp(my ($msg) = @_);
  40
  41     $self->driver_abort($msg) if $self->can('driver_abort');
  42
  43     print STDERR "IPC Fatal Error: $msg\n";
  44     print STDOUT "Bail out! IPC Fatal Error: $msg\n" unless $self->no_bail;
  45
  46     CORE::exit(255) unless $self->no_fatal;
  47 }
  48
  49 sub abort_trace {
  50     my $self = shift;
  51     my ($msg) = @_;
  52     # Older versions of Carp do not export longmess() function, so it needs to be called with package name
  53     $self->abort(Carp::longmess($msg));
  54 }
  55
  56 1;
  57
  58 __END__
  59
  60 =pod
  61
  62 =encoding UTF-8
  63
  64 =head1 NAME
  65
  66 Test2::IPC::Driver - Base class for Test2 IPC drivers.
  67
  68 =head1 SYNOPSIS
  69
  70     package Test2::IPC::Driver::MyDriver;
  71
  72     use base 'Test2::IPC::Driver';
  73
  74     ...
  75
  76 =head1 METHODS
  77
  78 =over 4
  79
  80 =item $self->abort($msg)
  81
  82 If an IPC encounters a fatal error it should use this. This will print the
  83 message to STDERR with C<'IPC Fatal Error: '> prefixed to it, then it will
  84 forcefully exit 255. IPC errors may occur in threads or processes other than
  85 the main one, this method provides the best chance of the harness noticing the
  86 error.
  87
  88 =item $self->abort_trace($msg)
  89
  90 This is the same as C<< $ipc->abort($msg) >> except that it uses
  91 C<Carp::longmess> to add a stack trace to the message.
  92
  93 =back
  94
  95 =head1 LOADING DRIVERS
  96
  97 Test2::IPC::Driver has an C<import()> method. All drivers inherit this import
  98 method. This import method registers the driver.
  99
 100 In most cases you just need to load the desired IPC driver to make it work. You
 101 should load this driver as early as possible. A warning will be issued if you
 102 load it too late for it to be effective.
 103
 104     use Test2::IPC::Driver::MyDriver;
 105     ...
 106
 107 =head1 WRITING DRIVERS
 108
 109     package Test2::IPC::Driver::MyDriver;
 110     use strict;
 111     use warnings;
 112
 113     use base 'Test2::IPC::Driver';
 114
 115     sub is_viable {
 116         return 0 if $^O eq 'win32'; # Will not work on windows.
 117         return 1;
 118     }
 119
 120     sub add_hub {
 121         my $self = shift;
 122         my ($hid) = @_;
 123
 124         ... # Make it possible to contact the hub
 125     }
 126
 127     sub drop_hub {
 128         my $self = shift;
 129         my ($hid) = @_;
 130
 131         ... # Nothing should try to reach the hub anymore.
 132     }
 133
 134     sub send {
 135         my $self = shift;
 136         my ($hid, $e, $global) = @_;
 137
 138         ... # Send the event to the proper hub.
 139
 140         # This may notify other procs/threads that there is a pending event.
 141         Test2::API::test2_ipc_set_pending($uniq_val);
 142     }
 143
 144     sub cull {
 145         my $self = shift;
 146         my ($hid) = @_;
 147
 148         my @events = ...; # Here is where you get the events for the hub
 149
 150         return @events;
 151     }
 152
 153     sub waiting {
 154         my $self = shift;
 155
 156         ... # Notify all listening procs and threads that the main
 157         ... # process/thread is waiting for them to finish.
 158     }
 159
 160     1;
 161
 162 =head2 METHODS SUBCLASSES MUST IMPLEMENT
 163
 164 =over 4
 165
 166 =item $ipc->is_viable
 167
 168 This should return true if the driver works in the current environment. This
 169 should return false if it does not. This is a CLASS method.
 170
 171 =item $ipc->add_hub($hid)
 172
 173 This is used to alert the driver that a new hub is expecting events. The driver
 174 should keep track of the process and thread ids, the hub should only be dropped
 175 by the proc+thread that started it.
 176
 177     sub add_hub {
 178         my $self = shift;
 179         my ($hid) = @_;
 180
 181         ... # Make it possible to contact the hub
 182     }
 183
 184 =item $ipc->drop_hub($hid)
 185
 186 This is used to alert the driver that a hub is no longer accepting events. The
 187 driver should keep track of the process and thread ids, the hub should only be
 188 dropped by the proc+thread that started it (This is the drivers responsibility
 189 to enforce).
 190
 191     sub drop_hub {
 192         my $self = shift;
 193         my ($hid) = @_;
 194
 195         ... # Nothing should try to reach the hub anymore.
 196     }
 197
 198 =item $ipc->send($hid, $event);
 199
 200 =item $ipc->send($hid, $event, $global);
 201
 202 Used to send events from the current process/thread to the specified hub in its
 203 process+thread.
 204
 205     sub send {
 206         my $self = shift;
 207         my ($hid, $e) = @_;
 208
 209         ... # Send the event to the proper hub.
 210
 211         # This may notify other procs/threads that there is a pending event.
 212         Test2::API::test2_ipc_set_pending($uniq_val);
 213     }
 214
 215 If C<$global> is true then the driver should send the event to all hubs in all
 216 processes and threads.
 217
 218 =item @events = $ipc->cull($hid)
 219
 220 Used to collect events that have been sent to the specified hub.
 221
 222     sub cull {
 223         my $self = shift;
 224         my ($hid) = @_;
 225
 226         my @events = ...; # Here is where you get the events for the hub
 227
 228         return @events;
 229     }
 230
 231 =item $ipc->waiting()
 232
 233 This is called in the parent process when it is complete and waiting for all
 234 child processes and threads to complete.
 235
 236     sub waiting {
 237         my $self = shift;
 238
 239         ... # Notify all listening procs and threads that the main
 240         ... # process/thread is waiting for them to finish.
 241     }
 242
 243 =back
 244
 245 =head2 METHODS SUBCLASSES MAY IMPLEMENT OR OVERRIDE
 246
 247 =over 4
 248
 249 =item $ipc->driver_abort($msg)
 250
 251 This is a hook called by C<< Test2::IPC::Driver->abort() >>. This is your
 252 chance to cleanup when an abort happens. You cannot prevent the abort, but you
 253 can gracefully except it.
 254
 255 =back
 256
 257 =head1 SOURCE
 258
 259 The source code repository for Test2 can be found at
 260 F<http://github.com/Test-More/test-more/>.
 261
 262 =head1 MAINTAINERS
 263
 264 =over 4
 265
 266 =item Chad Granum E<lt>exodist@cpan.orgE<gt>
 267
 268 =back
 269
 270 =head1 AUTHORS
 271
 272 =over 4
 273
 274 =item Chad Granum E<lt>exodist@cpan.orgE<gt>
 275
 276 =back
 277
 278 =head1 COPYRIGHT
 279
 280 Copyright 2019 Chad Granum E<lt>exodist@cpan.orgE<gt>.
 281
 282 This program is free software; you can redistribute it and/or
 283 modify it under the same terms as Perl itself.
 284
 285 See F<http://dev.perl.org/licenses/>
 286
 287 =cut