| 1 | package Test2::IPC::Driver; |
| 2 | use strict; |
| 3 | use warnings; |
| 4 | |
| 5 | our $VERSION = '1.302193'; |
| 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 2020 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 |