view release on metacpan or  search on metacpan

lib/AnyEvent/Socket.pm  view on Meta::CPAN

   } else {
      require AnyEvent::DNS unless $AnyEvent::DNS::VERSION;

      my $ipv4 = $AnyEvent::PROTOCOL{ipv4};
      my $ipv6 = $AnyEvent::PROTOCOL{ipv6};

      my @res;

      my $cv = AE::cv {
         $cb->(map @$_, reverse @res);
      };

      $cv->begin;

      if ($ipv4) {
         $cv->begin;
         AnyEvent::DNS::a ($name, sub {
            $res[$ipv4] = [map { parse_ipv4 $_ } @_];
            $cv->end;
         });
      };

      if ($ipv6) {
         $cv->begin;
         AnyEvent::DNS::aaaa ($name, sub {
            $res[$ipv6] = [map { parse_ipv6 $_ } @_];
            $cv->end;
         });
      };

      $cv->end;
   }
}

BEGIN {
   *sockaddr_family = $Socket::VERSION >= 1.75
      ? \&Socket::sockaddr_family
      : # for 5.6.x, we need to do something much more horrible
        (Socket::pack_sockaddr_in 0x5555, "\x55\x55\x55\x55"
           | eval { Socket::pack_sockaddr_un "U" }) =~ /^\x00/
           ? sub { unpack "xC", $_[0] }
           : sub { unpack "S" , $_[0] };
}

# check for broken platforms with an extra field in sockaddr structure
# kind of a rfc vs. bsd issue, as usual (ok, normally it's a
# unix vs. bsd issue, a iso C vs. bsd issue or simply a
# correctness vs. bsd issue.)
my $pack_family = 0x55 == sockaddr_family ("\x55\x55")
                  ? "xC" : "S";

=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host

Pack the given port/host combination into a binary sockaddr
structure. Handles both IPv4 and IPv6 host addresses, as well as UNIX
domain sockets (C<$host> == C<unix/> and C<$service> == absolute
pathname).

Example:

   my $bind = AnyEvent::Socket::pack_sockaddr 43, v195.234.53.120;
   bind $socket, $bind
      or die "bind: $!";

=cut

sub pack_sockaddr($$) {
   my $af = address_family $_[1];

   if ($af == AF_INET) {
      Socket::pack_sockaddr_in $_[0], $_[1]
   } elsif ($af == AF_INET6) {
      pack "$pack_family nL a16 L",
         AF_INET6,
         $_[0], # port
         0,     # flowinfo
         $_[1], # addr
         0      # scope id
   } elsif ($af == AF_UNIX) {
      Socket::pack_sockaddr_un $_[0]
   } else {
      Carp::croak "pack_sockaddr: invalid host";
   }
}

=item ($service, $host) = AnyEvent::Socket::unpack_sockaddr $sa

Unpack the given binary sockaddr structure (as used by bind, getpeername
etc.) into a C<$service, $host> combination.

For IPv4 and IPv6, C<$service> is the port number and C<$host> the host
address in network format (binary).

For UNIX domain sockets, C<$service> is the absolute pathname and C<$host>
is a special token that is understood by the other functions in this
module (C<format_address> converts it to C<unix/>).

=cut

# perl contains a bug (imho) where it requires that the kernel always returns
# sockaddr_un structures of maximum length (which is not, AFAICS, required
# by any standard). try to 0-pad structures for the benefit of those platforms.
# unfortunately, the IO::Async author chose to break Socket again in version
# 2.011 - it now contains a bogus length check, so we disable the workaround.

my $sa_un_zero = $Socket::VERSION >= 2.011
   ? ""
   : eval { Socket::pack_sockaddr_un "" };

$sa_un_zero ^= $sa_un_zero;

