File Coverage

blib/lib/POE/Wheel/SocketFactory.pm

Criterion	Covered	Total	%
statement	256	404	63.3
branch	118	256	46.0
condition	21	62	33.8
subroutine	26	28	92.8
pod	6	7	85.7
total	427	757	56.4

package POE::Wheel::SocketFactory;

use strict;

use vars qw($VERSION @ISA);
$VERSION = '1.366'; # NOTE - Should be #.### (three decimal places)

use Carp qw( carp croak );
use Symbol qw( gensym );

use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
use Errno qw(
  EWOULDBLOCK EADDRNOTAVAIL EINPROGRESS EADDRINUSE ECONNABORTED
  ESPIPE
);

use Socket qw(
  AF_INET SOCK_STREAM SOL_SOCKET AF_UNIX PF_UNIX
  PF_INET SOCK_DGRAM SO_ERROR unpack_sockaddr_in
  unpack_sockaddr_un PF_UNSPEC SO_REUSEADDR INADDR_ANY
  pack_sockaddr_in pack_sockaddr_un inet_aton SOMAXCONN
);

use IO::Handle ();
use FileHandle ();
use POE qw( Wheel );
push @ISA, qw(POE::Wheel);

sub CRIMSON_SCOPE_HACK ($) { 0 }
sub DEBUG () { 0 }

sub MY_SOCKET_HANDLE   () {  0 }
sub MY_UNIQUE_ID       () {  1 }
sub MY_EVENT_SUCCESS   () {  2 }
sub MY_EVENT_FAILURE   () {  3 }
sub MY_SOCKET_DOMAIN   () {  4 }
sub MY_STATE_ACCEPT    () {  5 }
sub MY_STATE_CONNECT   () {  6 }
sub MY_MINE_SUCCESS    () {  7 }
sub MY_MINE_FAILURE    () {  8 }
sub MY_SOCKET_PROTOCOL () {  9 }
sub MY_SOCKET_TYPE     () { 10 }
sub MY_STATE_ERROR     () { 11 }
sub MY_SOCKET_SELECTED () { 12 }

# Fletch has subclassed SSLSocketFactory from SocketFactory.
# He's added new members after MY_SOCKET_SELECTED.  Be sure, if you
# extend this, to extend add stuff BEFORE MY_SOCKET_SELECTED or let
# Fletch know you've broken his module.

# If IPv6 support can't be loaded, then provide dummies so the code at
# least compiles.  Suggested in rt.cpan.org 27250.
BEGIN {

  eval { Socket->import( qw(getaddrinfo getnameinfo unpack_sockaddr_in6) ) };
  if ($@) {
    *getaddrinfo = sub { Carp::confess("Unable to use IPv6: Socket doesn't provide getaddrinfo()") };
    *getnameinfo = sub { Carp::confess("Unable to use IPv6: Socket doesn't provide getnameinfo()") };
    *unpack_sockaddr_in6 = sub { Carp::confess("Unable to use IPv6: Socket doesn't provide unpack_sockaddr_in6()") };
  }

  # Socket6 provides AF_INET6 and PF_INET6 where earlier Perls' Socket don't.
  eval { Socket->import( qw(AF_INET6 PF_INET6) ) };
  if ($@) {
    eval { require Socket6; Socket6->import( qw(AF_INET6 PF_INET6) ) };
    if ($@) {
      *AF_INET6 = sub { -1 };
      *PF_INET6 = sub { -1 };
    }
  }

  eval { Socket->import( 'IPPROTO_TCP' ) };
  if ($@) {
    *IPPROTO_TCP = (getprotobyname 'tcp')[2];
  }

  eval { Socket->import( 'IPPROTO_UDP' ) };
  if ($@) {
    *IPPROTO_UDP = (getprotobyname 'udp')[2];
  }
}

# Common protocols to help support systems that don't have
# getprotobyname().
my %proto_by_name = (
    tcp => IPPROTO_TCP,
    udp => IPPROTO_UDP,
);

my %proto_by_number = reverse %proto_by_name;

#------------------------------------------------------------------------------
# These tables customize the socketfactory.  Many protocols share the
# same operations, it seems, and this is a way to add new ones with a
# minimum of additional code.

sub DOM_UNIX  () { 'unix'  }  # UNIX domain socket
sub DOM_INET  () { 'inet'  }  # INET domain socket
sub DOM_INET6 () { 'inet6' }  # INET v6 domain socket

# AF_XYZ and PF_XYZ may be different.
my %map_family_to_domain = (
  AF_UNIX,  DOM_UNIX,  PF_UNIX,  DOM_UNIX,
  AF_INET,  DOM_INET,  PF_INET,  DOM_INET,
  AF_INET6, DOM_INET6,
  PF_INET6, DOM_INET6,
);

