File Coverage

blib/lib/IO/Async/OS.pm
Criterion Covered Total %
statement 223 232 96.1
branch 74 106 69.8
condition 39 57 68.4
subroutine 42 43 97.6
pod n/a
total 378 438 86.3


line stmt bran cond sub pod time code
1             # You may distribute under the terms of either the GNU General Public License
2             # or the Artistic License (the same terms as Perl itself)
3             #
4             # (C) Paul Evans, 2012-2019 -- leonerd@leonerd.org.uk
5              
6             package IO::Async::OS;
7              
8 103     103   414786 use strict;
  103         200  
  103         2748  
9 103     103   452 use warnings;
  103         169  
  103         9532  
10              
11             our $VERSION = '0.802';
12              
13             our @ISA = qw( IO::Async::OS::_Base );
14              
15             if( eval { require "IO/Async/OS/$^O.pm" } ) {
16             @ISA = "IO::Async::OS::$^O";
17             }
18              
19             package # hide from CPAN
20             IO::Async::OS::_Base;
21              
22 103     103   561 use Carp;
  103         162  
  103         6558  
23              
24 103         10183 use Socket 1.95 qw(
25             AF_INET AF_INET6 AF_UNIX INADDR_LOOPBACK SOCK_DGRAM SOCK_RAW SOCK_STREAM
26             pack_sockaddr_in inet_aton
27             pack_sockaddr_in6 inet_pton
28             pack_sockaddr_un
29 103     103   18609 );
  103         116183  
30              
31 103     103   6609 use POSIX qw( sysconf _SC_OPEN_MAX );
  103         79658  
  103         557  
32              
33             # Win32 [and maybe other places] don't have an _SC_OPEN_MAX. About the best we
34             # can do really is just make up some largeish number and hope for the best.
35 103   50 103   31424 use constant OPEN_MAX_FD => eval { sysconf(_SC_OPEN_MAX) } || 1024;
  103         174  
  103         161  
36              
37             # Some constants that define features of the OS
38              
39 103     103   631 use constant HAVE_SOCKADDR_IN6 => defined eval { pack_sockaddr_in6 0, inet_pton( AF_INET6, "2001::1" ) };
  103         202  
  103         153  
  103         7209  
40 103     103   656 use constant HAVE_SOCKADDR_UN => defined eval { pack_sockaddr_un "/foo" };
  103         187  
  103         172  
  103         4572  
41              
42             # Do we have to fake S_ISREG() files read/write-ready in select()?
43 103     103   483 use constant HAVE_FAKE_ISREG_READY => 0;
  103         155  
  103         3670  
44              
45             # Do we have to select() for for evec to get connect() failures
46 103     103   457 use constant HAVE_SELECT_CONNECT_EVEC => 0;
  103         158  
  103         3723  
47             # Ditto; do we have to poll() for POLLPRI to get connect() failures
48 103     103   513 use constant HAVE_POLL_CONNECT_POLLPRI => 0;
  103         153  
  103         3527  
49              
50             # Does connect() yield EWOULDBLOCK for nonblocking in progress?
51 103     103   456 use constant HAVE_CONNECT_EWOULDBLOCK => 0;
  103         164  
  103         3454  
52              
53             # Can we rename() files that are open?
54 103     103   434 use constant HAVE_RENAME_OPEN_FILES => 1;
  103         154  
  103         4196  
55              
56             # Can we reliably watch for POSIX signals, including SIGCHLD to reliably
57             # inform us that a fork()ed child has exit()ed?
58 103     103   472 use constant HAVE_SIGNALS => 1;
  103         166  
  103         4381  
59              
60             # Do we support POSIX-style true fork()ed processes at all?
61 103     103   482 use constant HAVE_POSIX_FORK => !$ENV{IO_ASYNC_NO_FORK};
  103         163  
  103         6068  
62             # Can we potentially support threads? (would still need to 'require threads')
63             use constant HAVE_THREADS => !$ENV{IO_ASYNC_NO_THREADS} &&
64 103   33 103   606 eval { require Config && $Config::Config{useithreads} };
  103         191  
  103         594  