sub unpack_sockaddr($) {
   my $af = sockaddr_family $_[0];

   if ($af == AF_INET) {
      Socket::unpack_sockaddr_in $_[0]
   } elsif ($af == AF_INET6) {
      unpack "x2 n x4 a16", $_[0]
   } elsif ($af == AF_UNIX) {
      ((Socket::unpack_sockaddr_un $_[0] ^ $sa_un_zero), pack "S", AF_UNIX)
   } else {
      Carp::croak "unpack_sockaddr: unsupported protocol family $af";
   }
}

=item AnyEvent::Socket::resolve_sockaddr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...)

Tries to resolve the given nodename and service name into protocol families
and sockaddr structures usable to connect to this node and service in a
protocol-independent way. It works remotely similar to the getaddrinfo
posix function.

For internet addresses, C<$node> is either an IPv4 or IPv6 address, an
internet hostname (DNS domain name or IDN), and C<$service> is either
a service name (port name from F</etc/services>) or a numerical port
number. If both C<$node> and C<$service> are names, then SRV records
will be consulted to find the real service, otherwise they will be
used as-is. If you know that the service name is not in your services
database, then you can specify the service in the format C<name=port>
(e.g. C<http=80>).

If a host cannot be found via DNS, then it will be looked up in
F</etc/hosts> (or the file specified via C<< $ENV{PERL_ANYEVENT_HOSTS}
>>). If they are found, the addresses there will be used. The effect is as
if entries from F</etc/hosts> would yield C<A> and C<AAAA> records for the
host name unless DNS already had records for them.

For UNIX domain sockets, C<$node> must be the string C<unix/> and
C<$service> must be the absolute pathname of the socket. In this case,
C<$proto> will be ignored.

C<$proto> must be a protocol name, currently C<tcp>, C<udp> or
C<sctp>. The default is currently C<tcp>, but in the future, this function
might try to use other protocols such as C<sctp>, depending on the socket
type and any SRV records it might find.

C<$family> must be either C<0> (meaning any protocol is OK), C<4> (use
only IPv4) or C<6> (use only IPv6). The default is influenced by
C<$ENV{PERL_ANYEVENT_PROTOCOLS}>.

C<$type> must be C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_SEQPACKET> (or
C<undef> in which case it gets automatically chosen to be C<SOCK_STREAM>
unless C<$proto> is C<udp>).

The callback will receive zero or more array references that contain
C<$family, $type, $proto> for use in C<socket> and a binary
C<$sockaddr> for use in C<connect> (or C<bind>).

The application should try these in the order given.

Example:

   resolve_sockaddr "google.com", "http", 0, undef, undef, sub { ... };

=cut

our %HOSTS;          # $HOSTS{$nodename}[$ipv6] = [@aliases...]
our @HOSTS_CHECKING; # callbacks to call when hosts have been loaded
our $HOSTS_MTIME;

sub _parse_hosts($) {
   %HOSTS = ();

   for (split /\n/, $_[0]) {
      s/#.*$//;
      s/^[ \t]+//;
      y/A-Z/a-z/;

      my ($addr, @aliases) = split /[ \t]+/;
      next unless @aliases;

      if (my $ip = parse_ipv4 $addr) {
         ($ip) = $ip =~ /^(.*)$/s if AnyEvent::TAINT;
         push @{ $HOSTS{$_}[0] }, $ip
            for @aliases;
      } elsif (my $ip = parse_ipv6 $addr) {
         ($ip) = $ip =~ /^(.*)$/s if AnyEvent::TAINT;
         push @{ $HOSTS{$_}[1] }, $ip
            for @aliases;
      }
   }
}

