File Coverage

blib/lib/Test2/IPC/Driver.pm
Criterion Covered Total %
statement 35 35 100.0
branch 8 10 80.0
condition n/a
subroutine 12 12 100.0
pod 2 4 50.0
total 57 61 93.4


line stmt bran cond sub pod time code
1             package Test2::IPC::Driver;
2 30     30   212 use strict;
  30         70  
  30         903  
3 30     30   149 use warnings;
  30         64  
  30         3118  
4              
5             our $VERSION = '1.302181';
6              
7              
8 30     30   161 use Carp qw/confess/;
  30         67  
  30         1679  
9 30     30   637 use Test2::Util::HashBase qw{no_fatal no_bail};
  30         79  
  30         191  
10              
11 30     30   776 use Test2::API qw/test2_ipc_add_driver/;
  30         62  
  30         5187  
12              
13             my %ADDED;
14             sub import {
15 7     7   98 my $class = shift;
16 7 50       29 return if $class eq __PACKAGE__;
17 7 100       40 return if $ADDED{$class}++;
18 4         24 test2_ipc_add_driver($class);
19             }
20              
21 691     691 0 1819 sub pending { -1 }
22 29     29 0 118 sub set_pending { -1 }
23              
24             for my $meth (qw/send cull add_hub drop_hub waiting is_viable/) {
25 30     30   398 no strict 'refs';
  30         76  
  30         7989  
26             *$meth = sub {
27 6     6   39 my $thing = shift;
28 6         715 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 13     13 1 2043 my $self = shift;
39 13         39 chomp(my ($msg) = @_);
40              
41 13 100       77 $self->driver_abort($msg) if $self->can('driver_abort');
42              
43 13         70 print STDERR "IPC Fatal Error: $msg\n";
44 13 100       43 print STDOUT "Bail out! IPC Fatal Error: $msg\n" unless $self->no_bail;
45              
46 13 50       37 CORE::exit(255) unless $self->no_fatal;
47             }
48              
49             sub abort_trace {
50 4     4 1 37 my $self = shift;
51 4         10 my ($msg) = @_;
52             # Older versions of Carp do not export longmess() function, so it needs to be called with package name
53 4         362 $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