65              
66             # Preferred trial order for built-in Loop classes
67 103     103   542 use constant LOOP_BUILTIN_CLASSES => qw( Poll Select );
  103         194  
  103         5189  
68              
69             # Should there be any other Loop classes we try before the builtin ones?
70 103     103   572 use constant LOOP_PREFER_CLASSES => ();
  103         208  
  103         101343  
71              
72             =head1 NAME
73              
74             C - operating system abstractions for C
75              
76             =head1 DESCRIPTION
77              
78             This module acts as a class to provide a number of utility methods whose exact
79             behaviour may depend on the type of OS it is running on. It is provided as a
80             class so that specific kinds of operating system can override methods in it.
81              
82             As well as these support functions it also provides a number of constants, all
83             with names beginning C which describe various features that may or may
84             not be available on the OS or perl build. Most of these are either hard-coded
85             per OS, or detected at runtime.
86              
87             The following constants may be overridden by environment variables.
88              
89             =over 4
90              
91             =item * HAVE_POSIX_FORK
92              
93             True if the C call has full POSIX semantics (full process separation).
94             This is true on most OSes but false on MSWin32.
95              
96             This may be overridden to be false by setting the environment variable
97             C.
98              
99             =item * HAVE_THREADS
100              
101             True if C are available, meaning that the C module can be
102             used. This depends on whether perl was built with threading support.
103              
104             This may be overridable to be false by setting the environment variable
105             C.
106              
107             =back
108              
109             =cut
110              
111             =head2 getfamilybyname
112              
113             $family = IO::Async::OS->getfamilybyname( $name )
114              
115             Return a protocol family value based on the given name. If C<$name> looks like
116             a number it will be returned as-is. The string values C, C and
117             C will be converted to the appropriate C constant.
118              
119             =cut
120              
121             sub getfamilybyname
122             {
123 152     152   218 shift;
124 152         250 my ( $name ) = @_;
125              
126 152 100       450 return undef unless defined $name;
127              
128 102 100       624 return $name if $name =~ m/^\d+$/;
129              
130 48 100       178 return AF_INET if $name eq "inet";
131 7 100 66     29 return AF_INET6() if $name eq "inet6" and defined &AF_INET6;
132 5 50       16 return AF_UNIX if $name eq "unix";
133              
134 0         0 croak "Unrecognised socket family name '$name'";
135             }
136              
137             =head2 getsocktypebyname
138              
139             $socktype = IO::Async::OS->getsocktypebyname( $name )
140              
141             Return a socket type value based on the given name. If C<$name> looks like a
142             number it will be returned as-is. The string values C, C and
143             C will be converted to the appropriate C constant.
144              
145             =cut
146              
147             sub getsocktypebyname
148             {
149 163     163   227 shift;
150 163         252 my ( $name ) = @_;
151              
152 163 100       389 return undef unless defined $name;
153              
154 114 100       434 return $name if $name =~ m/^\d+$/;
155              
156 52 100       213 return SOCK_STREAM if $name eq "stream";
157 18 50       95 return SOCK_DGRAM if $name eq "dgram";
158 0 0       0 return SOCK_RAW if $name eq "raw";
159              
160 0         0 croak "Unrecognised socktype name '$name'";
161             }
162              
163             # This one isn't documented because it's not really overridable. It's largely
164             # here just for completeness
165             my $HAVE_IO_SOCKET_IP;
166              
167             sub socket
168             {
169 44     44   21133 my $self = shift;
170 44         91 my ( $family, $socktype, $proto ) = @_;
171              
172 44         228 require IO::Socket;
173             defined $HAVE_IO_SOCKET_IP or
174 44 100       123 $HAVE_IO_SOCKET_IP = defined eval { require IO::Socket::IP };
  12         6591  
175              
176 44 50       55529 croak "Cannot create a new socket without a family" unless $family;
177             # PF_UNSPEC and undef are both false
178 44   50     145 $family = $self->getfamilybyname( $family ) || AF_UNIX;
179              
180             # SOCK_STREAM is the most likely
181 44   50     113 $socktype = $self->getsocktypebyname( $socktype ) || SOCK_STREAM;
182              
183 44 100       121 defined $proto or $proto = 0;
184              
185 44 100 100     184 if( $HAVE_IO_SOCKET_IP and ( $family == AF_INET || $family == AF_INET6() ) ) {
      66        
186 42         182 return IO::Socket::IP->new->socket( $family, $socktype, $proto );
187             }
188              
189 2         4 my $sock = eval {
190 2         10 IO::Socket->new(
191             Domain => $family,
192             Type => $socktype,
193             Proto => $proto,
194             );
195             };
196 2 50       273 return $sock if $sock;
197              
198             # That failed. Most likely because the Domain was unrecognised. This
199             # usually happens if getaddrinfo returns an AF_INET6 address but we don't
200             # have a suitable class loaded. In this case we'll return a generic one.
201             # It won't be in the specific subclass but that's the best we can do. And
202             # it will still work as a generic socket.
203 0         0 return IO::Socket->new->socket( $family, $socktype, $proto );
204             }
205              
206             =head2 socketpair
207              
208             ( $S1, $S2 ) = IO::Async::OS->socketpair( $family, $socktype, $proto )
209              
210             An abstraction of the C syscall, where any argument may be
211             missing (or given as C).
212              
213             If C<$family> is not provided, a suitable value will be provided by the OS
214             (likely C on POSIX-based platforms). If C<$socktype> is not provided,
215             then C will be used.
216              
217             Additionally, this method supports building connected C or
218             C pairs in the C family even if the underlying platform's
219             C does not, by connecting two normal sockets together.
220              
221             C<$family> and C<$socktype> may also be given symbolically as defined by
222             C and C.
223              
224             =cut
225              
226             sub socketpair
227             {
228 47     47   15470 my $self = shift;
229 47         127 my ( $family, $socktype, $proto ) = @_;
230              
231 47         6065 require IO::Socket;
232              
233             # PF_UNSPEC and undef are both false
234 47   100     92546 $family = $self->getfamilybyname( $family ) || AF_UNIX;
235              
236             # SOCK_STREAM is the most likely
237 47   100     169 $socktype = $self->getsocktypebyname( $socktype ) || SOCK_STREAM;
238              
239 47   50     225 $proto ||= 0;
240              
241 47         238 my ( $S1, $S2 ) = IO::Socket->new->socketpair( $family, $socktype, $proto );
242 47 100       11140 return ( $S1, $S2 ) if defined $S1;
243              
244 11 50 66     101 return unless $family == AF_INET and ( $socktype == SOCK_STREAM or $socktype == SOCK_DGRAM );
      33        
245              
246             # Now lets emulate an AF_INET socketpair call
247              
248 11 50       108 my $Stmp = IO::Async::OS->socket( $family, $socktype ) or return;
249 11 50       1529 $Stmp->bind( pack_sockaddr_in( 0, INADDR_LOOPBACK ) ) or return;
250              
251 11 50       339 $S1 = IO::Async::OS->socket( $family, $socktype ) or return;
252              
253 11 100       1147 if( $socktype == SOCK_STREAM ) {
254 2 50       21 $Stmp->listen( 1 ) or return;
255 2 50       74 $S1->connect( getsockname $Stmp ) or return;
256 2 50       246 $S2 = $Stmp->accept or return;
257              
258             # There's a bug in IO::Socket here, in that $S2 's ->socktype won't
259             # yet be set. We can apply a horribly hacky fix here
260             # defined $S2->socktype and $S2->socktype == $socktype or
261             # ${*$S2}{io_socket_type} = $socktype;
262             # But for now we'll skip the test for it instead
263             }
264             else {
265 9         22 $S2 = $Stmp;
266 9 50       102 $S1->connect( getsockname $S2 ) or return;
267 9 50       282 $S2->connect( getsockname $S1 ) or return;
268             }
269              
270 11         568 return ( $S1, $S2 );
271             }
272              
273             =head2 pipepair
274              
275             ( $rd, $wr ) = IO::Async::OS->pipepair
276              
277             An abstraction of the C syscall, which returns the two new handles.
278              
279             =cut
280              
281             sub pipepair
282             {
283 809     809   36966 my $self = shift;
284              
285 809 50       31040 pipe( my ( $rd, $wr ) ) or return;
286 809         6454 return ( $rd, $wr );
287             }
288              
289             =head2 pipequad
290              
291             ( $rdA, $wrA, $rdB, $wrB ) = IO::Async::OS->pipequad
292              
293             This method is intended for creating two pairs of filehandles that are linked
294             together, suitable for passing as the STDIN/STDOUT pair to a child process.
295             After this function returns, C<$rdA> and C<$wrA> will be a linked pair, as
296             will C<$rdB> and C<$wrB>.
297              
298             On platforms that support C, this implementation will be
299             preferred, in which case C<$rdA> and C<$wrB> will actually be the same
300             filehandle, as will C<$rdB> and C<$wrA>. This saves a file descriptor in the
301             parent process.
302              
303             When creating a L or subclass of it, the C
304             and C parameters should always be used.
305              
306             my ( $childRd, $myWr, $myRd, $childWr ) = IO::Async::OS->pipequad;
307              
308             $loop->open_process(
309             stdin => $childRd,
310             stdout => $childWr,
311             ...
312             );
313              
314             my $str = IO::Async::Stream->new(
315             read_handle => $myRd,
316             write_handle => $myWr,
317             ...
318             );
319             $loop->add( $str );
320              
321             =cut
322              
323             sub pipequad
324             {
325 2     2   4864 my $self = shift;
326              
327             # Prefer socketpair
328 2 50       32 if( my ( $S1, $S2 ) = $self->socketpair ) {
329 2         13 return ( $S1, $S2, $S2, $S1 );
330             }
331              
332             # Can't do that, fallback on pipes
333 0 0       0 my ( $rdA, $wrA ) = $self->pipepair or return;
334 0 0       0 my ( $rdB, $wrB ) = $self->pipepair or return;
335              
336 0         0 return ( $rdA, $wrA, $rdB, $wrB );
337             }
338              
339             =head2 signame2num
340              
341             $signum = IO::Async::OS->signame2num( $signame )
342              
343             This utility method converts a signal name (such as "TERM") into its system-
344             specific signal number. This may be useful to pass to C or use
345             in other places which use numbers instead of symbolic names.
346              
347             =head2 signum2name
348              
349             $signame = IO::Async::OS->signum2name( $signum )
350              
351             The inverse of L; this method convers signal numbers into
352             readable names.
353              
354             =cut
355              
356             my %sig_name2num;
357             my %sig_num2name;
358              
359             sub _init_signum
360             {
361 60     60   248 my $self = shift;
362              
363 60         1084 require Config;
364              
365             $Config::Config{sig_name} and $Config::Config{sig_num} or
366 60 50 33     16347 die "No signals found";
367              
368 60         1898 my @names = split ' ', $Config::Config{sig_name};
369 60         1425 my @nums = split ' ', $Config::Config{sig_num};
370              
371 60         4000 @sig_name2num{ @names } = @nums;
372 60         4815 @sig_num2name{ @nums } = @names;
373             }
374              
375             sub signame2num
376             {
377 215     215   1558 my $self = shift;
378 215         319 my ( $signame ) = @_;
379              
380 215 100       1858 %sig_name2num or $self->_init_signum;
381              
382 215         530 return $sig_name2num{$signame};
383             }
384              
385             sub signum2name
386             {
387 1     1   3 my $self = shift;
388 1         3 my ( $signum ) = @_;
389              
390 1 50       6 %sig_num2name or $self->_init_signum;
391              
392 1         5 return $sig_num2name{$signum};
393             }
394              
395             =head2 extract_addrinfo
396              
397             ( $family, $socktype, $protocol, $addr ) = IO::Async::OS->extract_addrinfo( $ai )
398              
399             Given an ARRAY or HASH reference value containing an addrinfo, returns a
400             family, socktype and protocol argument suitable for a C call and an
401             address suitable for C or C.
402              
403             If given an ARRAY it should be in the following form:
404              
405             [ $family, $socktype, $protocol, $addr ]
406              
407             If given a HASH it should contain the following keys:
408              
409             family socktype protocol addr
410              
411             Each field in the result will be initialised to 0 (or empty string for the
412             address) if not defined in the C<$ai> value.
413              
414             The family type may also be given as a symbolic string as defined by
415             C.
416              
417             The socktype may also be given as a symbolic string; C, C or
418             C; this will be converted to the appropriate C constant.
419              
420             Note that the C field, if provided, must be a packed socket address,
421             such as returned by C or C.
422              
423             If the HASH form is used, rather than passing a packed socket address in the
424             C field, certain other hash keys may be used instead for convenience on
425             certain named families.
426              
427             =over 4
428              
429             =cut
430              
431 103     103   762 use constant ADDRINFO_FAMILY => 0;
  103         276  
  103         5212  
