Commit | Line | Data |
---|---|---|
b4514920 CG |
1 | package Test2::IPC::Driver; |
2 | use strict; | |
3 | use warnings; | |
4 | ||
07bc328a | 5 | our $VERSION = '1.302096'; |
b4514920 CG |
6 | |
7 | ||
8 | use Carp qw/confess longmess/; | |
9 | use Test2::Util::HashBase qw{no_fatal}; | |
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 use_shm { 0 } | |
22 | ||
23 | for my $meth (qw/send cull add_hub drop_hub waiting is_viable/) { | |
24 | no strict 'refs'; | |
25 | *$meth = sub { | |
26 | my $thing = shift; | |
27 | confess "'$thing' did not define the required method '$meth'." | |
28 | }; | |
29 | } | |
30 | ||
31 | # Print the error and call exit. We are not using 'die' cause this is a | |
58818a66 | 32 | # catastrophic error that should never be caught. If we get here it |
b4514920 CG |
33 | # means some serious shit has happened in a child process, the only way |
34 | # to inform the parent may be to exit false. | |
35 | ||
36 | sub abort { | |
37 | my $self = shift; | |
38 | chomp(my ($msg) = @_); | |
39 | print STDERR "IPC Fatal Error: $msg\n"; | |
40 | print STDOUT "not ok - IPC Fatal Error\n"; | |
41 | ||
42 | CORE::exit(255) unless $self->no_fatal; | |
43 | } | |
44 | ||
45 | sub abort_trace { | |
46 | my $self = shift; | |
47 | my ($msg) = @_; | |
48 | $self->abort(longmess($msg)); | |
49 | } | |
50 | ||
51 | 1; | |
52 | ||
53 | __END__ | |
54 | ||
55 | =pod | |
56 | ||
57 | =encoding UTF-8 | |
58 | ||
59 | =head1 NAME | |
60 | ||
61 | Test2::IPC::Driver - Base class for Test2 IPC drivers. | |
62 | ||
63 | =head1 SYNOPSIS | |
64 | ||
65 | package Test2::IPC::Driver::MyDriver; | |
66 | ||
67 | use base 'Test2::IPC::Driver'; | |
68 | ||
69 | ... | |
70 | ||
71 | =head1 METHODS | |
72 | ||
73 | =over 4 | |
74 | ||
75 | =item $self->abort($msg) | |
76 | ||
77 | If an IPC encounters a fatal error it should use this. This will print the | |
78 | message to STDERR with C<'IPC Fatal Error: '> prefixed to it, then it will | |
79 | forcefully exit 255. IPC errors may occur in threads or processes other than | |
80 | the main one, this method provides the best chance of the harness noticing the | |
81 | error. | |
82 | ||
83 | =item $self->abort_trace($msg) | |
84 | ||
85 | This is the same as C<< $ipc->abort($msg) >> except that it uses | |
86 | C<Carp::longmess> to add a stack trace to the message. | |
87 | ||
88 | =item $false = $self->use_shm | |
89 | ||
90 | The base class always returns false for this method. You may override it if you | |
91 | wish to use the SHM made available in L<Test2::API>/L<Test2::API::Instance>. | |
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 | # If you are using the SHM you should notify other procs/threads that | |
141 | # there is a pending event. | |
142 | Test2::API::test2_ipc_set_pending($uniq_val); | |
143 | } | |
144 | ||
145 | sub cull { | |
146 | my $self = shift; | |
147 | my ($hid) = @_; | |
148 | ||
149 | my @events = ...; # Here is where you get the events for the hub | |
150 | ||
151 | return @events; | |
152 | } | |
153 | ||
154 | sub waiting { | |
155 | my $self = shift; | |
156 | ||
157 | ... # Notify all listening procs and threads that the main | |
158 | ... # process/thread is waiting for them to finish. | |
159 | } | |
160 | ||
161 | 1; | |
162 | ||
163 | =head2 METHODS SUBCLASSES MUST IMPLEMENT | |
164 | ||
165 | =over 4 | |
166 | ||
167 | =item $ipc->is_viable | |
168 | ||
169 | This should return true if the driver works in the current environment. This | |
170 | should return false if it does not. This is a CLASS method. | |
171 | ||
172 | =item $ipc->add_hub($hid) | |
173 | ||
174 | This is used to alert the driver that a new hub is expecting events. The driver | |
175 | should keep track of the process and thread ids, the hub should only be dropped | |
176 | by the proc+thread that started it. | |
177 | ||
178 | sub add_hub { | |
179 | my $self = shift; | |
180 | my ($hid) = @_; | |
181 | ||
182 | ... # Make it possible to contact the hub | |
183 | } | |
184 | ||
185 | =item $ipc->drop_hub($hid) | |
186 | ||
187 | This is used to alert the driver that a hub is no longer accepting events. The | |
188 | driver should keep track of the process and thread ids, the hub should only be | |
189 | dropped by the proc+thread that started it (This is the drivers responsibility | |
190 | to enforce). | |
191 | ||
192 | sub drop_hub { | |
193 | my $self = shift; | |
194 | my ($hid) = @_; | |
195 | ||
196 | ... # Nothing should try to reach the hub anymore. | |
197 | } | |
198 | ||
199 | =item $ipc->send($hid, $event); | |
200 | ||
201 | =item $ipc->send($hid, $event, $global); | |
202 | ||
203 | Used to send events from the current process/thread to the specified hub in its | |
204 | process+thread. | |
205 | ||
206 | sub send { | |
207 | my $self = shift; | |
208 | my ($hid, $e) = @_; | |
209 | ||
210 | ... # Send the event to the proper hub. | |
211 | ||
212 | # If you are using the SHM you should notify other procs/threads that | |
213 | # there is a pending event. | |
214 | Test2::API::test2_ipc_set_pending($uniq_val); | |
215 | } | |
216 | ||
217 | If C<$global> is true then the driver should send the event to all hubs in all | |
218 | processes and threads. | |
219 | ||
220 | =item @events = $ipc->cull($hid) | |
221 | ||
222 | Used to collect events that have been sent to the specified hub. | |
223 | ||
224 | sub cull { | |
225 | my $self = shift; | |
226 | my ($hid) = @_; | |
227 | ||
228 | my @events = ...; # Here is where you get the events for the hub | |
229 | ||
230 | return @events; | |
231 | } | |
232 | ||
233 | =item $ipc->waiting() | |
234 | ||
235 | This is called in the parent process when it is complete and waiting for all | |
236 | child processes and threads to complete. | |
237 | ||
238 | sub waiting { | |
239 | my $self = shift; | |
240 | ||
241 | ... # Notify all listening procs and threads that the main | |
242 | ... # process/thread is waiting for them to finish. | |
243 | } | |
244 | ||
245 | =back | |
246 | ||
247 | =head2 METHODS SUBCLASSES MAY IMPLEMENT OR OVERRIDE | |
248 | ||
249 | =over 4 | |
250 | ||
251 | =item $bool = $ipc->use_shm() | |
252 | ||
253 | True if you want to make use of the L<Test2::API>/L<Test2::API::Instance> SHM. | |
254 | ||
255 | =item $bites = $ipc->shm_size() | |
256 | ||
58818a66 | 257 | Use this to customize the size of the SHM space. There are no guarantees about |
b4514920 CG |
258 | what the size will be if you do not implement this. |
259 | ||
260 | =back | |
261 | ||
262 | =head1 SOURCE | |
263 | ||
264 | The source code repository for Test2 can be found at | |
265 | F<http://github.com/Test-More/test-more/>. | |
266 | ||
267 | =head1 MAINTAINERS | |
268 | ||
269 | =over 4 | |
270 | ||
271 | =item Chad Granum E<lt>exodist@cpan.orgE<gt> | |
272 | ||
273 | =back | |
274 | ||
275 | =head1 AUTHORS | |
276 | ||
277 | =over 4 | |
278 | ||
279 | =item Chad Granum E<lt>exodist@cpan.orgE<gt> | |
280 | ||
281 | =back | |
282 | ||
283 | =head1 COPYRIGHT | |
284 | ||
07bc328a | 285 | Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. |
b4514920 CG |
286 | |
287 | This program is free software; you can redistribute it and/or | |
288 | modify it under the same terms as Perl itself. | |
289 | ||
290 | See F<http://dev.perl.org/licenses/> | |
291 | ||
292 | =cut |