view release on metacpan or  search on metacpan

local/lib/perl5/IO/Async/OS.pm  view on Meta::CPAN

package IO::Async::OS;

use strict;
use warnings;

our $VERSION = '0.70';

our @ISA = qw( IO::Async::OS::_Base );

if( eval { require "IO/Async/OS/$^O.pm" } ) {
   @ISA = "IO::Async::OS::$^O";
}

package # hide from CPAN
   IO::Async::OS::_Base;

use Carp;

use Socket 1.95 qw(
   AF_INET AF_INET6 AF_UNIX INADDR_LOOPBACK SOCK_DGRAM SOCK_RAW SOCK_STREAM
   pack_sockaddr_in inet_aton
   pack_sockaddr_in6 inet_pton
   pack_sockaddr_un
);

use IO::Socket (); # empty import

use POSIX qw( sysconf _SC_OPEN_MAX );

# Win32 [and maybe other places] don't have an _SC_OPEN_MAX. About the best we
# can do really is just make up some largeish number and hope for the best.
use constant OPEN_MAX_FD => eval { sysconf(_SC_OPEN_MAX) } || 1024;

# Some constants that define features of the OS

use constant HAVE_SOCKADDR_IN6 => defined eval { pack_sockaddr_in6 0, inet_pton( AF_INET6, "2001::1" ) };
use constant HAVE_SOCKADDR_UN  => defined eval { pack_sockaddr_un "/foo" };

# Do we have to fake S_ISREG() files read/write-ready in select()?
use constant HAVE_FAKE_ISREG_READY => 0;

# Do we have to select() for for evec to get connect() failures
use constant HAVE_SELECT_CONNECT_EVEC => 0;
# Ditto; do we have to poll() for POLLPRI to get connect() failures
use constant HAVE_POLL_CONNECT_POLLPRI => 0;

# Does connect() yield EWOULDBLOCK for nonblocking in progress?
use constant HAVE_CONNECT_EWOULDBLOCK => 0;

# Can we rename() files that are open?
use constant HAVE_RENAME_OPEN_FILES => 1;

# Do we have IO::Socket::IP available?
use constant HAVE_IO_SOCKET_IP => defined eval { require IO::Socket::IP };

# Can we reliably watch for POSIX signals, including SIGCHLD to reliably
# inform us that a fork()ed child has exit()ed?
use constant HAVE_SIGNALS => 1;

# Do we support POSIX-style true fork()ed processes at all?
use constant HAVE_POSIX_FORK => !$ENV{IO_ASYNC_NO_FORK};
# Can we potentially support threads? (would still need to 'require threads')
use constant HAVE_THREADS => !$ENV{IO_ASYNC_NO_THREADS} &&
   eval { require Config && $Config::Config{useithreads} };

# Preferred trial order for built-in Loop classes
use constant LOOP_BUILTIN_CLASSES => qw( Poll Select );

# Should there be any other Loop classes we try before the builtin ones?
use constant LOOP_PREFER_CLASSES => ();

# Do we have Sereal available?
use constant HAVE_SEREAL => defined eval { require Sereal::Encoder; require Sereal::Decoder; };

=head1 NAME

C<IO::Async::OS> - operating system abstractions for C<IO::Async>

=head1 DESCRIPTION

This module acts as a class to provide a number of utility methods whose exact
behaviour may depend on the type of OS it is running on. It is provided as a
class so that specific kinds of operating system can override methods in it.

As well as these support functions it also provides a number of constants, all
with names beginning C<HAVE_> which describe various features that may or may
not be available on the OS or perl build. Most of these are either hard-coded
per OS, or detected at runtime.

The following constants may be overridden by environment variables.

=over 4

=item * HAVE_POSIX_FORK

True if the C<fork()> call has full POSIX semantics (full process separation).
This is true on most OSes but false on MSWin32.

This may be overridden to be false by setting the environment variable
C<IO_ASYNC_NO_FORK>.

=item * HAVE_THREADS

True if C<ithreads> are available, meaning that the C<threads> module can be
used. This depends on whether perl was built with threading support.

This may be overridable to be false by setting the environment variable
C<IO_ASYNC_NO_THREADS>.

=back

=cut

=head2 getfamilybyname

   $family = IO::Async::OS->getfamilybyname( $name )

Return a protocol family value based on the given name. If C<$name> looks like
a number it will be returned as-is. The string values C<inet>, C<inet6> and
C<unix> will be converted to the appropriate C<AF_*> constant.

=cut