# helper function - unless dns delivered results, check and parse hosts, then call continuation code
sub _load_hosts_unless(&$@) {
   my ($cont, $cv, @dns) = @_;

   if (@dns) {
      $cv->end;
   } else {
      my $etc_hosts = length $ENV{PERL_ANYEVENT_HOSTS} ? $ENV{PERL_ANYEVENT_HOSTS}
                      : AnyEvent::WIN32                ? "$ENV{SystemRoot}/system32/drivers/etc/hosts"
                      :                                  "/etc/hosts";

      push @HOSTS_CHECKING, sub {
         $cont->();
         $cv->end;
      };

      unless ($#HOSTS_CHECKING) {
         # we are not the first, so we actually have to do the work
         require AnyEvent::IO;

         AnyEvent::IO::aio_stat ($etc_hosts, sub {
            if ((stat _)[9] ne $HOSTS_MTIME) {
               AE::log 8 => "(re)loading $etc_hosts.";
               $HOSTS_MTIME = (stat _)[9];

lib/AnyEvent/Socket.pm  view on Meta::CPAN

               map ["$_->[3].", $_->[2]],
                  grep $_->[3] ne ".",
                     @srv
            );
         } else {
            # no srv records, continue traditionally
            $resolve->([$node, $port]);
         }
      };
   } else {
      # most common case
      $resolve->([$node, $port]);
   }
}

=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]

This is a convenience function that creates a TCP socket and makes a
100% non-blocking connect to the given C<$host> (which can be a DNS/IDN
hostname or a textual IP address, or the string C<unix/> for UNIX domain
sockets) and C<$service> (which can be a numeric port number or a service
name, or a C<servicename=portnumber> string, or the pathname to a UNIX
domain socket).

If both C<$host> and C<$port> are names, then this function will use SRV
records to locate the real target(s).