sub SVROP_LISTENS () { 'listens' }  # connect/listen sockets
sub SVROP_NOTHING () { 'nothing' }  # connectionless sockets

# Map family/protocol pairs to connection or connectionless
# operations.
my %supported_protocol = (
  DOM_UNIX, {
    none => SVROP_LISTENS
  },
  DOM_INET, {
    tcp  => SVROP_LISTENS,
    udp  => SVROP_NOTHING,
  },
  DOM_INET6, {
    tcp  => SVROP_LISTENS,
    udp  => SVROP_NOTHING,
  },
);

# Sane default socket types for each supported protocol.  TODO Maybe
# this structure can be combined with %supported_protocol?
my %default_socket_type = (
  DOM_UNIX, {
    none => SOCK_STREAM
  },
  DOM_INET, {
    tcp  => SOCK_STREAM,
    udp  => SOCK_DGRAM,
  },
  DOM_INET6, {
    tcp  => SOCK_STREAM,
    udp  => SOCK_DGRAM,
  },
);

#------------------------------------------------------------------------------
# Perform system-dependent translations on Unix addresses, if
# necessary.

sub _condition_unix_address {
  my ($address) = @_;

  # OS/2 would like sockets to use backwhacks, and please place them
  # in the virtual \socket\ directory.  Thank you.
  if ($^O eq 'os2') {
    $address =~ tr[\\][/];
    if ($address !~ m{^/socket/}) {
      $address =~ s{^/?}{/socket/};
    }
    $address =~ tr[/][\\];
  }

  $address;
}

#------------------------------------------------------------------------------
# Define the select handler that will accept connections.

sub _define_accept_state {
  my $self = shift;

  # We do these stupid closure tricks to avoid putting $self in it
  # directly.  If you include $self in one of the state() closures,
  # the component will fail to shut down properly: there will be a
  # circular definition in the closure holding $self alive.

  my $domain = $map_family_to_domain{ $self->[MY_SOCKET_DOMAIN] };
  $domain = '(undef)' unless defined $domain;
  my $event_success = \$self->[MY_EVENT_SUCCESS];
  my $event_failure = \$self->[MY_EVENT_FAILURE];
  my $unique_id     =  $self->[MY_UNIQUE_ID];

  $poe_kernel->state(
    $self->[MY_STATE_ACCEPT] = ref($self) . "($unique_id) -> select accept",
    sub {
      # prevents SEGV
      0 && CRIMSON_SCOPE_HACK('<');

      # subroutine starts here
      my ($k, $me, $handle) = @_[KERNEL, SESSION, ARG0];

      my $new_socket = gensym;
      my $peer = accept($new_socket, $handle);

      if ($peer) {
        my ($peer_addr, $peer_port);
        if ( $domain eq DOM_UNIX ) {
          $peer_port = undef;
          eval { $peer_addr = unpack_sockaddr_un($peer) };
          $peer_addr = undef if length $@;
        }
        elsif ( $domain eq DOM_INET ) {
          ($peer_port, $peer_addr) = unpack_sockaddr_in($peer);
        }
        elsif ( $domain eq DOM_INET6 ) {
          ($peer_addr, $peer_port) = unpack_sockaddr_in6($peer);
        }
        else {
          die "sanity failure: socket domain == $domain";
        }
        $k->call(
          $me, $$event_success,
          $new_socket, $peer_addr, $peer_port,
          $unique_id
        );
      }
      elsif ($! != EWOULDBLOCK and $! != ECONNABORTED and $! != ESPIPE) {
        # OSX reports ESPIPE, which isn't documented anywhere.
        $$event_failure && $k->call(
          $me, $$event_failure,
          'accept', ($!+0), $!, $unique_id
        );
      }
    }
  );

  $self->[MY_SOCKET_SELECTED] = 'yes';
  $poe_kernel->select_read(
    $self->[MY_SOCKET_HANDLE],
    $self->[MY_STATE_ACCEPT]
  );
}

#------------------------------------------------------------------------------
# Define the select handler that will finalize an established
# connection.

