1package Test2::IPC::Driver;
2use strict;
3use warnings;
4
5our $VERSION = '1.302190';
6
7
8use Carp qw/confess/;
9use Test2::Util::HashBase qw{no_fatal no_bail};
10
11use Test2::API qw/test2_ipc_add_driver/;
12
13my %ADDED;
14sub import {
15    my $class = shift;
16    return if $class eq __PACKAGE__;
17    return if $ADDED{$class}++;
18    test2_ipc_add_driver($class);
19}
20
21sub pending { -1 }
22sub set_pending { -1 }
23
24for 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
37sub 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
49sub 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
561;
57
58__END__
59
60=pod
61
62=encoding UTF-8
63
64=head1 NAME
65
66Test2::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
82If an IPC encounters a fatal error it should use this. This will print the
83message to STDERR with C<'IPC Fatal Error: '> prefixed to it, then it will
84forcefully exit 255. IPC errors may occur in threads or processes other than
85the main one, this method provides the best chance of the harness noticing the
86error.
87
88=item $self->abort_trace($msg)
89
90This is the same as C<< $ipc->abort($msg) >> except that it uses
91C<Carp::longmess> to add a stack trace to the message.
92
93=back
94
95=head1 LOADING DRIVERS
96
97Test2::IPC::Driver has an C<import()> method. All drivers inherit this import
98method. This import method registers the driver.
99
100In most cases you just need to load the desired IPC driver to make it work. You
101should load this driver as early as possible. A warning will be issued if you
102load 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
168This should return true if the driver works in the current environment. This
169should return false if it does not. This is a CLASS method.
170
171=item $ipc->add_hub($hid)
172
173This is used to alert the driver that a new hub is expecting events. The driver
174should keep track of the process and thread ids, the hub should only be dropped
175by 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
186This is used to alert the driver that a hub is no longer accepting events. The
187driver should keep track of the process and thread ids, the hub should only be
188dropped by the proc+thread that started it (This is the drivers responsibility
189to 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
202Used to send events from the current process/thread to the specified hub in its
203process+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
215If C<$global> is true then the driver should send the event to all hubs in all
216processes and threads.
217
218=item @events = $ipc->cull($hid)
219
220Used 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
233This is called in the parent process when it is complete and waiting for all
234child 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
251This is a hook called by C<< Test2::IPC::Driver->abort() >>. This is your
252chance to cleanup when an abort happens. You cannot prevent the abort, but you
253can gracefully except it.
254
255=back
256
257=head1 SOURCE
258
259The source code repository for Test2 can be found at
260F<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
280Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
281
282This program is free software; you can redistribute it and/or
283modify it under the same terms as Perl itself.
284
285See F<http://dev.perl.org/licenses/>
286
287=cut
288