| 1 |
=head1 NAME |
| 2 |
|
| 3 |
AnyEvent::Socket - useful IPv4 and IPv6 stuff. |
| 4 |
|
| 5 |
=head1 SYNOPSIS |
| 6 |
|
| 7 |
use AnyEvent::Socket; |
| 8 |
|
| 9 |
tcp_connect "gameserver.deliantra.net", 13327, sub { |
| 10 |
my ($fh) = @_ |
| 11 |
or die "gameserver.deliantra.net connect failed: $!"; |
| 12 |
|
| 13 |
# enjoy your filehandle |
| 14 |
}; |
| 15 |
|
| 16 |
# a simple tcp server |
| 17 |
tcp_server undef, 8888, sub { |
| 18 |
my ($fh, $host, $port) = @_; |
| 19 |
|
| 20 |
syswrite $fh, "The internet is full, $host:$port. Go away!\015\012"; |
| 21 |
}; |
| 22 |
|
| 23 |
=head1 DESCRIPTION |
| 24 |
|
| 25 |
This module implements various utility functions for handling internet |
| 26 |
protocol addresses and sockets, in an as transparent and simple way as |
| 27 |
possible. |
| 28 |
|
| 29 |
All functions documented without C<AnyEvent::Socket::> prefix are exported |
| 30 |
by default. |
| 31 |
|
| 32 |
=over 4 |
| 33 |
|
| 34 |
=cut |
| 35 |
|
| 36 |
package AnyEvent::Socket; |
| 37 |
|
| 38 |
no warnings; |
| 39 |
use strict; |
| 40 |
|
| 41 |
use Carp (); |
| 42 |
use Errno (); |
| 43 |
use Socket qw(AF_INET AF_UNIX SOCK_STREAM SOCK_DGRAM SOL_SOCKET SO_REUSEADDR); |
| 44 |
|
| 45 |
use AnyEvent (); |
| 46 |
use AnyEvent::Util qw(guard fh_nonblocking AF_INET6); |
| 47 |
use AnyEvent::DNS (); |
| 48 |
|
| 49 |
use base 'Exporter'; |
| 50 |
|
| 51 |
our @EXPORT = qw( |
| 52 |
parse_ipv4 parse_ipv6 |
| 53 |
parse_ip parse_address |
| 54 |
format_ip format_address |
| 55 |
address_family |
| 56 |
inet_aton |
| 57 |
tcp_server |
| 58 |
tcp_connect |
| 59 |
); |
| 60 |
|
| 61 |
our $VERSION = 4.1; |
| 62 |
|
| 63 |
=item $ipn = parse_ipv4 $dotted_quad |
| 64 |
|
| 65 |
Tries to parse the given dotted quad IPv4 address and return it in |
| 66 |
octet form (or undef when it isn't in a parsable format). Supports all |
| 67 |
forms specified by POSIX (e.g. C<10.0.0.1>, C<10.1>, C<10.0x020304>, |
| 68 |
C<0x12345678> or C<0377.0377.0377.0377>). |
| 69 |
|
| 70 |
=cut |
| 71 |
|
| 72 |
sub parse_ipv4($) { |
| 73 |
$_[0] =~ /^ (?: 0x[0-9a-fA-F]+ | 0[0-7]* | [1-9][0-9]* ) |
| 74 |
(?:\. (?: 0x[0-9a-fA-F]+ | 0[0-7]* | [1-9][0-9]* ) ){0,3}$/x |
| 75 |
or return undef; |
| 76 |
|
| 77 |
@_ = map /^0/ ? oct : $_, split /\./, $_[0]; |
| 78 |
|
| 79 |
# check leading parts against range |
| 80 |
return undef if grep $_ >= 256, @_[0 .. @_ - 2]; |
| 81 |
|
| 82 |
# check trailing part against range |
| 83 |
return undef if $_[-1] >= 1 << (8 * (4 - $#_)); |
| 84 |
|
| 85 |
pack "N", (pop) |
| 86 |
+ ($_[0] << 24) |
| 87 |
+ ($_[1] << 16) |
| 88 |
+ ($_[2] << 8); |
| 89 |
} |
| 90 |
|
| 91 |
=item $ipn = parse_ipv6 $textual_ipv6_address |
| 92 |
|
| 93 |
Tries to parse the given IPv6 address and return it in |
| 94 |
octet form (or undef when it isn't in a parsable format). |
| 95 |
|
| 96 |
Should support all forms specified by RFC 2373 (and additionally all IPv4 |
| 97 |
forms supported by parse_ipv4). Note that scope-id's are not supported |
| 98 |
(and will not parse). |
| 99 |
|
| 100 |
This function works similarly to C<inet_pton AF_INET6, ...>. |
| 101 |
|
| 102 |
=cut |
| 103 |
|
| 104 |
sub parse_ipv6($) { |
| 105 |
# quick test to avoid longer processing |
| 106 |
my $n = $_[0] =~ y/://; |
| 107 |
return undef if $n < 2 || $n > 8; |
| 108 |
|
| 109 |
my ($h, $t) = split /::/, $_[0], 2; |
| 110 |
|
| 111 |
unless (defined $t) { |
| 112 |
($h, $t) = (undef, $h); |
| 113 |
} |
| 114 |
|
| 115 |
my @h = split /:/, $h; |
| 116 |
my @t = split /:/, $t; |
| 117 |
|
| 118 |
# check for ipv4 tail |
| 119 |
if (@t && $t[-1]=~ /\./) { |
| 120 |
return undef if $n > 6; |
| 121 |
|
| 122 |
my $ipn = parse_ipv4 pop @t |
| 123 |
or return undef; |
| 124 |
|
| 125 |
push @t, map +(sprintf "%x", $_), unpack "nn", $ipn; |
| 126 |
} |
| 127 |
|
| 128 |
# no :: then we need to have exactly 8 components |
| 129 |
return undef unless @h + @t == 8 || $_[0] =~ /::/; |
| 130 |
|
| 131 |
# now check all parts for validity |
| 132 |
return undef if grep !/^[0-9a-fA-F]{1,4}$/, @h, @t; |
| 133 |
|
| 134 |
# now pad... |
| 135 |
push @h, 0 while @h + @t < 8; |
| 136 |
|
| 137 |
# and done |
| 138 |
pack "n*", map hex, @h, @t |
| 139 |
} |
| 140 |
|
| 141 |
sub parse_unix($) { |
| 142 |
$_[0] eq "unix/" |
| 143 |
? pack "S", AF_UNIX |
| 144 |
: undef |
| 145 |
|
| 146 |
} |
| 147 |
|
| 148 |
=item $ipn = parse_address $text |
| 149 |
|
| 150 |
Combines C<parse_ipv4> and C<parse_ipv6> in one function. The address |
| 151 |
here refers to the host address (not socket address) in network form |
| 152 |
(binary). |
| 153 |
|
| 154 |
If the C<$text> is C<unix/>, then this function returns a special token |
| 155 |
recognised by the other functions in this module to mean "UNIX domain |
| 156 |
socket". |
| 157 |
|
| 158 |
=cut |
| 159 |
|
| 160 |
sub parse_address($) { |
| 161 |
&parse_ipv4 || &parse_ipv6 || &parse_unix |
| 162 |
} |
| 163 |
|
| 164 |
*parse_ip =\&parse_address; #d# |
| 165 |
|
| 166 |
=item $sa_family = address_family $ipn |
| 167 |
|
| 168 |
Returns the address family/protocol-family (AF_xxx/PF_xxx, in one value :) |
| 169 |
of the given host address in network format. |
| 170 |
|
| 171 |
=cut |
| 172 |
|
| 173 |
sub address_family($) { |
| 174 |
4 == length $_[0] |
| 175 |
? AF_INET |
| 176 |
: 16 == length $_[0] |
| 177 |
? AF_INET6 |
| 178 |
: unpack "S", $_[0] |
| 179 |
} |
| 180 |
|
| 181 |
=item $text = format_address $ipn |
| 182 |
|
| 183 |
Covnvert a host address in network format (e.g. 4 octets for IPv4 or 16 |
| 184 |
octets for IPv6) and convert it into textual form. |
| 185 |
|
| 186 |
Returns C<unix/> for UNIX domain sockets. |
| 187 |
|
| 188 |
This function works similarly to C<inet_ntop AF_INET || AF_INET6, ...>, |
| 189 |
except it automatically detects the address type. |
| 190 |
|
| 191 |
Returns C<undef> if it cannot detect the type. |
| 192 |
|
| 193 |
=cut |
| 194 |
|
| 195 |
sub format_address; |
| 196 |
sub format_address($) { |
| 197 |
my $af = address_family $_[0]; |
| 198 |
if ($af == AF_INET) { |
| 199 |
return join ".", unpack "C4", $_[0] |
| 200 |
} elsif ($af == AF_INET6) { |
| 201 |
if (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0 eq $_[0]) { |
| 202 |
return "::"; |
| 203 |
} elsif (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1 eq $_[0]) { |
| 204 |
return "::1"; |
| 205 |
} elsif (v0.0.0.0.0.0.0.0.0.0.0.0 eq substr $_[0], 0, 12) { |
| 206 |
# v4compatible |
| 207 |
return "::" . format_address substr $_[0], 12; |
| 208 |
} elsif (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) { |
| 209 |
# v4mapped |
| 210 |
return "::ffff:" . format_address substr $_[0], 12; |
| 211 |
} elsif (v0.0.0.0.0.0.0.0.255.255.0.0 eq substr $_[0], 0, 12) { |
| 212 |
# v4translated |
| 213 |
return "::ffff:0:" . format_address substr $_[0], 12; |
| 214 |
} else { |
| 215 |
my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0]; |
| 216 |
|
| 217 |
# this is rather sucky, I admit |
| 218 |
$ip =~ s/^0:(?:0:)*(0$)?/::/ |
| 219 |
or $ip =~ s/(:0){7}$/::/ or $ip =~ s/(:0){7}/:/ |
| 220 |
or $ip =~ s/(:0){6}$/::/ or $ip =~ s/(:0){6}/:/ |
| 221 |
or $ip =~ s/(:0){5}$/::/ or $ip =~ s/(:0){5}/:/ |
| 222 |
or $ip =~ s/(:0){4}$/::/ or $ip =~ s/(:0){4}/:/ |
| 223 |
or $ip =~ s/(:0){3}$/::/ or $ip =~ s/(:0){3}/:/ |
| 224 |
or $ip =~ s/(:0){2}$/::/ or $ip =~ s/(:0){2}/:/ |
| 225 |
or $ip =~ s/(:0){1}$/::/ or $ip =~ s/(:0){1}/:/; |
| 226 |
return $ip |
| 227 |
} |
| 228 |
} elsif ($af == AF_UNIX) { |
| 229 |
return "unix/" |
| 230 |
} else { |
| 231 |
return undef |
| 232 |
} |
| 233 |
} |
| 234 |
|
| 235 |
*format_ip = \&format_address; |
| 236 |
|
| 237 |
=item inet_aton $name_or_address, $cb->(@addresses) |
| 238 |
|
| 239 |
Works similarly to its Socket counterpart, except that it uses a |
| 240 |
callback. Also, if a host has only an IPv6 address, this might be passed |
| 241 |
to the callback instead (use the length to detect this - 4 for IPv4, 16 |
| 242 |
for IPv6). |
| 243 |
|
| 244 |
Unlike the L<Socket> function of the same name, you can get multiple IPv4 |
| 245 |
and IPv6 addresses as result (and maybe even other adrdess types). |
| 246 |
|
| 247 |
=cut |
| 248 |
|
| 249 |
sub inet_aton { |
| 250 |
my ($name, $cb) = @_; |
| 251 |
|
| 252 |
if (my $ipn = &parse_ipv4) { |
| 253 |
$cb->($ipn); |
| 254 |
} elsif (my $ipn = &parse_ipv6) { |
| 255 |
$cb->($ipn); |
| 256 |
} elsif ($name eq "localhost") { # rfc2606 et al. |
| 257 |
$cb->(v127.0.0.1, v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1); |
| 258 |
} else { |
| 259 |
require AnyEvent::DNS; |
| 260 |
|
| 261 |
# simple, bad suboptimal algorithm |
| 262 |
AnyEvent::DNS::a ($name, sub { |
| 263 |
if (@_) { |
| 264 |
$cb->(map +(parse_ipv4 $_), @_); |
| 265 |
} else { |
| 266 |
$cb->(); |
| 267 |
#AnyEvent::DNS::aaaa ($name, $cb); need inet_pton |
| 268 |
} |
| 269 |
}); |
| 270 |
} |
| 271 |
} |
| 272 |
|
| 273 |
# check for broken platforms with extra field in sockaddr structure |
| 274 |
# kind of a rfc vs. bsd issue, as usual (ok, normally it's a |
| 275 |
# unix vs. bsd issue, a iso C vs. bsd issue or simply a |
| 276 |
# correctness vs. bsd issue. |
| 277 |
my $pack_family = (0x55 == Socket::sockaddr_family "\x55\x55") |
| 278 |
? "xC" : "S"; |
| 279 |
|
| 280 |
=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host |
| 281 |
|
| 282 |
Pack the given port/host combination into a binary sockaddr |
| 283 |
structure. Handles both IPv4 and IPv6 host addresses, as well as UNIX |
| 284 |
domain sockets (C<$host> == C<unix/> and C<$service> == absolute |
| 285 |
pathname). |
| 286 |
|
| 287 |
=cut |
| 288 |
|
| 289 |
sub pack_sockaddr($$) { |
| 290 |
my $af = address_family $_[1]; |
| 291 |
|
| 292 |
if ($af == AF_INET) { |
| 293 |
Socket::pack_sockaddr_in $_[0], $_[1] |
| 294 |
} elsif ($af == AF_INET6) { |
| 295 |
pack "$pack_family nL a16 L", |
| 296 |
AF_INET6, |
| 297 |
$_[0], # port |
| 298 |
0, # flowinfo |
| 299 |
$_[1], # addr |
| 300 |
0 # scope id |
| 301 |
} elsif ($af == AF_UNIX) { |
| 302 |
Socket::pack_sockaddr_un $_[0] |
| 303 |
} else { |
| 304 |
Carp::croak "pack_sockaddr: invalid host"; |
| 305 |
} |
| 306 |
} |
| 307 |
|
| 308 |
=item ($service, $host) = AnyEvent::Socket::unpack_sockaddr $sa |
| 309 |
|
| 310 |
Unpack the given binary sockaddr structure (as used by bind, getpeername |
| 311 |
etc.) into a C<$service, $host> combination. |
| 312 |
|
| 313 |
For IPv4 and IPv6, C<$service> is the port number and C<$host> the host |
| 314 |
address in network format (binary). |
| 315 |
|
| 316 |
For UNIX domain sockets, C<$service> is the absolute pathname and C<$host> |
| 317 |
is a special token that is understood by the other functions in this |
| 318 |
module (C<format_address> converts it to C<unix/>). |
| 319 |
|
| 320 |
=cut |
| 321 |
|
| 322 |
sub unpack_sockaddr($) { |
| 323 |
my $af = Socket::sockaddr_family $_[0]; |
| 324 |
|
| 325 |
if ($af == AF_INET) { |
| 326 |
Socket::unpack_sockaddr_in $_[0] |
| 327 |
} elsif ($af == AF_INET6) { |
| 328 |
unpack "x2 n x4 a16", $_[0] |
| 329 |
} elsif ($af == AF_UNIX) { |
| 330 |
((Socket::unpack_sockaddr_un $_[0]), pack "S", AF_UNIX) |
| 331 |
} else { |
| 332 |
Carp::croak "unpack_sockaddr: unsupported protocol family $af"; |
| 333 |
} |
| 334 |
} |
| 335 |
|
| 336 |
=item resolve_sockaddr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...) |
| 337 |
|
| 338 |
Tries to resolve the given nodename and service name into protocol families |
| 339 |
and sockaddr structures usable to connect to this node and service in a |
| 340 |
protocol-independent way. It works remotely similar to the getaddrinfo |
| 341 |
posix function. |
| 342 |
|
| 343 |
For internet addresses, C<$node> is either an IPv4 or IPv6 address or an |
| 344 |
internet hostname, and C<$service> is either a service name (port name |
| 345 |
from F</etc/services>) or a numerical port number. If both C<$node> and |
| 346 |
C<$service> are names, then SRV records will be consulted to find the real |
| 347 |
service, otherwise they will be used as-is. If you know that the service |
| 348 |
name is not in your services database, then you can specify the service in |
| 349 |
the format C<name=port> (e.g. C<http=80>). |
| 350 |
|
| 351 |
For UNIX domain sockets, C<$node> must be the string C<unix/> and |
| 352 |
C<$service> must be the absolute pathname of the socket. In this case, |
| 353 |
C<$proto> will be ignored. |
| 354 |
|
| 355 |
C<$proto> must be a protocol name, currently C<tcp>, C<udp> or |
| 356 |
C<sctp>. The default is currently C<tcp>, but in the future, this function |
| 357 |
might try to use other protocols such as C<sctp>, depending on the socket |
| 358 |
type and any SRV records it might find. |
| 359 |
|
| 360 |
C<$family> must be either C<0> (meaning any protocol is OK), C<4> (use |
| 361 |
only IPv4) or C<6> (use only IPv6). This setting might be influenced by |
| 362 |
C<$ENV{PERL_ANYEVENT_PROTOCOLS}>. |
| 363 |
|
| 364 |
C<$type> must be C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_SEQPACKET> (or |
| 365 |
C<undef> in which case it gets automatically chosen). |
| 366 |
|
| 367 |
The callback will receive zero or more array references that contain |
| 368 |
C<$family, $type, $proto> for use in C<socket> and a binary |
| 369 |
C<$sockaddr> for use in C<connect> (or C<bind>). |
| 370 |
|
| 371 |
The application should try these in the order given. |
| 372 |
|
| 373 |
Example: |
| 374 |
|
| 375 |
resolve_sockaddr "google.com", "http", 0, undef, undef, sub { ... }; |
| 376 |
|
| 377 |
=cut |
| 378 |
|
| 379 |
sub resolve_sockaddr($$$$$$) { |
| 380 |
my ($node, $service, $proto, $family, $type, $cb) = @_; |
| 381 |
|
| 382 |
if ($node eq "unix/") { |
| 383 |
return $cb->() if $family || !/^\//; # no can do |
| 384 |
|
| 385 |
return $cb->([AF_UNIX, $type, 0, Socket::pack_sockaddr_un $service]); |
| 386 |
} |
| 387 |
|
| 388 |
unless (AF_INET6) { |
| 389 |
$family != 6 |
| 390 |
or return $cb->(); |
| 391 |
|
| 392 |
$family = 4; |
| 393 |
} |
| 394 |
|
| 395 |
$cb->() if $family == 4 && !$AnyEvent::PROTOCOL{ipv4}; |
| 396 |
$cb->() if $family == 6 && !$AnyEvent::PROTOCOL{ipv6}; |
| 397 |
|
| 398 |
$family ||= 4 unless $AnyEvent::PROTOCOL{ipv6}; |
| 399 |
$family ||= 6 unless $AnyEvent::PROTOCOL{ipv4}; |
| 400 |
|
| 401 |
$proto ||= "tcp"; |
| 402 |
$type ||= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM; |
| 403 |
|
| 404 |
my $proton = (getprotobyname $proto)[2] |
| 405 |
or Carp::croak "$proto: protocol unknown"; |
| 406 |
|
| 407 |
my $port; |
| 408 |
|
| 409 |
if ($service =~ /^(\S+)=(\d+)$/) { |
| 410 |
($service, $port) = ($1, $2); |
| 411 |
} elsif ($service =~ /^\d+$/) { |
| 412 |
($service, $port) = (undef, $service); |
| 413 |
} else { |
| 414 |
$port = (getservbyname $service, $proto)[2] |
| 415 |
or Carp::croak "$service/$proto: service unknown"; |
| 416 |
} |
| 417 |
|
| 418 |
my @target = [$node, $port]; |
| 419 |
|
| 420 |
# resolve a records / provide sockaddr structures |
| 421 |
my $resolve = sub { |
| 422 |
my @res; |
| 423 |
my $cv = AnyEvent->condvar (cb => sub { |
| 424 |
$cb->( |
| 425 |
map $_->[2], |
| 426 |
sort { |
| 427 |
$AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]} |
| 428 |
or $a->[0] <=> $b->[0] |
| 429 |
} |
| 430 |
@res |
| 431 |
) |
| 432 |
}); |
| 433 |
|
| 434 |
$cv->begin; |
| 435 |
for my $idx (0 .. $#target) { |
| 436 |
my ($node, $port) = @{ $target[$idx] }; |
| 437 |
|
| 438 |
if (my $noden = parse_address $node) { |
| 439 |
my $af = address_family $noden; |
| 440 |
|
| 441 |
if ($af == AF_INET && $family != 6) { |
| 442 |
push @res, [$idx, "ipv4", [AF_INET, $type, $proton, |
| 443 |
pack_sockaddr $port, $noden]] |
| 444 |
} |
| 445 |
|
| 446 |
if ($af == AF_INET6 && $family != 4) { |
| 447 |
push @res, [$idx, "ipv6", [AF_INET6, $type, $proton, |
| 448 |
pack_sockaddr $port, $noden]] |
| 449 |
} |
| 450 |
} else { |
| 451 |
# ipv4 |
| 452 |
if ($family != 6) { |
| 453 |
$cv->begin; |
| 454 |
AnyEvent::DNS::a $node, sub { |
| 455 |
push @res, [$idx, "ipv4", [AF_INET, $type, $proton, |
| 456 |
pack_sockaddr $port, parse_ipv4 $_]] |
| 457 |
for @_; |
| 458 |
$cv->end; |
| 459 |
}; |
| 460 |
} |
| 461 |
|
| 462 |
# ipv6 |
| 463 |
if ($family != 4) { |
| 464 |
$cv->begin; |
| 465 |
AnyEvent::DNS::aaaa $node, sub { |
| 466 |
push @res, [$idx, "ipv6", [AF_INET6, $type, $proton, |
| 467 |
pack_sockaddr $port, parse_ipv6 $_]] |
| 468 |
for @_; |
| 469 |
$cv->end; |
| 470 |
}; |
| 471 |
} |
| 472 |
} |
| 473 |
} |
| 474 |
$cv->end; |
| 475 |
}; |
| 476 |
|
| 477 |
# try srv records, if applicable |
| 478 |
if ($node eq "localhost") { |
| 479 |
@target = (["127.0.0.1", $port], ["::1", $port]); |
| 480 |
&$resolve; |
| 481 |
} elsif (defined $service && !parse_address $node) { |
| 482 |
AnyEvent::DNS::srv $service, $proto, $node, sub { |
| 483 |
my (@srv) = @_; |
| 484 |
|
| 485 |
# no srv records, continue traditionally |
| 486 |
@srv |
| 487 |
or return &$resolve; |
| 488 |
|
| 489 |
# the only srv record has "." ("" here) => abort |
| 490 |
$srv[0][2] ne "" || $#srv |
| 491 |
or return $cb->(); |
| 492 |
|
| 493 |
# use srv records then |
| 494 |
@target = map ["$_->[3].", $_->[2]], |
| 495 |
grep $_->[3] ne ".", |
| 496 |
@srv; |
| 497 |
|
| 498 |
&$resolve; |
| 499 |
}; |
| 500 |
} else { |
| 501 |
&$resolve; |
| 502 |
} |
| 503 |
} |
| 504 |
|
| 505 |
=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb] |
| 506 |
|
| 507 |
This is a convenience function that creates a TCP socket and makes a 100% |
| 508 |
non-blocking connect to the given C<$host> (which can be a hostname or |
| 509 |
a textual IP address, or the string C<unix/> for UNIX domain sockets) |
| 510 |
and C<$service> (which can be a numeric port number or a service name, |
| 511 |
or a C<servicename=portnumber> string, or the pathname to a UNIX domain |
| 512 |
socket). |
| 513 |
|
| 514 |
If both C<$host> and C<$port> are names, then this function will use SRV |
| 515 |
records to locate the real target(s). |
| 516 |
|
| 517 |
In either case, it will create a list of target hosts (e.g. for multihomed |
| 518 |
hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to |
| 519 |
each in turn. |
| 520 |
|
| 521 |
If the connect is successful, then the C<$connect_cb> will be invoked with |
| 522 |
the socket file handle (in non-blocking mode) as first and the peer host |
| 523 |
(as a textual IP address) and peer port as second and third arguments, |
| 524 |
respectively. The fourth argument is a code reference that you can call |
| 525 |
if, for some reason, you don't like this connection, which will cause |
| 526 |
C<tcp_connect> to try the next one (or call your callback without any |
| 527 |
arguments if there are no more connections). In most cases, you can simply |
| 528 |
ignore this argument. |
| 529 |
|
| 530 |
$cb->($filehandle, $host, $port, $retry) |
| 531 |
|
| 532 |
If the connect is unsuccessful, then the C<$connect_cb> will be invoked |
| 533 |
without any arguments and C<$!> will be set appropriately (with C<ENXIO> |
| 534 |
indicating a DNS resolution failure). |
| 535 |
|
| 536 |
The file handle is perfect for being plugged into L<AnyEvent::Handle>, but |
| 537 |
can be used as a normal perl file handle as well. |
| 538 |
|
| 539 |
Unless called in void context, C<tcp_connect> returns a guard object that |
| 540 |
will automatically abort connecting when it gets destroyed (it does not do |
| 541 |
anything to the socket after the connect was successful). |
| 542 |
|
| 543 |
Sometimes you need to "prepare" the socket before connecting, for example, |
| 544 |
to C<bind> it to some port, or you want a specific connect timeout that |
| 545 |
is lower than your kernel's default timeout. In this case you can specify |
| 546 |
a second callback, C<$prepare_cb>. It will be called with the file handle |
| 547 |
in not-yet-connected state as only argument and must return the connection |
| 548 |
timeout value (or C<0>, C<undef> or the empty list to indicate the default |
| 549 |
timeout is to be used). |
| 550 |
|
| 551 |
Note that the socket could be either a IPv4 TCP socket or an IPv6 TCP |
| 552 |
socket (although only IPv4 is currently supported by this module). |
| 553 |
|
| 554 |
Note to the poor Microsoft Windows users: Windows (of course) doesn't |
| 555 |
correctly signal connection errors, so unless your event library works |
| 556 |
around this, failed connections will simply hang. The only event libraries |
| 557 |
that handle this condition correctly are L<EV> and L<Glib>. Additionally, |
| 558 |
AnyEvent works around this bug with L<Event> and in its pure-perl |
| 559 |
backend. All other libraries cannot correctly handle this condition. To |
| 560 |
lessen the impact of this windows bug, a default timeout of 30 seconds |
| 561 |
will be imposed on windows. Cygwin is not affected. |
| 562 |
|
| 563 |
Simple Example: connect to localhost on port 22. |
| 564 |
|
| 565 |
tcp_connect localhost => 22, sub { |
| 566 |
my $fh = shift |
| 567 |
or die "unable to connect: $!"; |
| 568 |
# do something |
| 569 |
}; |
| 570 |
|
| 571 |
Complex Example: connect to www.google.com on port 80 and make a simple |
| 572 |
GET request without much error handling. Also limit the connection timeout |
| 573 |
to 15 seconds. |
| 574 |
|
| 575 |
tcp_connect "www.google.com", "http", |
| 576 |
sub { |
| 577 |
my ($fh) = @_ |
| 578 |
or die "unable to connect: $!"; |
| 579 |
|
| 580 |
my $handle; # avoid direct assignment so on_eof has it in scope. |
| 581 |
$handle = new AnyEvent::Handle |
| 582 |
fh => $fh, |
| 583 |
on_eof => sub { |
| 584 |
undef $handle; # keep it alive till eof |
| 585 |
warn "done.\n"; |
| 586 |
}; |
| 587 |
|
| 588 |
$handle->push_write ("GET / HTTP/1.0\015\012\015\012"); |
| 589 |
|
| 590 |
$handle->push_read_line ("\015\012\015\012", sub { |
| 591 |
my ($handle, $line) = @_; |
| 592 |
|
| 593 |
# print response header |
| 594 |
print "HEADER\n$line\n\nBODY\n"; |
| 595 |
|
| 596 |
$handle->on_read (sub { |
| 597 |
# print response body |
| 598 |
print $_[0]->rbuf; |
| 599 |
$_[0]->rbuf = ""; |
| 600 |
}); |
| 601 |
}); |
| 602 |
}, sub { |
| 603 |
my ($fh) = @_; |
| 604 |
# could call $fh->bind etc. here |
| 605 |
|
| 606 |
15 |
| 607 |
}; |
| 608 |
|
| 609 |
Example: connect to a UNIX domain socket. |
| 610 |
|
| 611 |
tcp_connect "unix/", "/tmp/.X11-unix/X0", sub { |
| 612 |
... |
| 613 |
} |
| 614 |
|
| 615 |
=cut |
| 616 |
|
| 617 |
sub tcp_connect($$$;$) { |
| 618 |
my ($host, $port, $connect, $prepare) = @_; |
| 619 |
|
| 620 |
# see http://cr.yp.to/docs/connect.html for some background |
| 621 |
# also http://advogato.org/article/672.html |
| 622 |
|
| 623 |
my %state = ( fh => undef ); |
| 624 |
|
| 625 |
# name/service to type/sockaddr resolution |
| 626 |
resolve_sockaddr $host, $port, 0, 0, 0, sub { |
| 627 |
my @target = @_; |
| 628 |
|
| 629 |
$state{next} = sub { |
| 630 |
return unless exists $state{fh}; |
| 631 |
|
| 632 |
my $target = shift @target |
| 633 |
or do { |
| 634 |
%state = (); |
| 635 |
return $connect->(); |
| 636 |
}; |
| 637 |
|
| 638 |
my ($domain, $type, $proto, $sockaddr) = @$target; |
| 639 |
|
| 640 |
# socket creation |
| 641 |
socket $state{fh}, $domain, $type, $proto |
| 642 |
or return $state{next}(); |
| 643 |
|
| 644 |
fh_nonblocking $state{fh}, 1; |
| 645 |
|
| 646 |
my $timeout = $prepare && $prepare->($state{fh}); |
| 647 |
|
| 648 |
$timeout ||= 30 if AnyEvent::WIN32; |
| 649 |
|
| 650 |
$state{to} = AnyEvent->timer (after => $timeout, cb => sub { |
| 651 |
$! = &Errno::ETIMEDOUT; |
| 652 |
$state{next}(); |
| 653 |
}) if $timeout; |
| 654 |
|
| 655 |
# called when the connect was successful, which, |
| 656 |
# in theory, could be the case immediately (but never is in practise) |
| 657 |
my $connected = sub { |
| 658 |
delete $state{ww}; |
| 659 |
delete $state{to}; |
| 660 |
|
| 661 |
# we are connected, or maybe there was an error |
| 662 |
if (my $sin = getpeername $state{fh}) { |
| 663 |
my ($port, $host) = unpack_sockaddr $sin; |
| 664 |
|
| 665 |
my $guard = guard { |
| 666 |
%state = (); |
| 667 |
}; |
| 668 |
|
| 669 |
$connect->($state{fh}, format_address $host, $port, sub { |
| 670 |
$guard->cancel; |
| 671 |
$state{next}(); |
| 672 |
}); |
| 673 |
} else { |
| 674 |
# dummy read to fetch real error code |
| 675 |
sysread $state{fh}, my $buf, 1 if $! == &Errno::ENOTCONN; |
| 676 |
$state{next}(); |
| 677 |
} |
| 678 |
}; |
| 679 |
|
| 680 |
# now connect |
| 681 |
if (connect $state{fh}, $sockaddr) { |
| 682 |
$connected->(); |
| 683 |
} elsif ($! == &Errno::EINPROGRESS # POSIX |
| 684 |
|| $! == &Errno::EWOULDBLOCK |
| 685 |
# WSAEINPROGRESS intentionally not checked - it means something else entirely |
| 686 |
|| $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt |
| 687 |
|| $! == AnyEvent::Util::WSAEWOULDBLOCK) { |
| 688 |
$state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $connected); |
| 689 |
} else { |
| 690 |
$state{next}(); |
| 691 |
} |
| 692 |
}; |
| 693 |
|
| 694 |
$! = &Errno::ENXIO; |
| 695 |
$state{next}(); |
| 696 |
}; |
| 697 |
|
| 698 |
defined wantarray && guard { %state = () } |
| 699 |
} |
| 700 |
|
| 701 |
=item $guard = tcp_server $host, $service, $accept_cb[, $prepare_cb] |
| 702 |
|
| 703 |
Create and bind a stream socket to the given host, and port, set the |
| 704 |
SO_REUSEADDR flag (if applicable) and call C<listen>. Unlike the name |
| 705 |
implies, this function can also bind on UNIX domain sockets. |
| 706 |
|
| 707 |
For internet sockets, C<$host> must be an IPv4 or IPv6 address (or |
| 708 |
C<undef>, in which case it binds either to C<0> or to C<::>, depending |
| 709 |
on whether IPv4 or IPv6 is the preferred protocol, and maybe to both in |
| 710 |
future versions, as applicable). |
| 711 |
|
| 712 |
To bind to the IPv4 wildcard address, use C<0>, to bind to the IPv6 |
| 713 |
wildcard address, use C<::>. |
| 714 |
|
| 715 |
The port is specified by C<$service>, which must be either a service name or |
| 716 |
a numeric port number (or C<0> or C<undef>, in which case an ephemeral |
| 717 |
port will be used). |
| 718 |
|
| 719 |
For UNIX domain sockets, C<$host> must be C<unix/> and C<$service> must be |
| 720 |
the absolute pathname of the socket. This function will try to C<unlink> |
| 721 |
the socket before it tries to bind to it. See SECURITY CONSIDERATIONS, |
| 722 |
below. |
| 723 |
|
| 724 |
For each new connection that could be C<accept>ed, call the C<< |
| 725 |
$accept_cb->($fh, $host, $port) >> with the file handle (in non-blocking |
| 726 |
mode) as first and the peer host and port as second and third arguments |
| 727 |
(see C<tcp_connect> for details). |
| 728 |
|
| 729 |
Croaks on any errors it can detect before the listen. |
| 730 |
|
| 731 |
If called in non-void context, then this function returns a guard object |
| 732 |
whose lifetime it tied to the TCP server: If the object gets destroyed, |
| 733 |
the server will be stopped (but existing accepted connections will |
| 734 |
continue). |
| 735 |
|
| 736 |
If you need more control over the listening socket, you can provide a |
| 737 |
C<< $prepare_cb->($fh, $host, $port) >>, which is called just before the |
| 738 |
C<listen ()> call, with the listen file handle as first argument, and IP |
| 739 |
address and port number of the local socket endpoint as second and third |
| 740 |
arguments. |
| 741 |
|
| 742 |
It should return the length of the listen queue (or C<0> for the default). |
| 743 |
|
| 744 |
Note to IPv6 users: RFC-compliant behaviour for IPv6 sockets listening on |
| 745 |
C<::> is to bind to both IPv6 and IPv4 addresses by default on dual-stack |
| 746 |
hosts. Unfortunately, only GNU/Linux seems to implement this properly, so |
| 747 |
if you want both IPv4 and IPv6 listening sockets you should create the |
| 748 |
IPv6 socket first and then attempt to bind on the IPv4 socket, but ignore |
| 749 |
any C<EADDRINUSE> errors. |
| 750 |
|
| 751 |
Example: bind on some TCP port on the local machine and tell each client |
| 752 |
to go away. |
| 753 |
|
| 754 |
tcp_server undef, undef, sub { |
| 755 |
my ($fh, $host, $port) = @_; |
| 756 |
|
| 757 |
syswrite $fh, "The internet is full, $host:$port. Go away!\015\012"; |
| 758 |
}, sub { |
| 759 |
my ($fh, $thishost, $thisport) = @_; |
| 760 |
warn "bound to $thishost, port $thisport\n"; |
| 761 |
}; |
| 762 |
|
| 763 |
=cut |
| 764 |
|
| 765 |
sub tcp_server($$$;$) { |
| 766 |
my ($host, $service, $accept, $prepare) = @_; |
| 767 |
|
| 768 |
$host = $AnyEvent::PROTOCOL{ipv4} < $AnyEvent::PROTOCOL{ipv6} && AF_INET6 |
| 769 |
? "::" : "0" |
| 770 |
unless defined $host; |
| 771 |
|
| 772 |
my $ipn = parse_address $host |
| 773 |
or Carp::croak "AnyEvent::Socket::tcp_server: cannot parse '$host' as host address"; |
| 774 |
|
| 775 |
my $af = address_family $ipn; |
| 776 |
|
| 777 |
my %state; |
| 778 |
|
| 779 |
# win32 perl is too stupid to get this right :/ |
| 780 |
Carp::croak "tcp_server/socket: address family not supported" |
| 781 |
if AnyEvent::WIN32 && $af == AF_UNIX; |
| 782 |
|
| 783 |
socket $state{fh}, $af, SOCK_STREAM, 0 |
| 784 |
or Carp::croak "tcp_server/socket: $!"; |
| 785 |
|
| 786 |
if ($af == AF_INET || $af == AF_INET6) { |
| 787 |
setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1 |
| 788 |
or Carp::croak "tcp_server/so_reuseaddr: $!" |
| 789 |
unless AnyEvent::WIN32; # work around windows bug |
| 790 |
|
| 791 |
unless ($service =~ /^\d*$/) { |
| 792 |
$service = (getservbyname $service, "tcp")[2] |
| 793 |
or Carp::croak "$service: service unknown" |
| 794 |
} |
| 795 |
} elsif ($af == AF_UNIX) { |
| 796 |
unlink $service; |
| 797 |
} |
| 798 |
|
| 799 |
bind $state{fh}, pack_sockaddr $service, $ipn |
| 800 |
or Carp::croak "bind: $!"; |
| 801 |
|
| 802 |
fh_nonblocking $state{fh}, 1; |
| 803 |
|
| 804 |
my $len; |
| 805 |
|
| 806 |
if ($prepare) { |
| 807 |
my ($service, $host) = unpack_sockaddr getsockname $state{fh}; |
| 808 |
$len = $prepare && $prepare->($state{fh}, format_address $host, $service); |
| 809 |
} |
| 810 |
|
| 811 |
$len ||= 128; |
| 812 |
|
| 813 |
listen $state{fh}, $len |
| 814 |
or Carp::croak "listen: $!"; |
| 815 |
|
| 816 |
$state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub { |
| 817 |
# this closure keeps $state alive |
| 818 |
while (my $peer = accept my $fh, $state{fh}) { |
| 819 |
fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not |
| 820 |
|
| 821 |
my ($service, $host) = unpack_sockaddr $peer; |
| 822 |
$accept->($fh, format_address $host, $service); |
| 823 |
} |
| 824 |
}); |
| 825 |
|
| 826 |
defined wantarray |
| 827 |
? guard { %state = () } # clear fh and watcher, which breaks the circular dependency |
| 828 |
: () |
| 829 |
} |
| 830 |
|
| 831 |
1; |
| 832 |
|
| 833 |
=back |
| 834 |
|
| 835 |
=head1 SECURITY CONSIDERATIONS |
| 836 |
|
| 837 |
This module is quite powerful, with with power comes the ability to abuse |
| 838 |
as well: If you accept "hostnames" and ports from untrusted sources, |
| 839 |
then note that this can be abused to delete files (host=C<unix/>). This |
| 840 |
is not really a problem with this module, however, as blindly accepting |
| 841 |
any address and protocol and trying to bind a server or connect to it is |
| 842 |
harmful in general. |
| 843 |
|
| 844 |
=head1 AUTHOR |
| 845 |
|
| 846 |
Marc Lehmann <schmorp@schmorp.de> |
| 847 |
http://home.schmorp.de/ |
| 848 |
|
| 849 |
=cut |
| 850 |
|