sub _define_connect_state {
  my $self = shift;

  # We do these stupid closure tricks to avoid putting $self in it
  # directly.  If you include $self in one of the state() closures,
  # the component will fail to shut down properly: there will be a
  # circular definition in the closure holding $self alive.

  my $domain = $map_family_to_domain{ $self->[MY_SOCKET_DOMAIN] };
  $domain = '(undef)' unless defined $domain;
  my $event_success   = \$self->[MY_EVENT_SUCCESS];
  my $event_failure   = \$self->[MY_EVENT_FAILURE];
  my $unique_id       =  $self->[MY_UNIQUE_ID];
  my $socket_selected = \$self->[MY_SOCKET_SELECTED];

  my $socket_handle   = \$self->[MY_SOCKET_HANDLE];
  my $state_accept    = \$self->[MY_STATE_ACCEPT];
  my $state_connect   = \$self->[MY_STATE_CONNECT];
  my $mine_success    = \$self->[MY_MINE_SUCCESS];
  my $mine_failure    = \$self->[MY_MINE_FAILURE];

  $poe_kernel->state(
    $self->[MY_STATE_CONNECT] = (
      ref($self) .  "($unique_id) -> select connect"
    ),
    sub {
      # This prevents SEGV in older versions of Perl.
      0 && CRIMSON_SCOPE_HACK('<');

      # Grab some values and stop watching the socket.
      my ($k, $me, $handle) = @_[KERNEL, SESSION, ARG0];

      _shutdown(
        $socket_selected, $socket_handle,
        $state_accept, $state_connect,
        $mine_success, $event_success,
        $mine_failure, $event_failure,
      );

      # Throw a failure if the connection failed.
      $! = unpack('i', getsockopt($handle, SOL_SOCKET, SO_ERROR));
      if ($!) {
        (defined $$event_failure) and $k->call(
          $me, $$event_failure,
          'connect', ($!+0), $!, $unique_id
        );
        return;
      }

      # Get the remote address, or throw an error if that fails.
      my $peer = getpeername($handle);
      if ($!) {
        (defined $$event_failure) and $k->call(
          $me, $$event_failure,
          'getpeername', ($!+0), $!, $unique_id
        );
        return;
      }

      # Parse the remote address according to the socket's domain.
      my ($peer_addr, $peer_port);

      # UNIX sockets have some trouble with peer addresses.
      if ($domain eq DOM_UNIX) {
        if (defined $peer) {
          eval { $peer_addr = unpack_sockaddr_un($peer) };
          $peer_addr = undef if length $@;
        }
      }

      # INET socket stacks tend not to.
      elsif ($domain eq DOM_INET) {
        if (defined $peer) {
          eval {
            ($peer_port, $peer_addr) = unpack_sockaddr_in($peer);
          };
          if (length $@) {
            $peer_port = $peer_addr = undef;
          }
        }
      }

      # INET6 socket stacks tend not to.
      elsif ($domain eq DOM_INET6) {
        if (defined $peer) {
          ((my $error), $peer_addr, $peer_port) = getnameinfo($peer);
          if ($error) {
            warn $error;
            $peer_port = $peer_addr = undef;
          }
        }
      }

      # What are we doing here?
      else {
        die "sanity failure: socket domain == $domain";
      }

      # Tell the session it went okay.  Also let go of the socket.
      $k->call(
        $me, $$event_success,
        $handle, $peer_addr, $peer_port, $unique_id
      );
    }
  );

  # Cygwin and Windows expect an error state registered to expedite.
  # This code is nearly identical the stuff above.
  if ($^O eq "cygwin" or $^O eq "MSWin32") {
    $poe_kernel->state(
      $self->[MY_STATE_ERROR] = (
        ref($self) .  "($unique_id) -> connect error"
      ),
      sub {
        # This prevents SEGV in older versions of Perl.
        0 && CRIMSON_SCOPE_HACK('<');

        # Grab some values and stop watching the socket.
        my ($k, $me, $handle) = @_[KERNEL, SESSION, ARG0];

        _shutdown(
          $socket_selected, $socket_handle,
          $state_accept, $state_connect,
          $mine_success, $event_success,
          $mine_failure, $event_failure,
        );

        # Throw a failure if the connection failed.
        $! = unpack('i', getsockopt($handle, SOL_SOCKET, SO_ERROR));
        if ($!) {
          (defined $$event_failure) and $k->call(
            $me, $$event_failure, 'connect', ($!+0), $!, $unique_id
          );
          return;
        }
      }
    );
    $poe_kernel->select_expedite(
      $self->[MY_SOCKET_HANDLE],
      $self->[MY_STATE_ERROR]
    );
  }

  $self->[MY_SOCKET_SELECTED] = 'yes';
  $poe_kernel->select_write(
    $self->[MY_SOCKET_HANDLE],
    $self->[MY_STATE_CONNECT]
  );
}

#------------------------------------------------------------------------------