432 103     103   557 use constant ADDRINFO_SOCKTYPE => 1;
  103         230  
  103         4856  
433 103     103   608 use constant ADDRINFO_PROTOCOL => 2;
  103         347  
  103         4927  
434 103     103   577 use constant ADDRINFO_ADDR => 3;
  103         187  
  103         122159  
435              
436             sub extract_addrinfo
437             {
438 55     55   1689 my $self = shift;
439 55         91 my ( $ai, $argname ) = @_;
440              
441 55   100     209 $argname ||= "addr";
442              
443 55         67 my @ai;
444              
445 55 100       180 if( ref $ai eq "ARRAY" ) {
    50          
446 4         109 @ai = @$ai;
447             }
448             elsif( ref $ai eq "HASH" ) {
449 51         158 $ai = { %$ai }; # copy so we can delete from it
450 51         86 @ai = delete @{$ai}{qw( family socktype protocol addr )};
  51         138  
451              
452 51 100 100     175 if( defined $ai[ADDRINFO_FAMILY] and !defined $ai[ADDRINFO_ADDR] ) {
453 15         20 my $family = $ai[ADDRINFO_FAMILY];
454 15         27 my $method = "_extract_addrinfo_$family";
455 15 100       172 my $code = $self->can( $method ) or croak "Cannot determine addr for extract_addrinfo on family='$family'";
456              
457 14         33 $ai[ADDRINFO_ADDR] = $code->( $self, $ai );
458              
459 14 100       240 keys %$ai and croak "Unrecognised '$family' addrinfo keys: " . join( ", ", keys %$ai );
460             }
461             }
462             else {
463 0         0 croak "Expected '$argname' to be an ARRAY or HASH reference";
464             }
465              
466 53         125 $ai[ADDRINFO_FAMILY] = $self->getfamilybyname( $ai[ADDRINFO_FAMILY] );
467 53         106 $ai[ADDRINFO_SOCKTYPE] = $self->getsocktypebyname( $ai[ADDRINFO_SOCKTYPE] );
468              
469             # Make sure all fields are defined
470 53   100     280 $ai[$_] ||= 0 for ADDRINFO_FAMILY, ADDRINFO_SOCKTYPE, ADDRINFO_PROTOCOL;
471 53 100       110 $ai[ADDRINFO_ADDR] = "" if !defined $ai[ADDRINFO_ADDR];
472              
473 53         219 return @ai;
474             }
475              
476             =item family => 'inet'
477              
478             Will pack an IP address and port number from keys called C and C.
479             If C is missing it will be set to "0.0.0.0". If C is missing it will
480             be set to 0.
481              
482             =cut
483              
484             sub _extract_addrinfo_inet
485             {
486 8     8   13 my $self = shift;
487 8         13 my ( $ai ) = @_;
488              
489 8   100     27 my $port = delete $ai->{port} || 0;
490 8   100     25 my $ip = delete $ai->{ip} || "0.0.0.0";
491              
492 8         49 return pack_sockaddr_in( $port, inet_aton( $ip ) );
493             }
494              
495             =item family => 'inet6'
496              
497             Will pack an IP address and port number from keys called C and C.
498             If C is missing it will be set to "::". If C is missing it will be
499             set to 0. Optionally will also include values from C and C
500             keys if provided.
501              
502             This will only work if a C function can be found in
503             C
504              
505             =cut
506              
507             sub _extract_addrinfo_inet6
508             {
509 1     1   2 my $self = shift;
510 1         2 my ( $ai ) = @_;
511              
512 1   50     5 my $port = delete $ai->{port} || 0;
513 1   50     10 my $ip = delete $ai->{ip} || "::";
514 1   50     8 my $scopeid = delete $ai->{scopeid} || 0;
515 1   50     5 my $flowinfo = delete $ai->{flowinfo} || 0;
516              
517 1         2 if( HAVE_SOCKADDR_IN6 ) {
518 1         9 return pack_sockaddr_in6( $port, inet_pton( AF_INET6, $ip ), $scopeid, $flowinfo );
519             }
520             else {
521             croak "Cannot pack_sockaddr_in6";
522             }
523             }
524              
525             =item family => 'unix'
526              
527             Will pack a UNIX socket path from a key called C.
528              
529             =cut
530              
531             sub _extract_addrinfo_unix
532             {
533 5     5   19 my $self = shift;
534 5         10 my ( $ai ) = @_;
535              
536 5 50       14 defined( my $path = delete $ai->{path} ) or croak "Expected 'path' for extract_addrinfo on family='unix'";
537              
538 5         20 return pack_sockaddr_un( $path );
539             }
540              
541             =pod
542              
543             =back
544              
545             =cut
546              
547             =head2 make_addr_for_peer
548              
549             $connectaddr = IO::Async::OS->make_addr_for_peer( $family, $listenaddr )
550              
551             Given the C and C of a listening socket. creates an
552             address suitable to C to it.
553              
554             This method will handle specially any C address bound to
555             C or any C address bound to C, as some OSes
556             do not allow Cing to those and would instead insist on receiving
557             C or C respectively.
558              
559             This method is used by the C<< ->connect( peer => $sock ) >> parameter of
560             handle and loop connect methods.
561              
562             =cut
563              
564             sub make_addr_for_peer
565             {
566 5     5   2231 shift;
567 5         11 my ( $p_family, $p_addr ) = @_;
568              
569 5 100       12 if( $p_family == Socket::AF_INET ) {
570 2         9 my @params = Socket::unpack_sockaddr_in $p_addr;
571 2 100       8 $params[1] = Socket::INADDR_LOOPBACK if $params[1] eq Socket::INADDR_ANY;
572 2         15 return Socket::pack_sockaddr_in @params;
573             }
574 3 100       8 if( HAVE_SOCKADDR_IN6 and $p_family == Socket::AF_INET6 ) {
575 2         12 my @params = Socket::unpack_sockaddr_in6 $p_addr;
576 2 100       6 $params[1] = Socket::IN6ADDR_LOOPBACK if $params[1] eq Socket::IN6ADDR_ANY;
577 2         14 return Socket::pack_sockaddr_in6 @params;
578             }
579              
580             # Most other cases should be fine
581 1         7 return $p_addr;
582             }
583              
584             =head1 LOOP IMPLEMENTATION METHODS
585              
586             The following methods are provided on C because they are likely
587             to require OS-specific implementations, but are used by L to
588             implement its functionality. It can use the HASH reference C<< $loop->{os} >>
589             to store other data it requires.
590              
591             =cut
592              
593             =head2 loop_watch_signal
594              
595             =head2 loop_unwatch_signal
596              
597             IO::Async::OS->loop_watch_signal( $loop, $signal, $code )
598              
599             IO::Async::OS->loop_unwatch_signal( $loop, $signal )
600              
601             Used to implement the C / C Loop pair.
602              
603             =cut
604              
605             sub _setup_sigpipe
606             {
607 61     61   231 my $self = shift;
608 61         150 my ( $loop ) = @_;
609              
610 61         17286 require IO::Async::Handle;
611              
612 61 50       671 my ( $reader, $sigpipe ) = $self->pipepair or croak "Cannot pipe() - $!";
613 61         1368 $_->blocking( 0 ) for $reader, $sigpipe;
614              
615 61         250 $loop->{os}{sigpipe} = $sigpipe;
616              
617 61         151 my $sigwatch = $loop->{os}{sigwatch};
618              
619             $loop->add( $loop->{os}{sigpipe_reader} = IO::Async::Handle->new(
620             notifier_name => "sigpipe",
621             read_handle => $reader,
622             on_read_ready => sub {
623 311 50   311   5091 sysread $reader, my $buffer, 8192 or return;
624 311         2162 foreach my $signum ( unpack "I*", $buffer ) {
625 319 50       2764 $sigwatch->{$signum}->() if $sigwatch->{$signum};
626             }
627             },
628 61         1953 ) );
629              
630 61         377 return $sigpipe;
631             }
632              
633             sub loop_watch_signal
634             {
635 72     72   344 my $self = shift;
636 72         265 my ( $loop, $signal, $code ) = @_;
637              
638 72 100       841 exists $SIG{$signal} or croak "Unrecognised signal name $signal";
639 69 50       438 ref $code or croak 'Expected $code as a reference';
640              
641 69         1463 my $signum = $self->signame2num( $signal );
642 69   100     1190 my $sigwatch = $loop->{os}{sigwatch} ||= {}; # {$num} = $code
643              
644 69   66     1166 my $sigpipe = $loop->{os}{sigpipe} // $self->_setup_sigpipe( $loop );
645              
646 69         438 my $signum_str = pack "I", $signum;
647 69     324   1387 $SIG{$signal} = sub { syswrite $sigpipe, $signum_str };
  324         24418  
648              
649 69         432 $sigwatch->{$signum} = $code;
650             }
651              
652             sub loop_unwatch_signal
653             {
654 9     9   21 my $self = shift;
655 9         19 my ( $loop, $signal ) = @_;
656              
657 9         35 my $signum = $self->signame2num( $signal );
658 9 50       34 my $sigwatch = $loop->{os}{sigwatch} or return;
659              
660 9         45 delete $sigwatch->{$signum};
661 9         150 undef $SIG{$signal};
662             }
663              
664             =head2 potentially_open_fds
665              
666             @fds = IO::Async::OS->potentially_open_fds
667              
668             Returns a list of filedescriptors which might need closing. By default this
669             will return C<0 .. _SC_OPEN_MAX>. OS-specific subclasses may have a better
670             guess.
671              
672             =cut
673              
674             sub potentially_open_fds
675             {
676 0     0   0 return 0 .. OPEN_MAX_FD;
677             }
678              
679             sub post_fork
680             {
681 2     2   4 my $self = shift;
682 2         5 my ( $loop ) = @_;
683              
684 2 50       9 if( $loop->{os}{sigpipe} ) {
685 2         13 $loop->remove( $loop->{os}{sigpipe_reader} );
686 2         6 undef $loop->{os}{sigpipe};
687              
688 2         4 my $sigwatch = $loop->{os}{sigwatch};
689              
690 2         41 foreach my $signal ( keys %SIG ) {
691 136 50       174 my $signum = $self->signame2num( $signal ) or next;
692 136 100       225 my $code = $sigwatch->{$signum} or next;
693              
694 2         8 $self->loop_watch_signal( $loop, $signal, $code );
695             }
696             }
697             }
698              
699             =head1 AUTHOR
700              
701             Paul Evans
702              
703             =cut
704              
705             0x55AA;