sub getfamilybyname
{
   shift;
   my ( $name ) = @_;

   return undef unless defined $name;

   return $name if $name =~ m/^\d+$/;

   return AF_INET    if $name eq "inet";
   return AF_INET6() if $name eq "inet6" and defined &AF_INET6;
   return AF_UNIX    if $name eq "unix";

   croak "Unrecognised socket family name '$name'";
}

=head2 getsocktypebyname

   $socktype = IO::Async::OS->getsocktypebyname( $name )

Return a socket type value based on the given name. If C<$name> looks like a
number it will be returned as-is. The string values C<stream>, C<dgram> and
C<raw> will be converted to the appropriate C<SOCK_*> constant.

=cut

sub getsocktypebyname
{
   shift;
   my ( $name ) = @_;

   return undef unless defined $name;

local/lib/perl5/IO/Async/OS.pm  view on Meta::CPAN

   $family = $self->getfamilybyname( $family ) || AF_UNIX;

   # SOCK_STREAM is the most likely
   $socktype = $self->getsocktypebyname( $socktype ) || SOCK_STREAM;

   $proto ||= 0;

   my ( $S1, $S2 ) = IO::Socket->new->socketpair( $family, $socktype, $proto );
   return ( $S1, $S2 ) if defined $S1;

   return unless $family == AF_INET and ( $socktype == SOCK_STREAM or $socktype == SOCK_DGRAM );

   # Now lets emulate an AF_INET socketpair call

   my $Stmp = IO::Async::OS->socket( $family, $socktype ) or return;
   $Stmp->bind( pack_sockaddr_in( 0, INADDR_LOOPBACK ) ) or return;

   $S1 = IO::Async::OS->socket( $family, $socktype ) or return;

   if( $socktype == SOCK_STREAM ) {
      $Stmp->listen( 1 ) or return;
      $S1->connect( getsockname $Stmp ) or return;
      $S2 = $Stmp->accept or return;

      # There's a bug in IO::Socket here, in that $S2 's ->socktype won't
      # yet be set. We can apply a horribly hacky fix here
      #   defined $S2->socktype and $S2->socktype == $socktype or
      #     ${*$S2}{io_socket_type} = $socktype;
      # But for now we'll skip the test for it instead
   }
   else {
      $S2 = $Stmp;
      $S1->connect( getsockname $S2 ) or return;
      $S2->connect( getsockname $S1 ) or return;
   }

   return ( $S1, $S2 );
}

=head2 pipepair

   ( $rd, $wr ) = IO::Async::OS->pipepair

An abstraction of the C<pipe(2)> syscall, which returns the two new handles.

=cut

sub pipepair
{
   my $self = shift;

   pipe( my ( $rd, $wr ) ) or return;
   return ( $rd, $wr );
}

=head2 pipequad

   ( $rdA, $wrA, $rdB, $wrB ) = IO::Async::OS->pipequad

This method is intended for creating two pairs of filehandles that are linked
together, suitable for passing as the STDIN/STDOUT pair to a child process.
After this function returns, C<$rdA> and C<$wrA> will be a linked pair, as
will C<$rdB> and C<$wrB>.

On platforms that support C<socketpair(2)>, this implementation will be
preferred, in which case C<$rdA> and C<$wrB> will actually be the same
filehandle, as will C<$rdB> and C<$wrA>. This saves a file descriptor in the
parent process.

When creating a L<IO::Async::Stream> or subclass of it, the C<read_handle>
and C<write_handle> parameters should always be used.

 my ( $childRd, $myWr, $myRd, $childWr ) = IO::Async::OS->pipequad;

 IO::Async::OS->open_child(
    stdin  => $childRd,
    stdout => $childWr,
    ...
 );

 my $str = IO::Async::Stream->new(
    read_handle  => $myRd,
    write_handle => $myWr,
    ...
 );
 IO::Async::OS->add( $str );

=cut

sub pipequad
{
   my $self = shift;

   # Prefer socketpair
   if( my ( $S1, $S2 ) = $self->socketpair ) {
      return ( $S1, $S2, $S2, $S1 );
   }

   # Can't do that, fallback on pipes
   my ( $rdA, $wrA ) = $self->pipepair or return;
   my ( $rdB, $wrB ) = $self->pipepair or return;

   return ( $rdA, $wrA, $rdB, $wrB );
}

=head2 signame2num

   $signum = IO::Async::OS->signame2num( $signame )

This utility method converts a signal name (such as "TERM") into its system-
specific signal number. This may be useful to pass to C<POSIX::SigSet> or use
in other places which use numbers instead of symbolic names.

=cut

my %sig_num;
sub _init_signum
{
   my $self = shift;
   # Copypasta from Config.pm's documentation

   our %Config;
   require Config;
   Config->import;

   unless($Config{sig_name} && $Config{sig_num}) {
      die "No signals found";
   }