sub event {
  my $self = shift;
  push(@_, undef) if (scalar(@_) & 1);

  while (@_) {
    my ($name, $event) = splice(@_, 0, 2);

    if ($name eq 'SuccessEvent') {
      if (defined $event) {
        if (ref($event)) {
          carp "reference for SuccessEvent will be treated as an event name"
        }
        $self->[MY_EVENT_SUCCESS] = $event;
        undef $self->[MY_MINE_SUCCESS];
      }
      else {
        carp "SuccessEvent requires an event name.  ignoring undef";
      }
    }
    elsif ($name eq 'FailureEvent') {
      if (defined $event) {
        if (ref($event)) {
          carp "reference for FailureEvent will be treated as an event name";
        }
        $self->[MY_EVENT_FAILURE] = $event;
        undef $self->[MY_MINE_FAILURE];
      }
      else {
        carp "FailureEvent requires an event name.  ignoring undef";
      }
    }
    else {
      carp "ignoring unknown SocketFactory parameter '$name'";
    }
  }

  $self->[MY_SOCKET_SELECTED] = 'yes';
  if (defined $self->[MY_STATE_ACCEPT]) {
    $poe_kernel->select_read(
      $self->[MY_SOCKET_HANDLE],
      $self->[MY_STATE_ACCEPT]
     );
  }
  elsif (defined $self->[MY_STATE_CONNECT]) {
    $poe_kernel->select_write(
      $self->[MY_SOCKET_HANDLE],
      $self->[MY_STATE_CONNECT]
    );
    if ($^O eq "cygwin" or $^O eq "MSWin32") {
      $poe_kernel->select_expedite(
        $self->[MY_SOCKET_HANDLE],
        $self->[MY_STATE_ERROR]
      );
    }
  }
  else {
    die "POE developer error - no state defined";
  }
}

#------------------------------------------------------------------------------

sub getsockname {
  my $self = shift;
  return undef unless (
    defined $self->[MY_SOCKET_HANDLE] and
    fileno($self->[MY_SOCKET_HANDLE])
  );
  return getsockname($self->[MY_SOCKET_HANDLE]);
}

sub ID {
  return $_[0]->[MY_UNIQUE_ID];
}

#------------------------------------------------------------------------------

