--- AnyEvent/lib/AnyEvent/Socket.pm 2008/05/28 21:52:20 1.37 +++ AnyEvent/lib/AnyEvent/Socket.pm 2011/01/14 17:43:11 1.130 @@ -4,21 +4,21 @@ =head1 SYNOPSIS - use AnyEvent::Socket; - - tcp_connect "gameserver.deliantra.net", 13327, sub { - my ($fh) = @_ - or die "gameserver.deliantra.net connect failed: $!"; - - # enjoy your filehandle - }; - - # a simple tcp server - tcp_server undef, 8888, sub { - my ($fh, $host, $port) = @_; - - syswrite $fh, "The internet is full, $host:$port. Go away!\015\012"; - }; + use AnyEvent::Socket; + + tcp_connect "gameserver.deliantra.net", 13327, sub { + my ($fh) = @_ + or die "gameserver.deliantra.net connect failed: $!"; + + # enjoy your filehandle + }; + + # a simple tcp server + tcp_server undef, 8888, sub { + my ($fh, $host, $port) = @_; + + syswrite $fh, "The internet is full, $host:$port. Go away!\015\012"; + }; =head1 DESCRIPTION @@ -35,22 +35,22 @@ package AnyEvent::Socket; -no warnings; -use strict; - use Carp (); use Errno (); use Socket qw(AF_INET AF_UNIX SOCK_STREAM SOCK_DGRAM SOL_SOCKET SO_REUSEADDR); -use AnyEvent (); +use AnyEvent (); BEGIN { AnyEvent::common_sense } use AnyEvent::Util qw(guard fh_nonblocking AF_INET6); use AnyEvent::DNS (); use base 'Exporter'; our @EXPORT = qw( + getprotobyname + parse_hostport format_hostport parse_ipv4 parse_ipv6 parse_ip parse_address + format_ipv4 format_ipv6 format_ip format_address address_family inet_aton @@ -58,7 +58,19 @@ tcp_connect ); -our $VERSION = '1.0'; +our $VERSION = $AnyEvent::VERSION; + +# used in cases where we may return immediately but want the +# caller to do stuff first +sub _postpone { + my ($cb, @args) = (@_, $!); + + my $w; $w = AE::timer 0, 0, sub { + undef $w; + $! = pop @args; + $cb->(@args); + }; +} =item $ipn = parse_ipv4 $dotted_quad @@ -80,7 +92,7 @@ return undef if grep $_ >= 256, @_[0 .. @_ - 2]; # check trailing part against range - return undef if $_[-1] >= 1 << (8 * (4 - $#_)); + return undef if $_[-1] >= 2 ** (8 * (4 - $#_)); pack "N", (pop) + ($_[0] << 24) @@ -99,6 +111,11 @@ This function works similarly to C. +Example: + + print unpack "H*", parse_ipv6 "2002:5345::10.0.0.1"; + # => 2002534500000000000000000a000001 + =cut sub parse_ipv6($) { @@ -145,7 +162,7 @@ } -=item $ipn = parse_address $text +=item $ipn = parse_address $ip Combines C and C in one function. The address here refers to the host address (not socket address) in network form @@ -155,13 +172,157 @@ recognised by the other functions in this module to mean "UNIX domain socket". +If the C<$text> to parse is a mapped IPv4 in IPv6 address (:ffff::), +then it will be treated as an IPv4 address. If you don't want that, you +have to call C and/or C manually. + +Example: + + print unpack "H*", parse_address "10.1.2.3"; + # => 0a010203 + +=item $ipn = AnyEvent::Socket::aton $ip + +Same as C, but not exported (think C but +I name resolution). + =cut sub parse_address($) { - &parse_ipv4 || &parse_ipv6 || &parse_unix + for (&parse_ipv6) { + if ($_) { + s/^\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff//; + return $_; + } else { + return &parse_ipv4 || &parse_unix + } + } +} + +*aton = \&parse_address; + +=item ($name, $aliases, $proto) = getprotobyname $name + +Works like the builtin function of the same name, except it tries hard to +work even on broken platforms (well, that's windows), where getprotobyname +is traditionally very unreliable. + +Example: get the protocol number for TCP (usually 6) + + my $proto = getprotobyname "tcp"; + +=cut + +# microsoft can't even get getprotobyname working (the etc/protocols file +# gets lost fairly often on windows), so we have to hardcode some common +# protocol numbers ourselves. +our %PROTO_BYNAME; + +$PROTO_BYNAME{tcp} = Socket::IPPROTO_TCP () if defined &Socket::IPPROTO_TCP; +$PROTO_BYNAME{udp} = Socket::IPPROTO_UDP () if defined &Socket::IPPROTO_UDP; +$PROTO_BYNAME{icmp} = Socket::IPPROTO_ICMP() if defined &Socket::IPPROTO_ICMP; + +sub getprotobyname($) { + my $name = lc shift; + + defined (my $proton = $PROTO_BYNAME{$name} || (getprotobyname $name)[2]) + or return; + + ($name, uc $name, $proton) } -*parse_ip =\&parse_address; #d# +=item ($host, $service) = parse_hostport $string[, $default_service] + +Splitting a string of the form C is a common +problem. Unfortunately, just splitting on the colon makes it hard to +specify IPv6 addresses and doesn't support the less common but well +standardised C<[ip literal]> syntax. + +This function tries to do this job in a better way, it supports the +following formats, where C can be a numerical port number of a +service name, or a C string, and the C< port> and C<:port> +parts are optional. Also, everywhere where an IP address is supported +a hostname or unix domain socket address is also supported (see +C). + + hostname:port e.g. "www.linux.org", "www.x.de:443", "www.x.de:https=443" + ipv4:port e.g. "198.182.196.56", "127.1:22" + ipv6 e.g. "::1", "affe::1" + [ipv4or6]:port e.g. "[::1]", "[10.0.1]:80" + [ipv4or6] port e.g. "[127.0.0.1]", "[www.x.org] 17" + ipv4or6 port e.g. "::1 443", "10.0.0.1 smtp" + +It also supports defaulting the service name in a simple way by using +C<$default_service> if no service was detected. If neither a service was +detected nor a default was specified, then this function returns the +empty list. The same happens when a parse error was detected, such as a +hostname with a colon in it (the function is rather conservative, though). + +Example: + + print join ",", parse_hostport "localhost:443"; + # => "localhost,443" + + print join ",", parse_hostport "localhost", "https"; + # => "localhost,https" + + print join ",", parse_hostport "[::1]"; + # => "," (empty list) + +=cut + +sub parse_hostport($;$) { + my ($host, $port); + + for ("$_[0]") { # work on a copy, just in case, and also reset pos + + # parse host, special cases: "ipv6" or "ipv6 port" + unless ( + ($host) = /^\s* ([0-9a-fA-F:]*:[0-9a-fA-F:]*:[0-9a-fA-F\.:]*)/xgc + and parse_ipv6 $host + ) { + /^\s*/xgc; + + if (/^ \[ ([^\[\]]+) \]/xgc) { + $host = $1; + } elsif (/^ ([^\[\]:\ ]+) /xgc) { + $host = $1; + } else { + return; + } + } + + # parse port + if (/\G (?:\s+|:) ([^:[:space:]]+) \s*$/xgc) { + $port = $1; + } elsif (/\G\s*$/gc && length $_[1]) { + $port = $_[1]; + } else { + return; + } + } + + # hostnames must not contain :'s + return if $host =~ /:/ && !parse_ipv6 $host; + + ($host, $port) +} + +=item $string = format_hostport $host, $port + +Takes a host (in textual form) and a port and formats in unambigiously in +a way that C can parse it again. C<$port> can be C. + +=cut + +sub format_hostport($;$) { + my ($host, $port) = @_; + + $port = ":$port" if length $port; + $host = "[$host]" if $host =~ /:/; + + "$host$port" +} =item $sa_family = address_family $ipn @@ -178,6 +339,18 @@ : unpack "S", $_[0] } +=item $text = format_ipv4 $ipn + +Expects a four octet string representing a binary IPv4 address and returns +its textual format. Rarely used, see C for a nicer +interface. + +=item $text = format_ipv6 $ipn + +Expects a sixteen octet string representing a binary IPv6 address and +returns its textual format. Rarely used, see C for a +nicer interface. + =item $text = format_address $ipn Covnvert a host address in network format (e.g. 4 octets for IPv4 or 16 @@ -190,49 +363,97 @@ Returns C if it cannot detect the type. +If the C<$ipn> is a mapped IPv4 in IPv6 address (:ffff::), then just +the contained IPv4 address will be returned. If you do not want that, you +have to call C manually. + +Example: + + print format_address "\x01\x02\x03\x05"; + => 1.2.3.5 + +=item $text = AnyEvent::Socket::ntoa $ipn + +Same as format_address, but not exported (think C). + =cut -sub format_address; -sub format_address($) { - my $af = address_family $_[0]; - if ($af == AF_INET) { - return join ".", unpack "C4", $_[0] - } elsif ($af == AF_INET6) { - if (v0.0.0.0.0.0.0.0.0.0.0.0 eq substr $_[0], 0, 12) { +sub format_ipv4($) { + join ".", unpack "C4", $_[0] +} + +sub format_ipv6($) { + if ($_[0] =~ /^\x00\x00\x00\x00\x00\x00\x00\x00/) { + if (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0 eq $_[0]) { + return "::"; + } elsif (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1 eq $_[0]) { + return "::1"; + } elsif (v0.0.0.0.0.0.0.0.0.0.0.0 eq substr $_[0], 0, 12) { # v4compatible - return "::" . format_address substr $_[0], 12; + return "::" . format_ipv4 substr $_[0], 12; } elsif (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) { # v4mapped - return "::ffff:" . format_address substr $_[0], 12; + return "::ffff:" . format_ipv4 substr $_[0], 12; } elsif (v0.0.0.0.0.0.0.0.255.255.0.0 eq substr $_[0], 0, 12) { # v4translated - return "::ffff:0:" . format_address substr $_[0], 12; - } else { - my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0]; - - $ip =~ s/^0:(?:0:)*(0$)?/::/ - or $ip =~ s/(:0)+$/::/ - or $ip =~ s/(:0)+/:/; - return $ip + return "::ffff:0:" . format_ipv4 substr $_[0], 12; } - } elsif ($af == AF_UNIX) { + } + + my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0]; + + # this is admittedly rather sucky + $ip =~ s/(?:^|:) 0:0:0:0:0:0:0 (?:$|:)/::/x + or $ip =~ s/(?:^|:) 0:0:0:0:0:0 (?:$|:)/::/x + or $ip =~ s/(?:^|:) 0:0:0:0:0 (?:$|:)/::/x + or $ip =~ s/(?:^|:) 0:0:0:0 (?:$|:)/::/x + or $ip =~ s/(?:^|:) 0:0:0 (?:$|:)/::/x + or $ip =~ s/(?:^|:) 0:0 (?:$|:)/::/x + or $ip =~ s/(?:^|:) 0 (?:$|:)/::/x; + + $ip +} + +sub format_address($) { + if (4 == length $_[0]) { + return &format_ipv4; + } elsif (16 == length $_[0]) { + return $_[0] =~ /^\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff(....)$/s + ? format_ipv4 $1 + : &format_ipv6; + } elsif (AF_UNIX == address_family $_[0]) { return "unix/" } else { return undef } } -*format_ip = \&format_address; +*ntoa = \&format_address; =item inet_aton $name_or_address, $cb->(@addresses) Works similarly to its Socket counterpart, except that it uses a -callback. Also, if a host has only an IPv6 address, this might be passed -to the callback instead (use the length to detect this - 4 for IPv4, 16 -for IPv6). - -Unlike the L function of the same name, you can get multiple IPv4 -and IPv6 addresses as result (and maybe even other adrdess types). +callback. Use the length to distinguish between ipv4 and ipv6 (4 octets +for IPv4, 16 for IPv6), or use C to convert it to a more +readable format. + +Note that C, while initially a more complex interface, +resolves host addresses, IDNs, service names and SRV records and gives you +an ordered list of socket addresses to try and should be preferred over +C. + +Example. + + inet_aton "www.google.com", my $cv = AE::cv; + say unpack "H*", $_ + for $cv->recv; + # => d155e363 + # => d155e367 etc. + + inet_aton "ipv6.google.com", my $cv = AE::cv; + say unpack "H*", $_ + for $cv->recv; + # => 20014860a00300000000000000000068 =cut @@ -248,23 +469,52 @@ } else { require AnyEvent::DNS; - # simple, bad suboptimal algorithm - AnyEvent::DNS::a ($name, sub { - if (@_) { - $cb->(map +(parse_ipv4 $_), @_); - } else { - $cb->(); - #AnyEvent::DNS::aaaa ($name, $cb); need inet_pton - } - }); + 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; } } -# check for broken platforms with extra field in sockaddr structure +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 == Socket::sockaddr_family "\x55\x55" +# correctness vs. bsd issue.) +my $pack_family = 0x55 == sockaddr_family ("\x55\x55") ? "xC" : "S"; =item $sa = AnyEvent::Socket::pack_sockaddr $service, $host @@ -274,6 +524,12 @@ domain sockets (C<$host> == C 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($$) { @@ -309,15 +565,21 @@ =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. + +my $sa_un_zero = eval { Socket::pack_sockaddr_un "" }; $sa_un_zero ^= $sa_un_zero; + sub unpack_sockaddr($) { - my $af = Socket::sockaddr_family $_[0]; + 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]), pack "S", AF_UNIX) + ((Socket::unpack_sockaddr_un $_[0] ^ $sa_un_zero), pack "S", AF_UNIX) } else { Carp::croak "unpack_sockaddr: unsupported protocol family $af"; } @@ -330,13 +592,14 @@ protocol-independent way. It works remotely similar to the getaddrinfo posix function. -For internet addresses, C<$node> is either an IPv4 or IPv6 address or an -internet hostname, and C<$service> is either a service name (port name -from F) 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 (e.g. C). +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) 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 +(e.g. C). For UNIX domain sockets, C<$node> must be the string C and C<$service> must be the absolute pathname of the socket. In this case, @@ -348,11 +611,12 @@ 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). This setting might be influenced by +only IPv4) or C<6> (use only IPv6). The default is influenced by C<$ENV{PERL_ANYEVENT_PROTOCOLS}>. C<$type> must be C, C or C (or -C in which case it gets automatically chosen). +C in which case it gets automatically chosen to be C +unless C<$proto> is C). The callback will receive zero or more array references that contain C<$family, $type, $proto> for use in C and a binary @@ -370,9 +634,9 @@ my ($node, $service, $proto, $family, $type, $cb) = @_; if ($node eq "unix/") { - return $cb->() if $family || !/^\//; # no can do + return $cb->() if $family || $service !~ /^\//; # no can do - return $cb->([AF_UNIX, $type, 0, Socket::pack_sockaddr_un $service]); + return $cb->([AF_UNIX, defined $type ? $type : SOCK_STREAM, 0, Socket::pack_sockaddr_un $service]); } unless (AF_INET6) { @@ -391,7 +655,7 @@ $proto ||= "tcp"; $type ||= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM; - my $proton = (getprotobyname $proto)[2] + my $proton = AnyEvent::Socket::getprotobyname $proto or Carp::croak "$proto: protocol unknown"; my $port; @@ -405,12 +669,12 @@ or Carp::croak "$service/$proto: service unknown"; } - my @target = [$node, $port]; - # resolve a records / provide sockaddr structures my $resolve = sub { + my @target = @_; + my @res; - my $cv = AnyEvent->condvar (cb => sub { + my $cv = AE::cv { $cb->( map $_->[2], sort { @@ -419,19 +683,21 @@ } @res ) - }); + }; $cv->begin; for my $idx (0 .. $#target) { my ($node, $port) = @{ $target[$idx] }; if (my $noden = parse_address $node) { - if (4 == length $noden && $family != 6) { + my $af = address_family $noden; + + if ($af == AF_INET && $family != 6) { push @res, [$idx, "ipv4", [AF_INET, $type, $proton, pack_sockaddr $port, $noden]] } - if (16 == length $noden && $family != 4) { + if ($af == AF_INET6 && $family != 4) { push @res, [$idx, "ipv6", [AF_INET6, $type, $proton, pack_sockaddr $port, $noden]] } @@ -439,7 +705,7 @@ # ipv4 if ($family != 6) { $cv->begin; - a $node, sub { + AnyEvent::DNS::a $node, sub { push @res, [$idx, "ipv4", [AF_INET, $type, $proton, pack_sockaddr $port, parse_ipv4 $_]] for @_; @@ -450,7 +716,7 @@ # ipv6 if ($family != 4) { $cv->begin; - aaaa $node, sub { + AnyEvent::DNS::aaaa $node, sub { push @res, [$idx, "ipv6", [AF_INET6, $type, $proton, pack_sockaddr $port, parse_ipv6 $_]] for @_; @@ -462,42 +728,46 @@ $cv->end; }; + $node = AnyEvent::Util::idn_to_ascii $node + if $node =~ /[^\x00-\x7f]/; + # try srv records, if applicable if ($node eq "localhost") { - @target = (["127.0.0.1", $port], ["::1", $port]); - &$resolve; + $resolve->(["127.0.0.1", $port], ["::1", $port]); } elsif (defined $service && !parse_address $node) { - srv $service, $proto, $node, sub { + AnyEvent::DNS::srv $service, $proto, $node, sub { my (@srv) = @_; - # no srv records, continue traditionally - @srv - or return &$resolve; - - # only srv record has "." => abort - $srv[0][2] ne "." || $#srv - or return $cb->(); - - # use srv records then - @target = map ["$_->[3].", $_->[2]], - grep $_->[3] ne ".", - @srv; - - &$resolve; + if (@srv) { + # the only srv record has "." ("" here) => abort + $srv[0][2] ne "" || $#srv + or return $cb->(); + + # use srv records then + $resolve->( + map ["$_->[3].", $_->[2]], + grep $_->[3] ne ".", + @srv + ); + } else { + # no srv records, continue traditionally + $resolve->([$node, $port]); + } }; } else { - &$resolve; + # 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 hostname or -a textual IP address, or the string C for UNIX domain sockets) -and C<$service> (which can be a numeric port number or a service name, -or a C string, or the pathname to a UNIX domain -socket). +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 for UNIX domain +sockets) and C<$service> (which can be a numeric port number or a service +name, or a C 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). @@ -506,14 +776,14 @@ hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to each in turn. -If the connect is successful, 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 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. +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 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) @@ -521,12 +791,18 @@ without any arguments and C<$!> will be set appropriately (with C indicating a DNS resolution failure). +The callback will I be invoked before C returns, even +if C was able to connect immediately (e.g. on unix domain +sockets). + The file handle is perfect for being plugged into L, but can be used as a normal perl file handle as well. Unless called in void context, C returns a guard object that -will automatically abort connecting when it gets destroyed (it does not do -anything to the socket after the connect was successful). +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 it to some port, or you want a specific connect timeout that @@ -550,11 +826,11 @@ Simple Example: connect to localhost on port 22. - tcp_connect localhost => 22, sub { - my $fh = shift - or die "unable to connect: $!"; - # do something - }; + 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 @@ -568,14 +844,18 @@ my $handle; # avoid direct assignment so on_eof has it in scope. $handle = new AnyEvent::Handle fh => $fh, + on_error => sub { + warn "error $_[2]\n"; + $_[0]->destroy; + }, on_eof => sub { - undef $handle; # keep it alive till eof + $handle->destroy; # destroy handle warn "done.\n"; }; $handle->push_write ("GET / HTTP/1.0\015\012\015\012"); - $handle->push_read_line ("\015\012\015\012", sub { + $handle->push_read (line => "\015\012\015\012", sub { my ($handle, $line) = @_; # print response header @@ -605,22 +885,23 @@ sub tcp_connect($$$;$) { my ($host, $port, $connect, $prepare) = @_; - # see http://cr.yp.to/docs/connect.html for some background + # 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, 0, sub { + resolve_sockaddr $host, $port, 0, 0, undef, sub { my @target = @_; $state{next} = sub { return unless exists $state{fh}; my $target = shift @target - or do { + or return _postpone sub { + return unless exists $state{fh}; %state = (); - return $connect->(); + $connect->(); }; my ($domain, $type, $proto, $sockaddr) = @$target; @@ -635,51 +916,60 @@ $timeout ||= 30 if AnyEvent::WIN32; - $state{to} = AnyEvent->timer (after => $timeout, cb => sub { - $! = &Errno::ETIMEDOUT; + $state{to} = AE::timer $timeout, 0, sub { + $! = Errno::ETIMEDOUT; $state{next}(); - }) if $timeout; + } if $timeout; - # called when the connect was successful, which, - # in theory, could be the case immediately (but never is in practise) - my $connected = sub { - delete $state{ww}; - delete $state{to}; - - # we are connected, or maybe there was an error - if (my $sin = getpeername $state{fh}) { - my ($port, $host) = unpack_sockaddr $sin; + # 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; + } - my $guard = guard { - %state = (); - }; + return if $! == Errno::EAGAIN; # skip spurious wake-ups - $connect->($state{fh}, format_address $host, $port, sub { - $guard->cancel; - $state{next}(); - }); - } else { - # dummy read to fetch real error code - sysread $state{fh}, my $buf, 1 if $! == &Errno::ENOTCONN; - $state{next}(); - } - }; + delete $state{ww}; delete $state{to}; - # now connect - if (connect $state{fh}, $sockaddr) { - $connected->(); - } elsif ($! == &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} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $connected); + $state{next}(); + } + }; } else { $state{next}(); } }; - $! = &Errno::ENXIO; + $! = Errno::ENXIO; $state{next}(); }; @@ -693,8 +983,9 @@ implies, this function can also bind on UNIX domain sockets. For internet sockets, C<$host> must be an IPv4 or IPv6 address (or -C, in which case it binds either to C<0> or to C<::>, depending on -whether IPv4 or IPv6 is the preferred protocol). +C, 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<::>. @@ -710,7 +1001,7 @@ For each new connection that could be Ced, 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 +mode) as first, and the peer host and port as second and third arguments (see C for details). Croaks on any errors it can detect before the listen. @@ -718,7 +1009,7 @@ If called in non-void context, then this function returns a guard object whose lifetime it tied to the TCP server: If the object gets destroyed, the server will be stopped (but existing accepted connections will -continue). +not be affected). 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 @@ -728,6 +1019,13 @@ 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 errors. + Example: bind on some TCP port on the local machine and tell each client to go away. @@ -740,6 +1038,12 @@ warn "bound to $thishost, port $thisport\n"; }; +Example: bind a server on a unix domain socket. + + tcp_server "unix/", "/tmp/mydir/mysocket", sub { + my ($fh) = @_; + }; + =cut sub tcp_server($$$;$) { @@ -793,25 +1097,63 @@ listen $state{fh}, $len or Carp::croak "listen: $!"; - $state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub { + $state{aw} = AE::io $state{fh}, 0, sub { # this closure keeps $state alive - while (my $peer = accept my $fh, $state{fh}) { + while ($state{fh} && (my $peer = accept my $fh, $state{fh})) { fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not my ($service, $host) = unpack_sockaddr $peer; $accept->($fh, format_address $host, $service); } - }); + }; defined wantarray ? guard { %state = () } # clear fh and watcher, which breaks the circular dependency : () } +=item tcp_nodelay $fh, $enable + +Enables (or disables) the C 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 +socket option). The default is OS-specific, but is usually +C. Typical other available choices include C, C, C, +C, C, C, C, C, C, +C, C and C. + +=cut + +sub tcp_congestion($$) { + defined TCP_CONGESTION + ? setsockopt $_[0], Socket::IPPROTO_TCP (), TCP_CONGESTION, "$_[1]" + : undef +} + 1; =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). 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