Commit | Line | Data |
---|---|---|
b4514920 CG |
1 | package Test2::IPC::Driver; |
2 | use strict; | |
3 | use warnings; | |
4 | ||
3740cf6d | 5 | our $VERSION = '1.302193'; |
b4514920 CG |
6 | |
7 | ||
95db2efb | 8 | use Carp qw/confess/; |
e26b661b | 9 | use Test2::Util::HashBase qw{no_fatal no_bail}; |
b4514920 CG |
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 | ||
33951b79 CBW |
21 | sub pending { -1 } |
22 | sub set_pending { -1 } | |
b4514920 CG |
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 | |
58818a66 | 33 | # catastrophic error that should never be caught. If we get here it |
b4514920 CG |
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) = @_); | |
e26b661b SH |
40 | |
41 | $self->driver_abort($msg) if $self->can('driver_abort'); | |
42 | ||
b4514920 | 43 | print STDERR "IPC Fatal Error: $msg\n"; |
e26b661b | 44 | print STDOUT "Bail out! IPC Fatal Error: $msg\n" unless $self->no_bail; |
b4514920 CG |
45 | |
46 | CORE::exit(255) unless $self->no_fatal; | |
47 | } | |
48 | ||
49 | sub abort_trace { | |
50 | my $self = shift; | |
51 | my ($msg) = @_; | |
95db2efb SH |
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)); | |
b4514920 CG |
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 | ||
b4514920 CG |
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 | ||
33951b79 | 140 | # This may notify other procs/threads that there is a pending event. |
b4514920 CG |
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 | ||
33951b79 | 211 | # This may notify other procs/threads that there is a pending event. |
b4514920 CG |
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 | ||
e26b661b SH |
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 | ||
b4514920 CG |
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 | ||
18c72c39 | 280 | Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. |
b4514920 CG |
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 |