sub new {
  my $type = shift;

  # Don't take responsibility for a bad parameter count.
  croak "$type requires an even number of parameters" if @_ & 1;

  my %params = @_;

  # The calling convention experienced a hard deprecation.
  croak "wheels no longer require a kernel reference as their first parameter"
    if (@_ && (ref($_[0]) eq 'POE::Kernel'));

  # Ensure some of the basic things are present.
  croak "$type requires a working Kernel" unless (defined $poe_kernel);
  croak 'SuccessEvent required' unless (defined $params{SuccessEvent});
  croak 'FailureEvent required' unless (defined $params{FailureEvent});
  my $event_success = $params{SuccessEvent};
  my $event_failure = $params{FailureEvent};

  # Create the SocketServer.  Cache a copy of the socket handle.
  my $socket_handle = gensym();
  my $self = bless(
    [
      $socket_handle,                   # MY_SOCKET_HANDLE
      &POE::Wheel::allocate_wheel_id(), # MY_UNIQUE_ID
      $event_success,                   # MY_EVENT_SUCCESS
      $event_failure,                   # MY_EVENT_FAILURE
      undef,                            # MY_SOCKET_DOMAIN
      undef,                            # MY_STATE_ACCEPT
      undef,                            # MY_STATE_CONNECT
      undef,                            # MY_MINE_SUCCESS
      undef,                            # MY_MINE_FAILURE
      undef,                            # MY_SOCKET_PROTOCOL
      undef,                            # MY_SOCKET_TYPE
      undef,                            # MY_STATE_ERROR
      undef,                            # MY_SOCKET_SELECTED
    ],
    $type
  );

  # Default to Internet sockets.
  my $domain = delete $params{SocketDomain};
  if (defined $domain) {
    # [rt.cpan.org 76314] Untaint the domain.
    ($domain) = ($domain =~ /\A(.*)\z/s);
  }
  else {
    $domain = AF_INET;
  }
  $self->[MY_SOCKET_DOMAIN] = $domain;

  # Abstract the socket domain into something we don't have to keep
  # testing duplicates of.
  my $abstract_domain = $map_family_to_domain{$self->[MY_SOCKET_DOMAIN]};
  unless (defined $abstract_domain) {
    $poe_kernel->yield(
      $event_failure,
      'domain',
      0,
      "SocketDomain $domain is currently unsupported on this platform",
      $self->[MY_UNIQUE_ID]
    );
    return $self;
  }

  #---------------#
  # Create Socket #
  #---------------#

  # Declare the protocol name out here; it'll be needed by
  # getservbyname later.
  my $protocol_name;

  # Unix sockets don't use protocols; warn the programmer, and force
  # PF_UNSPEC.
  if ($abstract_domain eq DOM_UNIX) {
    carp 'SocketProtocol ignored for Unix socket'
      if defined $params{SocketProtocol};
    $self->[MY_SOCKET_PROTOCOL] = PF_UNSPEC;
    $protocol_name = 'none';
  }

  # Internet sockets use protocols.  Default the INET protocol to tcp,
  # and try to resolve it.
  elsif (
    $abstract_domain eq DOM_INET or
    $abstract_domain eq DOM_INET6
  ) {
    my $socket_protocol = (
      (defined $params{SocketProtocol})
      ? $params{SocketProtocol}
      : 'tcp'
    );


    if ($socket_protocol !~ /^\d+$/) {
      unless ($socket_protocol = $proto_by_name{$socket_protocol} || eval { getprotobyname($socket_protocol) }) {
        $poe_kernel->yield(
          $event_failure, 'getprotobyname', $!+0, $!, $self->[MY_UNIQUE_ID]
        );
        return $self;
      }
    }

    # Get the protocol's name regardless of what was provided.  If the
    # protocol isn't supported, croak now instead of making the
    # programmer wonder why things fail later.
    $protocol_name = $proto_by_number{$socket_protocol} || eval { lc(getprotobynumber($socket_protocol)) };
    unless ($protocol_name) {
      $poe_kernel->yield(
        $event_failure, 'getprotobynumber', $!+0, $!, $self->[MY_UNIQUE_ID]
      );
      return $self;
    }

    unless (defined $supported_protocol{$abstract_domain}->{$protocol_name}) {
      croak "SocketFactory does not support Internet $protocol_name sockets";
    }

    $self->[MY_SOCKET_PROTOCOL] = $socket_protocol;
  }
  else {
    die "Mail this error to the author of POE: Internal consistency error";
  }

  # If no SocketType, default it to something appropriate.
  if (defined $params{SocketType}) {
    $self->[MY_SOCKET_TYPE] = $params{SocketType};
  }
  else {
    unless (defined $default_socket_type{$abstract_domain}->{$protocol_name}) {
      croak "SocketFactory does not support $abstract_domain $protocol_name";
    }
    $self->[MY_SOCKET_TYPE] =
      $default_socket_type{$abstract_domain}->{$protocol_name};
  }

  # o  create a dummy socket
  # o  cache the value of SO_OPENTYPE in $win32_socket_opt
  # o  set the overlapped io attribute
  # o  close dummy socket
  my $win32_socket_opt;
  if ( POE::Kernel::RUNNING_IN_HELL) {

    # Constants are evaluated first so they exist when the code uses
    # them.
    eval {
      *SO_OPENTYPE     = sub () { 0x7008 };
      *SO_SYNCHRONOUS_ALERT    = sub () { 0x10 };
      *SO_SYNCHRONOUS_NONALERT = sub () { 0x20 };
    };
    die "Could not install SO constants [$@]" if $@;

    # Turn on socket overlapped IO attribute per MSKB: Q181611.

    eval {
      socket(POE, AF_INET, SOCK_STREAM, IPPROTO_TCP)
        or die "socket failed: $!";
      my $opt = unpack("I", getsockopt(POE, SOL_SOCKET, SO_OPENTYPE()));
      $win32_socket_opt = $opt;
      $opt &= ~(SO_SYNCHRONOUS_ALERT()|SO_SYNCHRONOUS_NONALERT());
      setsockopt(POE, SOL_SOCKET, SO_OPENTYPE(), $opt);
      close POE;
    };

    die if $@;
  }

  # Create the socket.
  unless (
    socket( $socket_handle, $self->[MY_SOCKET_DOMAIN],
      $self->[MY_SOCKET_TYPE], $self->[MY_SOCKET_PROTOCOL]
    )
  ) {
    $poe_kernel->yield(
      $event_failure, 'socket', $!+0, $!, $self->[MY_UNIQUE_ID]
    );
    return $self;
  }

  # o  create a dummy socket
  # o  restore previous value of SO_OPENTYPE
  # o  close dummy socket
  #
  # This way we'd only be turning on the overlap attribute for
  # the socket we created... and not all subsequent sockets.
  if ( POE::Kernel::RUNNING_IN_HELL) {
    eval {
      socket(POE, AF_INET, SOCK_STREAM, IPPROTO_TCP)
        or die "socket failed: $!";
      setsockopt(POE, SOL_SOCKET, SO_OPENTYPE(), $win32_socket_opt);
      close POE;
    };

    die if $@;
  }
  DEBUG && warn "socket";

  #------------------#
  # Configure Socket #
  #------------------#

  # Make the socket binary.  It's wrapped in eval{} because tied
  # filehandle classes may actually die in their binmode methods.
  eval { binmode($socket_handle) };

  # Don't block on socket operations, because the socket will be
  # driven by a select loop.
  $socket_handle->blocking(0);

  # Make the socket reusable, if requested.
  if (
    (defined $params{Reuse})
       and ( (lc($params{Reuse}) eq 'yes')
             or (lc($params{Reuse}) eq 'on')
             or ( ($params{Reuse} =~ /\d+/)
                  and $params{Reuse}
                )
           )
     )
  {
    setsockopt($socket_handle, SOL_SOCKET, SO_REUSEADDR, 1) or do {
      $poe_kernel->yield(
        $event_failure,
        'setsockopt', $!+0, $!, $self->[MY_UNIQUE_ID]
      );
      return $self;
    };
  }

  #-------------#
  # Bind Socket #
  #-------------#

  my $bind_address;

  # Check SocketFactory /Bind.*/ parameters in an Internet socket
  # context, and translate them into parameters that bind()
  # understands.
  if ($abstract_domain eq DOM_INET) {
    # Don't bind if the creator doesn't specify a related parameter.
    if ((defined $params{BindAddress}) or (defined $params{BindPort})) {

      # Set the bind address, or default to INADDR_ANY.
      $bind_address = (
        (defined $params{BindAddress})
        ? $params{BindAddress}
        : INADDR_ANY
      );

      # Need to check lengths in octets, not characters.
      BEGIN { eval { require bytes } and bytes->import; }

      # Resolve the bind address if it's not already packed.
      unless (length($bind_address) == 4) {
        $bind_address = inet_aton($bind_address);
      }

      unless (defined $bind_address) {
        $! = EADDRNOTAVAIL;
        $poe_kernel->yield(
          $event_failure,
          "inet_aton", $!+0, $!, $self->[MY_UNIQUE_ID]
        );
        return $self;
      }

      # Set the bind port, or default to 0 (any) if none specified.
      # Resolve it to a number, if at all possible.
      my $bind_port = (defined $params{BindPort}) ? $params{BindPort} : 0;
      if ($bind_port =~ /[^0-9]/) {
        $bind_port = getservbyname($bind_port, $protocol_name);
        unless (defined $bind_port) {
          $! = EADDRNOTAVAIL;
          $poe_kernel->yield(
            $event_failure,
            'getservbyname', $!+0, $!, $self->[MY_UNIQUE_ID]
          );
          return $self;
        }
      }

      $bind_address = pack_sockaddr_in($bind_port, $bind_address);
      unless (defined $bind_address) {
        $poe_kernel->yield(
          $event_failure,
          "pack_sockaddr_in", $!+0, $!, $self->[MY_UNIQUE_ID]
        );
        return $self;
      }
    }
  }

  # Check SocketFactory /Bind.*/ parameters in an Internet socket
  # context, and translate them into parameters that bind()
  # understands.
  elsif ($abstract_domain eq DOM_INET6) {

    # Don't bind if the creator doesn't specify a related parameter.
    if ((defined $params{BindAddress}) or (defined $params{BindPort})) {

      # Set the bind address, or default to INADDR_ANY.
      $bind_address = (
        (defined $params{BindAddress})
        ? $params{BindAddress}
        : "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"  # XXX - Only Socket6 has?
      );

      # Set the bind port, or default to 0 (any) if none specified.
      # Resolve it to a number, if at all possible.
      my $bind_port = (defined $params{BindPort}) ? $params{BindPort} : 0;
      if ($bind_port =~ /[^0-9]/) {
        $bind_port = getservbyname($bind_port, $protocol_name);
        unless (defined $bind_port) {
          $! = EADDRNOTAVAIL;
          $poe_kernel->yield(
            $event_failure,
            'getservbyname', $!+0, $!, $self->[MY_UNIQUE_ID]
          );
          return $self;
        }
      }

      # Need to check lengths in octets, not characters.
      BEGIN { eval { require bytes } and bytes->import; }

      # Resolve the bind address.
      my ($error, @addresses) = getaddrinfo(
        $bind_address, $bind_port, {
          family   => $self->[MY_SOCKET_DOMAIN],
          socktype => $self->[MY_SOCKET_TYPE],
        }
      );

      unless (@addresses) {
        warn $error if $error;

        $! = EADDRNOTAVAIL;
        $poe_kernel->yield(
          $event_failure,
          "getaddrinfo", $!+0, $!, $self->[MY_UNIQUE_ID]
        );
        return $self;
      }

      $bind_address = $addresses[0]->{addr};
    }
  }

  # Check SocketFactory /Bind.*/ parameters in a Unix context, and
  # translate them into parameters bind() understands.
  elsif ($abstract_domain eq DOM_UNIX) {
    carp 'BindPort ignored for Unix socket' if defined $params{BindPort};

    if (defined $params{BindAddress}) {
      # Is this necessary, or will bind() return EADDRINUSE?
      if (defined $params{RemotePort}) {
        $! = EADDRINUSE;
        $poe_kernel->yield(
          $event_failure,
          'bind', $!+0, $!, $self->[MY_UNIQUE_ID]
        );
        return $self;
      }

      $bind_address = &_condition_unix_address($params{BindAddress});
      $bind_address = pack_sockaddr_un($bind_address);
      unless ($bind_address) {
        $poe_kernel->yield(
          $event_failure,
          'pack_sockaddr_un', $!+0, $!, $self->[MY_UNIQUE_ID]
        );
        return $self;
      }
    }
  }

  # This is an internal consistency error, and it should be hard
  # trapped right away.
  else {
    die "Mail this error to the author of POE: Internal consistency error";
  }

  # Perform the actual bind, if there's a bind address to bind to.
  if (defined $bind_address) {
    unless (bind($socket_handle, $bind_address)) {
      $poe_kernel->yield(
        $event_failure,
        'bind', $!+0, $!, $self->[MY_UNIQUE_ID]
      );
      return $self;
    }

    DEBUG && warn "bind";
  }

  #---------#
  # Connect #
  #---------#

  my $connect_address;

  if (defined $params{RemoteAddress}) {

    # Check SocketFactory /Remote.*/ parameters in an Internet socket
    # context, and translate them into parameters that connect()
    # understands.
    if (
      $abstract_domain eq DOM_INET or
      $abstract_domain eq DOM_INET6
    ) {
      # connecting if RemoteAddress
      croak 'RemotePort required' unless (defined $params{RemotePort});
      carp 'ListenQueue ignored' if (defined $params{ListenQueue});

      my $remote_port = $params{RemotePort};
      if ($remote_port =~ /[^0-9]/) {
        unless ($remote_port = getservbyname($remote_port, $protocol_name)) {
          $! = EADDRNOTAVAIL;
          $poe_kernel->yield(
            $event_failure,
            'getservbyname', $!+0, $!, $self->[MY_UNIQUE_ID]
          );
          return $self;
        }
      }

      my $error_tag;
      if ($abstract_domain eq DOM_INET) {
        $connect_address = inet_aton($params{RemoteAddress});
        $error_tag = "inet_aton";
      }
      elsif ($abstract_domain eq DOM_INET6) {
        my ($error, @addresses) = getaddrinfo(
          $params{RemoteAddress}, $remote_port, {
            family   => $self->[MY_SOCKET_DOMAIN],
            socktype => $self->[MY_SOCKET_TYPE],
          },
        );

        unless (@addresses) {
          warn $error if $error;
          $connect_address = undef;
        }
        else {
          $connect_address = $addresses[0]->{addr};
        }

        $error_tag = "getaddrinfo";
      }
      else {
        die "unknown domain $abstract_domain";
      }

      # TODO - If the gethostbyname2() code is removed, then we can
      # combine the previous code with the following code, and perhaps
      # remove one of these redundant $connect_address checks.  The
      # 0.29 release should tell us pretty quickly whether it's
      # needed.  If we reach 0.30 without incident, it's probably safe
      # to remove the old gethostbyname2() code and clean this up.
      unless (defined $connect_address) {
        $! = EADDRNOTAVAIL;
        $poe_kernel->yield(
          $event_failure,
          $error_tag, $!+0, $!, $self->[MY_UNIQUE_ID]
        );
        return $self;
      }

      if ($abstract_domain eq DOM_INET) {
        $connect_address = pack_sockaddr_in($remote_port, $connect_address);
        $error_tag = "pack_sockaddr_in";
      }
      elsif ($abstract_domain eq DOM_INET6) {
        $error_tag = "pack_sockaddr_in6";
      }
      else {
        die "unknown domain $abstract_domain";
      }

      unless ($connect_address) {
        $! = EADDRNOTAVAIL;
        $poe_kernel->yield(
          $event_failure,
          $error_tag, $!+0, $!, $self->[MY_UNIQUE_ID]
        );
        return $self;
      }
    }

    # Check SocketFactory /Remote.*/ parameters in a Unix socket
    # context, and translate them into parameters connect()
    # understands.
    elsif ($abstract_domain eq DOM_UNIX) {

      $connect_address = _condition_unix_address($params{RemoteAddress});
      $connect_address = pack_sockaddr_un($connect_address);
      unless (defined $connect_address) {
        $poe_kernel->yield(
          $event_failure,
          'pack_sockaddr_un', $!+0, $!, $self->[MY_UNIQUE_ID]
        );
        return $self;
      }
    }

    # This is an internal consistency error, and it should be trapped
    # right away.
    else {
      die "Mail this error to the author of POE: Internal consistency error";
    }
  }

  else {
    carp "RemotePort ignored without RemoteAddress"
      if defined $params{RemotePort};
  }

  # Perform the actual connection, if a connection was requested.  If
  # the connection can be established, then return the SocketFactory
  # handle.
  if (defined $connect_address) {
    unless (connect($socket_handle, $connect_address)) {
      if ($! and ($! != EINPROGRESS) and ($! != EWOULDBLOCK)) {
        $poe_kernel->yield(
          $event_failure,
          'connect', $!+0, $!, $self->[MY_UNIQUE_ID]
        );
        return $self;
      }
    }

    DEBUG && warn "connect";

    $self->[MY_SOCKET_HANDLE] = $socket_handle;
    $self->_define_connect_state();
    $self->event(
      SuccessEvent => $params{SuccessEvent},
      FailureEvent => $params{FailureEvent},
    );
    return $self;
  }

  #---------------------#
  # Listen, or Whatever #
  #---------------------#

  # A connection wasn't requested, so this must be a server socket.
  # Do whatever it is that needs to be done for whatever type of
  # server socket this is.
  if (exists $supported_protocol{$abstract_domain}->{$protocol_name}) {
    my $protocol_op = $supported_protocol{$abstract_domain}->{$protocol_name};

    DEBUG && warn "$abstract_domain + $protocol_name = $protocol_op";

    if ($protocol_op eq SVROP_LISTENS) {
      my $listen_queue = $params{ListenQueue} || SOMAXCONN;
      #  In SocketFactory, you limit the ListenQueue parameter
      #        to SOMAXCON (or is it SOCONNMAX?)...why?
      #  ah, here's czth, he'll have more to say on this issue
      #  not really.  just that SOMAXCONN can lie, notably on
      #        Solaris and reportedly on BSDs too
      #
      # ($listen_queue > SOMAXCONN) && ($listen_queue = SOMAXCONN);
      unless (listen($socket_handle, $listen_queue)) {
        $poe_kernel->yield(
          $event_failure,
          'listen', $!+0, $!, $self->[MY_UNIQUE_ID]
        );
        return $self;
      }

      DEBUG && warn "listen";

      $self->[MY_SOCKET_HANDLE] = $socket_handle;
      $self->_define_accept_state();
      $self->event(
        SuccessEvent => $params{SuccessEvent},
        FailureEvent => $params{FailureEvent},
      );
      return $self;
    }
    else {
      carp "Ignoring ListenQueue parameter for non-listening socket"
        if defined $params{ListenQueue};
      if ($protocol_op eq SVROP_NOTHING) {
        # Do nothing.  Duh.  Fire off a success event immediately, and
        # return.
        $poe_kernel->yield(
          $event_success,
          $socket_handle, undef, undef, $self->[MY_UNIQUE_ID]
        );
        return $self;
      }
      else {
        die "Mail this error to the author of POE: Internal consistency error";
      }
    }
  }
  else {
    die "SocketFactory doesn't support $abstract_domain $protocol_name socket";
  }

  die "Mail this error to the author of POE: Internal consistency error";
}

