--- AnyEvent/lib/AnyEvent/Socket.pm 2008/05/25 01:05:27 1.20 +++ AnyEvent/lib/AnyEvent/Socket.pm 2009/07/18 05:19:09 1.97 @@ -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,30 @@ package AnyEvent::Socket; -no warnings; -use strict; - use Carp (); use Errno (); -use Socket (); +use Socket qw(AF_INET AF_UNIX SOCK_STREAM SOCK_DGRAM SOL_SOCKET SO_REUSEADDR); -use AnyEvent (); -use AnyEvent::Util qw(guard fh_nonblocking); +use AnyEvent (); BEGIN { AnyEvent::common_sense } +use AnyEvent::Util qw(guard fh_nonblocking AF_INET6); use AnyEvent::DNS (); use base 'Exporter'; -our @EXPORT = qw(parse_ipv4 parse_ipv6 parse_ip format_ip inet_aton tcp_server tcp_connect); +our @EXPORT = qw( + getprotobyname + parse_hostport + parse_ipv4 parse_ipv6 + parse_ip parse_address + format_ipv4 format_ipv6 + format_ip format_address + address_family + inet_aton + tcp_server + tcp_connect +); -our $VERSION = '1.0'; +our $VERSION = 4.85; =item $ipn = parse_ipv4 $dotted_quad @@ -72,7 +80,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) @@ -86,7 +94,8 @@ octet form (or undef when it isn't in a parsable format). Should support all forms specified by RFC 2373 (and additionally all IPv4 -forms supported by parse_ipv4). +forms supported by parse_ipv4). Note that scope-id's are not supported +(and will not parse). This function works similarly to C. @@ -129,47 +138,250 @@ pack "n*", map hex, @h, @t } -=item $ipn = parse_ip $text +sub parse_unix($) { + $_[0] eq "unix/" + ? pack "S", AF_UNIX + : undef + +} + +=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 +(binary). + +If the C<$text> is C, then this function returns a special token +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. + +=item $ipn = AnyEvent::Socket::aton $ip + +Same as C, but not exported (think C but +I name resolution). + +=cut + +sub parse_address($) { + 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 -Combines C and C in one function. +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. =cut -sub parse_ip($) { - &parse_ipv4 || &parse_ipv6 +# 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) } -=item $text = format_ip $ipn +=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 weas 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" -Takes either an IPv4 address (4 octets) or and IPv6 address (16 octets) -and converts it into textual form. + 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 $sa_family = address_family $ipn + +Returns the address family/protocol-family (AF_xxx/PF_xxx, in one value :) +of the given host address in network format. + +=cut + +sub address_family($) { + 4 == length $_[0] + ? AF_INET + : 16 == length $_[0] + ? AF_INET6 + : 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 +octets for IPv6) and convert it into textual form. + +Returns C for UNIX domain sockets. This function works similarly to C, except it automatically detects the address type. +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. + +=item $text = AnyEvent::Socket::ntoa $ipn + +Same as format_address, but not exported (think C). + =cut -sub format_ip; -sub format_ip($) { - if (4 == length $_[0]) { - return join ".", unpack "C4", $_[0] - } elsif (16 == length $_[0]) { - if (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) { - # v4mapped - return "::ffff:" . format_ip substr $_[0], 12; - } else { - my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0]; +sub format_ipv4($) { + join ".", unpack "C4", $_[0] +} - $ip =~ s/^0:(?:0:)*/::/ - or $ip =~ s/(:0)+$/::/ - or $ip =~ s/(:0)+/:/; - return $ip - } +sub format_ipv6($) { + 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_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_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_ipv4 substr $_[0], 12; + } else { + my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0]; + + # this is rather sucky, I admit + $ip =~ s/^0:(?:0:)*(0$)?/::/ + or $ip =~ s/(:0){7}$/::/ or $ip =~ s/(:0){7}/:/ + or $ip =~ s/(:0){6}$/::/ or $ip =~ s/(:0){6}/:/ + or $ip =~ s/(:0){5}$/::/ or $ip =~ s/(:0){5}/:/ + or $ip =~ s/(:0){4}$/::/ or $ip =~ s/(:0){4}/:/ + or $ip =~ s/(:0){3}$/::/ or $ip =~ s/(:0){3}/:/ + or $ip =~ s/(:0){2}$/::/ or $ip =~ s/(:0){2}/:/ + or $ip =~ s/(:0){1}$/::/ or $ip =~ s/(:0){1}/:/; + return $ip + } +} + +sub format_address($) { + my $af = address_family $_[0]; + if ($af == AF_INET) { + return &format_ipv4; + } elsif ($af == AF_INET6) { + return (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) + ? format_ipv4 substr $_[0], 12 + : &format_ipv6; + } elsif ($af == AF_UNIX) { + return "unix/" } else { return undef } } +*ntoa = \&format_address; + =item inet_aton $name_or_address, $cb->(@addresses) Works similarly to its Socket counterpart, except that it uses a @@ -178,7 +390,7 @@ for IPv6). Unlike the L function of the same name, you can get multiple IPv4 -and IPv6 addresses as result. +and IPv6 addresses as result (and maybe even other adrdess types). =cut @@ -206,62 +418,257 @@ } } -=item $sa = AnyEvent::Socket::pack_sockaddr $port, $host +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] }; +} -Pack the given port/host combination into a binary sockaddr structure. Handles -both IPv4 and IPv6 host addresses. +# check for broken platforms with 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 and C<$service> == absolute +pathname). =cut sub pack_sockaddr($$) { - if (4 == length $_[1]) { + my $af = address_family $_[1]; + + if ($af == AF_INET) { Socket::pack_sockaddr_in $_[0], $_[1] - } elsif (16 == length $_[1]) { - pack "SnL a16 L", - &AnyEvent::Util::AF_INET6, + } 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 ($port, $host) = AnyEvent::Socket::unpack_sockaddr $sa +=item ($service, $host) = AnyEvent::Socket::unpack_sockaddr $sa Unpack the given binary sockaddr structure (as used by bind, getpeername -etc.) into a C<$port, $host> combination. +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). -Handles both IPv4 and IPv6 sockaddr structures. +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 converts it to C). =cut sub unpack_sockaddr($) { - my $af = unpack "S", $_[0]; + my $af = sockaddr_family $_[0]; - if ($af == &Socket::AF_INET) { + if ($af == AF_INET) { Socket::unpack_sockaddr_in $_[0] - } elsif ($af == &AnyEvent::Util::AF_INET6) { - (unpack "SnL a16 L")[1, 3] + } elsif ($af == AF_INET6) { + unpack "x2 n x4 a16", $_[0] + } elsif ($af == AF_UNIX) { + ((Socket::unpack_sockaddr_un $_[0]), pack "S", AF_UNIX) } else { Carp::croak "unpack_sockaddr: unsupported protocol family $af"; } } -sub _tcp_port($) { - $_[0] =~ /^(\d*)$/ and return $1*1; +=item 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 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 UNIX domain sockets, C<$node> must be the string C 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, C or +C. The default is currently C, but in the future, this function +might try to use other protocols such as C, 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, C or C (or +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 +C<$sockaddr> for use in C (or C). + +The application should try these in the order given. + +Example: + + resolve_sockaddr "google.com", "http", 0, undef, undef, sub { ... }; + +=cut + +sub resolve_sockaddr($$$$$$) { + my ($node, $service, $proto, $family, $type, $cb) = @_; + + if ($node eq "unix/") { + return $cb->() if $family || $service !~ /^\//; # no can do + + return $cb->([AF_UNIX, defined $type ? $type : SOCK_STREAM, 0, Socket::pack_sockaddr_un $service]); + } + + unless (AF_INET6) { + $family != 6 + or return $cb->(); + + $family = 4; + } + + $cb->() if $family == 4 && !$AnyEvent::PROTOCOL{ipv4}; + $cb->() if $family == 6 && !$AnyEvent::PROTOCOL{ipv6}; + + $family ||= 4 unless $AnyEvent::PROTOCOL{ipv6}; + $family ||= 6 unless $AnyEvent::PROTOCOL{ipv4}; + + $proto ||= "tcp"; + $type ||= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM; + + my $proton = getprotobyname $proto + or Carp::croak "$proto: protocol unknown"; - (getservbyname $_[0], "tcp")[2] - or Carp::croak "$_[0]: service unknown" + my $port; + + if ($service =~ /^(\S+)=(\d+)$/) { + ($service, $port) = ($1, $2); + } elsif ($service =~ /^\d+$/) { + ($service, $port) = (undef, $service); + } else { + $port = (getservbyname $service, $proto)[2] + or Carp::croak "$service/$proto: service unknown"; + } + + my @target = [$node, $port]; + + # resolve a records / provide sockaddr structures + my $resolve = sub { + my @res; + my $cv = AnyEvent->condvar (cb => sub { + $cb->( + map $_->[2], + sort { + $AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]} + or $a->[0] <=> $b->[0] + } + @res + ) + }); + + $cv->begin; + for my $idx (0 .. $#target) { + my ($node, $port) = @{ $target[$idx] }; + + if (my $noden = parse_address $node) { + my $af = address_family $noden; + + if ($af == AF_INET && $family != 6) { + push @res, [$idx, "ipv4", [AF_INET, $type, $proton, + pack_sockaddr $port, $noden]] + } + + if ($af == AF_INET6 && $family != 4) { + push @res, [$idx, "ipv6", [AF_INET6, $type, $proton, + pack_sockaddr $port, $noden]] + } + } else { + # ipv4 + if ($family != 6) { + $cv->begin; + AnyEvent::DNS::a $node, sub { + push @res, [$idx, "ipv4", [AF_INET, $type, $proton, + pack_sockaddr $port, parse_ipv4 $_]] + for @_; + $cv->end; + }; + } + + # ipv6 + if ($family != 4) { + $cv->begin; + AnyEvent::DNS::aaaa $node, sub { + push @res, [$idx, "ipv6", [AF_INET6, $type, $proton, + pack_sockaddr $port, parse_ipv6 $_]] + for @_; + $cv->end; + }; + } + } + } + $cv->end; + }; + + # try srv records, if applicable + if ($node eq "localhost") { + @target = (["127.0.0.1", $port], ["::1", $port]); + &$resolve; + } elsif (defined $service && !parse_address $node) { + AnyEvent::DNS::srv $service, $proto, $node, sub { + my (@srv) = @_; + + # no srv records, continue traditionally + @srv + or return &$resolve; + + # the only srv record has "." ("" here) => abort + $srv[0][2] ne "" || $#srv + or return $cb->(); + + # use srv records then + @target = map ["$_->[3].", $_->[2]], + grep $_->[3] ne ".", + @srv; + + &$resolve; + }; + } else { + &$resolve; + } } =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) and C<$service> (which can be a numeric port number or -a service name, or a C string). +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). If both C<$host> and C<$port> are names, then this function will use SRV records to locate the real target(s). @@ -303,13 +710,22 @@ Note that the socket could be either a IPv4 TCP socket or an IPv6 TCP socket (although only IPv4 is currently supported by this module). +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 and L. Additionally, +AnyEvent works around this bug with L 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 - }; + 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 @@ -323,8 +739,12 @@ 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"; }; @@ -349,27 +769,31 @@ 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 background + # also http://advogato.org/article/672.html my %state = ( fh => undef ); - # name resolution - AnyEvent::DNS::addr $host, $port, 0, 0, 0, sub { + # 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 $target = shift @target - or do { - %state = (); - return $connect->(); - }; + or return (%state = (), $connect->()); my ($domain, $type, $proto, $sockaddr) = @$target; @@ -379,71 +803,92 @@ fh_nonblocking $state{fh}, 1; - # prepare and optional timeout - if ($prepare) { - my $timeout = $prepare->($state{fh}); + my $timeout = $prepare && $prepare->($state{fh}); - $state{to} = AnyEvent->timer (after => $timeout, cb => sub { - $! = &Errno::ETIMEDOUT; - $state{next}(); - }) if $timeout; - } + $timeout ||= 30 if AnyEvent::WIN32; + + $state{to} = AnyEvent->timer (after => $timeout, cb => sub { + $! = Errno::ETIMEDOUT; + $state{next}(); + }) 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}; - + $state{connected} = sub { # we are connected, or maybe there was an error if (my $sin = getpeername $state{fh}) { my ($port, $host) = unpack_sockaddr $sin; - my $guard = guard { - %state = (); - }; + delete $state{ww}; delete $state{to}; - $connect->($state{fh}, format_ip $host, $port, sub { + my $guard = guard { %state = () }; + + $connect->(delete $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; + sysread $state{fh}, my $buf, 1 if $! == Errno::ENOTCONN; + + return if $! == Errno::EAGAIN; # skip spurious wake-ups + + delete $state{ww}; delete $state{to}; + $state{next}(); } }; # now connect if (connect $state{fh}, $sockaddr) { - $connected->(); - } elsif ($! == &Errno::EINPROGRESS || $! == &Errno::EWOULDBLOCK) { # EINPROGRESS is POSIX - $state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $connected); + $state{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 => $state{connected}); } else { - %state = (); - $connect->(); + $state{next}(); } }; - $! = &Errno::ENXIO; + $! = Errno::ENXIO; $state{next}(); }; defined wantarray && guard { %state = () } } -=item $guard = tcp_server $host, $port, $accept_cb[, $prepare_cb] +=item $guard = tcp_server $host, $service, $accept_cb[, $prepare_cb] -Create and bind a TCP socket to the given host (any IPv4 host if undef, -otherwise it must be an IPv4 or IPv6 address) and port (service name or -numeric port number, or an ephemeral port if given as zero or undef), set -the SO_REUSEADDR flag and call C. - -For each new connection that could be Ced, call the C<$accept_cb> -with the file handle (in non-blocking mode) as first and the peer host and -port as second and third arguments (see C for details). +Create and bind a stream socket to the given host, and port, set the +SO_REUSEADDR flag (if applicable) and call C. 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, 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, in which case an ephemeral +port will be used). + +For UNIX domain sockets, C<$host> must be C and C<$service> must be +the absolute pathname of the socket. This function will try to C +the socket before it tries to bind to it. See SECURITY CONSIDERATIONS, +below. + +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 +(see C for details). -Croaks on any errors. +Croaks on any errors it can detect before the listen. 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, @@ -451,39 +896,87 @@ continue). If you need more control over the listening socket, you can provide a -C<$prepare_cb>, which is called just before the C call, with -the listen file handle as first argument. +C<< $prepare_cb->($fh, $host, $port) >>, which is called just before the +C 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). -Example: bind on TCP port 8888 on the local machine and tell each client +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. - tcp_server undef, 8888, sub { + 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) = @_; + 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($$$;$) { - my ($host, $port, $accept, $prepare) = @_; + my ($host, $service, $accept, $prepare) = @_; - my %state; + $host = $AnyEvent::PROTOCOL{ipv4} < $AnyEvent::PROTOCOL{ipv6} && AF_INET6 + ? "::" : "0" + unless defined $host; + + my $ipn = parse_address $host + or Carp::croak "AnyEvent::Socket::tcp_server: cannot parse '$host' as host address"; - socket $state{fh}, &Socket::AF_INET, &Socket::SOCK_STREAM, 0 - or Carp::croak "socket: $!"; + my $af = address_family $ipn; - setsockopt $state{fh}, &Socket::SOL_SOCKET, &Socket::SO_REUSEADDR, 1 - or Carp::croak "so_reuseaddr: $!"; + my %state; - bind $state{fh}, Socket::pack_sockaddr_in _tcp_port $port, parse_ip ($host || "0.0.0.0") + # win32 perl is too stupid to get this right :/ + Carp::croak "tcp_server/socket: address family not supported" + if AnyEvent::WIN32 && $af == AF_UNIX; + + socket $state{fh}, $af, SOCK_STREAM, 0 + or Carp::croak "tcp_server/socket: $!"; + + if ($af == AF_INET || $af == AF_INET6) { + setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1 + or Carp::croak "tcp_server/so_reuseaddr: $!" + unless AnyEvent::WIN32; # work around windows bug + + unless ($service =~ /^\d*$/) { + $service = (getservbyname $service, "tcp")[2] + or Carp::croak "$service: service unknown" + } + } elsif ($af == AF_UNIX) { + unlink $service; + } + + bind $state{fh}, pack_sockaddr $service, $ipn or Carp::croak "bind: $!"; fh_nonblocking $state{fh}, 1; - my $len = ($prepare && $prepare->($state{fh})) || 128; + my $len; + + if ($prepare) { + my ($service, $host) = unpack_sockaddr getsockname $state{fh}; + $len = $prepare && $prepare->($state{fh}, format_address $host, $service); + } + + $len ||= 128; listen $state{fh}, $len or Carp::croak "listen: $!"; @@ -492,8 +985,9 @@ # this closure keeps $state alive while (my $peer = accept my $fh, $state{fh}) { fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not - my ($port, $host) = Socket::unpack_sockaddr_in $peer; - $accept->($fh, (Socket::inet_ntoa $host), $port); + + my ($service, $host) = unpack_sockaddr $peer; + $accept->($fh, format_address $host, $service); } }); @@ -506,6 +1000,15 @@ =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