In either case, it will create a list of target hosts (e.g. for multihomed
hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to
each in turn.

After the connection is established, then the C<$connect_cb> will be
invoked with the socket file handle (in non-blocking mode) as first, and
the peer host (as a textual IP address) and peer port as second and third
arguments, respectively. The fourth argument is a code reference that you
can call if, for some reason, you don't like this connection, which will
cause C<tcp_connect> to try the next one (or call your callback without
any arguments if there are no more connections). In most cases, you can
simply ignore this argument.

   $cb->($filehandle, $host, $port, $retry)

If the connect is unsuccessful, then the C<$connect_cb> will be invoked
without any arguments and C<$!> will be set appropriately (with C<ENXIO>
indicating a DNS resolution failure).

The callback will I<never> be invoked before C<tcp_connect> returns, even
if C<tcp_connect> was able to connect immediately (e.g. on unix domain
sockets).

The file handle is perfect for being plugged into L<AnyEvent::Handle>, but
can be used as a normal perl file handle as well.

Unless called in void context, C<tcp_connect> returns a guard object that
will automatically cancel the connection attempt when it gets destroyed
- in which case the callback will not be invoked. Destroying it does not
do anything to the socket after the connect was successful - you cannot
"uncall" a callback that has been invoked already.

Sometimes you need to "prepare" the socket before connecting, for example,
to C<bind> it to some port, or you want a specific connect timeout that
is lower than your kernel's default timeout. In this case you can specify
a second callback, C<$prepare_cb>. It will be called with the file handle
in not-yet-connected state as only argument and must return the connection
timeout value (or C<0>, C<undef> or the empty list to indicate the default
timeout is to be used).

Note to the poor Microsoft Windows users: Windows (of course) doesn't
correctly signal connection errors, so unless your event library works
around this, failed connections will simply hang. The only event libraries
that handle this condition correctly are L<EV> and L<Glib>. Additionally,
AnyEvent works around this bug with L<Event> and in its pure-perl
backend. All other libraries cannot correctly handle this condition. To
lessen the impact of this windows bug, a default timeout of 30 seconds
will be imposed on windows. Cygwin is not affected.

Simple Example: connect to localhost on port 22.

   tcp_connect localhost => 22, sub {
      my $fh = shift
         or die "unable to connect: $!";
      # do something
   };

Complex Example: connect to www.google.com on port 80 and make a simple
GET request without much error handling. Also limit the connection timeout
to 15 seconds.

   tcp_connect "www.google.com", "http",
      sub {
         my ($fh) = @_
            or die "unable to connect: $!";

         my $handle; # avoid direct assignment so on_eof has it in scope.
         $handle = new AnyEvent::Handle
            fh     => $fh,
            on_error => sub {
               AE::log error => $_[2];
               $_[0]->destroy;
            },
            on_eof => sub {
               $handle->destroy; # destroy handle
               AE::log info => "Done.";
            };

         $handle->push_write ("GET / HTTP/1.0\015\012\015\012");

         $handle->push_read (line => "\015\012\015\012", sub {
            my ($handle, $line) = @_;

            # print response header
            print "HEADER\n$line\n\nBODY\n";

            $handle->on_read (sub {
               # print response body
               print $_[0]->rbuf;
               $_[0]->rbuf = "";
            });
         });
      }, sub {
         my ($fh) = @_;
         # could call $fh->bind etc. here

         15
      };

Example: connect to a UNIX domain socket.

   tcp_connect "unix/", "/tmp/.X11-unix/X0", sub {
      ...
   }

=cut

sub tcp_connect($$$;$) {
   my ($host, $port, $connect, $prepare) = @_;

   # see http://cr.yp.to/docs/connect.html for some tricky aspects
   # also http://advogato.org/article/672.html

   my %state = ( fh => undef );

   # name/service to type/sockaddr resolution
   resolve_sockaddr $host, $port, 0, 0, undef, sub {
      my @target = @_;

      $state{next} = sub {
         return unless exists $state{fh};

         my $errno = $!;
         my $target = shift @target
            or return AE::postpone {
               return unless exists $state{fh};
               %state = ();
               $! = $errno;
               $connect->();
            };

         my ($domain, $type, $proto, $sockaddr) = @$target;

         # socket creation
         socket $state{fh}, $domain, $type, $proto
            or return $state{next}();

         AnyEvent::fh_unblock $state{fh};
         
         my $timeout = $prepare && $prepare->($state{fh});

         $timeout ||= 30 if AnyEvent::WIN32;

         $state{to} = AE::timer $timeout, 0, sub {
            $! = Errno::ETIMEDOUT;
            $state{next}();
         } if $timeout;

         # now connect
         if (
            (connect $state{fh}, $sockaddr)
            || ($! == Errno::EINPROGRESS # POSIX
                || $! == Errno::EWOULDBLOCK
                # WSAEINPROGRESS intentionally not checked - it means something else entirely
                || $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt
                || $! == AnyEvent::Util::WSAEWOULDBLOCK)
         ) {
            $state{ww} = AE::io $state{fh}, 1, sub {
               # we are connected, or maybe there was an error
               if (my $sin = getpeername $state{fh}) {
                  my ($port, $host) = unpack_sockaddr $sin;

                  delete $state{ww}; delete $state{to};

                  my $guard = guard { %state = () };

                  $connect->(delete $state{fh}, format_address $host, $port, sub {
                     $guard->cancel;
                     $state{next}();
                  });
               } else {
                  if ($! == Errno::ENOTCONN) {
                     # dummy read to fetch real error code if !cygwin
                     sysread $state{fh}, my $buf, 1;

                     # cygwin 1.5 continously reports "ready' but never delivers
                     # an error with getpeername or sysread.
                     # cygwin 1.7 only reports readyness *once*, but is otherwise
                     # the same, which is actually more broken.
                     # Work around both by using unportable SO_ERROR for cygwin.
                     $! = (unpack "l", getsockopt $state{fh}, Socket::SOL_SOCKET(), Socket::SO_ERROR()) || Errno::EAGAIN
                        if AnyEvent::CYGWIN && $! == Errno::EAGAIN;
                  }

                  return if $! == Errno::EAGAIN; # skip spurious wake-ups

                  delete $state{ww}; delete $state{to};

                  $state{next}();
               }
            };
         } else {
            $state{next}();
         }
      };

      $! = Errno::ENXIO;
      $state{next}();
   };

   defined wantarray && guard { %state = () }
}

=item $guard = tcp_server $host, $service, $accept_cb[, $prepare_cb]

Create and bind a stream socket to the given host address and port, set
the SO_REUSEADDR flag (if applicable) and call C<listen>. Unlike the name
implies, this function can also bind on UNIX domain sockets.

For internet sockets, C<$host> must be an IPv4 or IPv6 address (or
C<undef>, in which case it binds either to C<0> or to C<::>, depending
on whether IPv4 or IPv6 is the preferred protocol, and maybe to both in
future versions, as applicable).

To bind to the IPv4 wildcard address, use C<0>, to bind to the IPv6
wildcard address, use C<::>.

The port is specified by C<$service>, which must be either a service name
or a numeric port number (or C<0> or C<undef>, in which case an ephemeral
port will be used).

For UNIX domain sockets, C<$host> must be C<unix/> and C<$service> must be
the absolute pathname of the socket. This function will try to C<unlink>
the socket before it tries to bind to it, and will try to unlink it after
it stops using it. See SECURITY CONSIDERATIONS, below.

For each new connection that could be C<accept>ed, call the C<<
$accept_cb->($fh, $host, $port) >> with the file handle (in non-blocking
mode) as first, and the peer host and port as second and third arguments
(see C<tcp_connect> for details).

Croaks on any errors it can detect before the listen.

In non-void context, this function returns a guard object whose lifetime
it tied to the TCP server: If the object gets destroyed, the server will
be stopped and the listening socket will be cleaned up/unlinked (already
accepted connections will not be affected).

When called in void-context, AnyEvent will keep the listening socket alive
internally. In this case, there is no guarantee that the listening socket
will be cleaned up or unlinked.

In all cases, when the function returns to the caller, the socket is bound
and in listening state.

If you need more control over the listening socket, you can provide a
C<< $prepare_cb->($fh, $host, $port) >>, which is called just before the
C<listen ()> call, with the listen file handle as first argument, and IP
address and port number of the local socket endpoint as second and third
arguments.

It should return the length of the listen queue (or C<0> for the default).

Note to IPv6 users: RFC-compliant behaviour for IPv6 sockets listening on
C<::> is to bind to both IPv6 and IPv4 addresses by default on dual-stack
hosts. Unfortunately, only GNU/Linux seems to implement this properly, so
if you want both IPv4 and IPv6 listening sockets you should create the
IPv6 socket first and then attempt to bind on the IPv4 socket, but ignore
any C<EADDRINUSE> errors.

Example: bind on some TCP port on the local machine and tell each client
to go away.

   tcp_server undef, undef, sub {
      my ($fh, $host, $port) = @_;

      syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";
   }, sub {
      my ($fh, $thishost, $thisport) = @_;
      AE::log info => "Bound to $thishost, port $thisport.";
   };

Example: bind a server on a unix domain socket.

   tcp_server "unix/", "/tmp/mydir/mysocket", sub {
      my ($fh) = @_;
   };

=item $guard = AnyEvent::Socket::tcp_bind $host, $service, $done_cb[, $prepare_cb]

Same as C<tcp_server>, except it doesn't call C<accept> in a loop for you
but simply passes the listen socket to the C<$done_cb>. This is useful
when you want to have a convenient set up for your listen socket, but want
to do the C<accept>'ing yourself, for example, in another process.

In case of an error, C<tcp_bind> either croaks, or passes C<undef> to the
C<$done_cb>.

In non-void context, a guard will be returned. It will clean up/unlink the
listening socket when destroyed. In void context, no automatic clean up
might be performed.

=cut

sub _tcp_bind($$$;$) {
   my ($host, $service, $done, $prepare) = @_;

   $host = $AnyEvent::PROTOCOL{ipv4} < $AnyEvent::PROTOCOL{ipv6} && AF_INET6
           ? "::" : "0"
      unless defined $host;

   my $ipn = parse_address $host
      or Carp::croak "tcp_bind: cannot parse '$host' as host address";

   my $af = address_family $ipn;

   my %state;

   # win32 perl is too stupid to get this right :/
   Carp::croak "tcp_bind: AF_UNIX address family not supported on win32"
      if AnyEvent::WIN32 && $af == AF_UNIX;

   socket my $fh, $af, SOCK_STREAM, 0
      or Carp::croak "tcp_bind: $!";

   $state{fh} = $fh;

   if ($af == AF_INET || $af == AF_INET6) {
      setsockopt $fh, SOL_SOCKET, SO_REUSEADDR, 1
         or Carp::croak "tcp_bind: so_reuseaddr: $!"
            unless AnyEvent::WIN32; # work around windows bug

      unless ($service =~ /^\d*$/) {
         $service = (getservbyname $service, "tcp")[2]
                    or Carp::croak "tcp_bind: unknown service '$service'"
      }
   } elsif ($af == AF_UNIX) {
      unlink $service;
   }

   bind $fh, pack_sockaddr $service, $ipn
      or Carp::croak "tcp_bind: $!";

   if ($af == AF_UNIX and defined wantarray) {
      # this is racy, but is not designed to be foolproof, just best-effort
      my $ino = (lstat $service)[1];
      $state{unlink} = guard {
         unlink $service
            if (lstat $service)[1] == $ino;
      };
   }

   AnyEvent::fh_unblock $fh;

   my $len;

   if ($prepare) {
      my ($service, $host) = unpack_sockaddr getsockname $fh;
      $len = $prepare && $prepare->($fh, format_address $host, $service);
   }
   
   $len ||= 128;

   listen $fh, $len
      or Carp::croak "tcp_bind: $!";

   $done->(\%state);

   defined wantarray
      ? guard { %state = () } # clear fh, unlink
      : ()
}

sub tcp_bind($$$;$) {
   my ($host, $service, $done, $prepare) = @_;

   _tcp_bind $host, $service, sub {
      $done->(delete shift->{fh});
   }, $prepare
}

sub tcp_server($$$;$) {
   my ($host, $service, $accept, $prepare) = @_;

   _tcp_bind $host, $service, sub {
      my $rstate = shift;

      $rstate->{aw} = AE::io $rstate->{fh}, 0, sub {
         # this closure keeps $state alive
         while ($rstate->{fh} && (my $peer = accept my $fh, $rstate->{fh})) {
            AnyEvent::fh_unblock $fh; # POSIX requires inheritance, the outside world does not

            my ($service, $host) = unpack_sockaddr $peer;
            $accept->($fh, format_address $host, $service);
         }
      };
   }, $prepare
}

=item tcp_nodelay $fh, $enable

Enables (or disables) the C<TCP_NODELAY> socket option (also known as
Nagle's algorithm). Returns false on error, true otherwise.

=cut

sub tcp_nodelay($$) {
   my $onoff = int ! ! $_[1];

   setsockopt $_[0], Socket::IPPROTO_TCP (), Socket::TCP_NODELAY (), $onoff
}

=item tcp_congestion $fh, $algorithm

Sets the tcp congestion avoidance algorithm (via the C<TCP_CONGESTION>
socket option). The default is OS-specific, but is usually
C<reno>. Typical other available choices include C<cubic>, C<lp>, C<bic>,
C<highspeed>, C<htcp>, C<hybla>, C<illinois>, C<scalable>, C<vegas>,
C<veno>, C<westwood> and C<yeah>.

=cut

sub tcp_congestion($$) {
   defined TCP_CONGESTION
      ? setsockopt $_[0], Socket::IPPROTO_TCP (), TCP_CONGESTION, "$_[1]"
      : undef
}

=back

=head1 SECURITY CONSIDERATIONS

This module is quite powerful, with with power comes the ability to abuse
as well: If you accept "hostnames" and ports from untrusted sources,
then note that this can be abused to delete files (host=C<unix/>). This
is not really a problem with this module, however, as blindly accepting
any address and protocol and trying to bind a server or connect to it is
harmful in general.

=head1 AUTHOR

 Marc Lehmann <schmorp@schmorp.de>
 http://anyevent.schmorp.de

=cut

1