# Pause and resume accept.
sub pause_accept {
  my $self = shift;
  if (
    defined $self->[MY_SOCKET_HANDLE] and
    defined $self->[MY_STATE_ACCEPT] and
    defined $self->[MY_SOCKET_SELECTED]
  ) {
    $poe_kernel->select_pause_read($self->[MY_SOCKET_HANDLE]);
  }
}

sub resume_accept {
  my $self = shift;
  if (
    defined $self->[MY_SOCKET_HANDLE] and
    defined $self->[MY_STATE_ACCEPT] and
    defined $self->[MY_SOCKET_SELECTED]
  ) {
    $poe_kernel->select_resume_read($self->[MY_SOCKET_HANDLE]);
  }
}

#------------------------------------------------------------------------------
# DESTROY and _shutdown pass things by reference because _shutdown is
# called from the state() closures above.  As a result, we can't
# mention $self explicitly, or the wheel won't shut itself down
# properly.  Rather, it will form a circular reference on $self.

sub DESTROY {
  my $self = shift;
  _shutdown(
    \$self->[MY_SOCKET_SELECTED],
    \$self->[MY_SOCKET_HANDLE],
    \$self->[MY_STATE_ACCEPT],
    \$self->[MY_STATE_CONNECT],
    \$self->[MY_MINE_SUCCESS],
    \$self->[MY_EVENT_SUCCESS],
    \$self->[MY_MINE_FAILURE],
    \$self->[MY_EVENT_FAILURE],
  );
  &POE::Wheel::free_wheel_id($self->[MY_UNIQUE_ID]);
}

sub _shutdown {
  my (
    $socket_selected, $socket_handle,
    $state_accept, $state_connect,
    $mine_success, $event_success,
    $mine_failure, $event_failure,
  ) = @_;

  if (defined $$socket_selected) {
    $poe_kernel->select($$socket_handle);
    $$socket_selected = undef;
  }

  if (defined $$state_accept) {
    $poe_kernel->state($$state_accept);
    $$state_accept = undef;
  }

  if (defined $$state_connect) {
    $poe_kernel->state($$state_connect);
    $$state_connect = undef;
  }

  if (defined $$mine_success) {
    $poe_kernel->state($$event_success);
    $$mine_success = $$event_success = undef;
  }

  if (defined $$mine_failure) {
    $poe_kernel->state($$event_failure);
    $$mine_failure = $$event_failure = undef;
  }
}

1;

__END__