ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/AnyEvent/lib/AnyEvent/Socket.pm
(Generate patch)

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.34 by root, Wed May 28 21:07:07 2008 UTC vs.
Revision 1.65 by root, Wed Oct 29 14:32:02 2008 UTC

… …
2 2
3AnyEvent::Socket - useful IPv4 and IPv6 stuff. 3AnyEvent::Socket - useful IPv4 and IPv6 stuff.
4 4
5=head1 SYNOPSIS 5=head1 SYNOPSIS
6 6
7 use AnyEvent::Socket; 7 use AnyEvent::Socket;
8 8
9 tcp_connect "gameserver.deliantra.net", 13327, sub { 9 tcp_connect "gameserver.deliantra.net", 13327, sub {
10 my ($fh) = @_ 10 my ($fh) = @_
11 or die "gameserver.deliantra.net connect failed: $!"; 11 or die "gameserver.deliantra.net connect failed: $!";
12 12
13 # enjoy your filehandle 13 # enjoy your filehandle
14 }; 14 };
15 15
16 # a simple tcp server 16 # a simple tcp server
17 tcp_server undef, 8888, sub { 17 tcp_server undef, 8888, sub {
18 my ($fh, $host, $port) = @_; 18 my ($fh, $host, $port) = @_;
19 19
20 syswrite $fh, "The internet is full, $host:$port. Go away!\015\012"; 20 syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";
21 }; 21 };
22 22
23=head1 DESCRIPTION 23=head1 DESCRIPTION
24 24
25This module implements various utility functions for handling internet 25This module implements various utility functions for handling internet
26protocol addresses and sockets, in an as transparent and simple way as 26protocol addresses and sockets, in an as transparent and simple way as
… …
47use AnyEvent::DNS (); 47use AnyEvent::DNS ();
48 48
49use base 'Exporter'; 49use base 'Exporter';
50 50
51our @EXPORT = qw( 51our @EXPORT = qw(
52 parse_hostport
52 parse_ipv4 parse_ipv6 53 parse_ipv4 parse_ipv6
53 parse_ip parse_address 54 parse_ip parse_address
54 format_ip format_address 55 format_ip format_address
55 address_family 56 address_family
56 inet_aton 57 inet_aton
57 tcp_server 58 tcp_server
58 tcp_connect 59 tcp_connect
59); 60);
60 61
61our $VERSION = '1.0'; 62our $VERSION = 4.3;
62 63
63=item $ipn = parse_ipv4 $dotted_quad 64=item $ipn = parse_ipv4 $dotted_quad
64 65
65Tries to parse the given dotted quad IPv4 address and return it in 66Tries to parse the given dotted quad IPv4 address and return it in
66octet form (or undef when it isn't in a parsable format). Supports all 67octet form (or undef when it isn't in a parsable format). Supports all
… …
78 79
79 # check leading parts against range 80 # check leading parts against range
80 return undef if grep $_ >= 256, @_[0 .. @_ - 2]; 81 return undef if grep $_ >= 256, @_[0 .. @_ - 2];
81 82
82 # check trailing part against range 83 # check trailing part against range
83 return undef if $_[-1] >= 1 << (8 * (4 - $#_)); 84 return undef if $_[-1] >= 2 ** (8 * (4 - $#_));
84 85
85 pack "N", (pop) 86 pack "N", (pop)
86 + ($_[0] << 24) 87 + ($_[0] << 24)
87 + ($_[1] << 16) 88 + ($_[1] << 16)
88 + ($_[2] << 8); 89 + ($_[2] << 8);
… …
153 154
154If the C<$text> is C<unix/>, then this function returns a special token 155If the C<$text> is C<unix/>, then this function returns a special token
155recognised by the other functions in this module to mean "UNIX domain 156recognised by the other functions in this module to mean "UNIX domain
156socket". 157socket".
157 158
159=item $text = AnyEvent::Socket::aton $ipn
160
161Same as C<parse_address>, but not exported (think C<Socket::inet_aton> but
162I<without> name resolution).
163
158=cut 164=cut
159 165
160sub parse_address($) { 166sub parse_address($) {
161 &parse_ipv4 || &parse_ipv6 || &parse_unix 167 &parse_ipv4 || &parse_ipv6 || &parse_unix
162} 168}
163 169
164*parse_ip =\&parse_address; #d# 170*aton = \&parse_address;
171
172=item ($host, $service) = parse_hostport $string[, $default_service]
173
174Splitting a string of the form C<hostname:port> is a common
175problem. Unfortunately, just splitting on the colon makes it hard to
176specify IPv6 addresses and doesn't support the less common but well
177standardised C<[ip literal]> syntax.
178
179This function tries to do this job in a better way, it supports the
180following formats, where C<port> can be a numerical port number of a
181service name, or a C<name=port> string, and the C< port> and C<:port>
182parts are optional. Also, everywhere where an IP address is supported
183a hostname or unix domain socket address is also supported (see
184C<parse_unix>).
185
186 hostname:port e.g. "www.linux.org", "www.x.de:443", "www.x.de:https=443"
187 ipv4:port e.g. "198.182.196.56", "127.1:22"
188 ipv6 e.g. "::1", "affe::1"
189 [ipv4or6]:port e.g. "[::1]", "[10.0.1]:80"
190 [ipv4or6] port e.g. "[127.0.0.1]", "[www.x.org] 17"
191 ipv4or6 port e.g. "::1 443", "10.0.0.1 smtp"
192
193It also supports defaulting the service name in a simple way by using
194C<$default_service> if no service was detected. If neither a service was
195detected nor a default was specified, then this function returns the
196empty list. The same happens when a parse error weas detected, such as a
197hostname with a colon in it (the function is rather conservative, though).
198
199Example:
200
201 print join ",", parse_hostport "localhost:443";
202 # => "localhost,443"
203
204 print join ",", parse_hostport "localhost", "https";
205 # => "localhost,https"
206
207 print join ",", parse_hostport "[::1]";
208 # => "," (empty list)
209
210=cut
211
212sub parse_hostport($;$) {
213 my ($host, $port);
214
215 for ("$_[0]") { # work on a copy, just in case, and also reset pos
216
217 # parse host, special cases: "ipv6" or "ipv6 port"
218 unless (
219 ($host) = /^\s* ([0-9a-fA-F:]*:[0-9a-fA-F:]*:[0-9a-fA-F\.:]*)/xgc
220 and parse_ipv6 $host
221 ) {
222 /^\s*/xgc;
223
224 if (/^ \[ ([^\[\]]+) \]/xgc) {
225 $host = $1;
226 } elsif (/^ ([^\[\]:\ ]+) /xgc) {
227 $host = $1;
228 } else {
229 return;
230 }
231 }
232
233 # parse port
234 if (/\G (?:\s+|:) ([^:[:space:]]+) \s*$/xgc) {
235 $port = $1;
236 } elsif (/\G\s*$/gc && length $_[1]) {
237 $port = $_[1];
238 } else {
239 return;
240 }
241 }
242
243 # hostnames must not contain :'s
244 return if $host =~ /:/ && !parse_ipv6 $host;
245
246 ($host, $port)
247}
165 248
166=item $sa_family = address_family $ipn 249=item $sa_family = address_family $ipn
167 250
168Returns the address family/protocol-family (AF_xxx/PF_xxx, in one value :) 251Returns the address family/protocol-family (AF_xxx/PF_xxx, in one value :)
169of the given host address in network format. 252of the given host address in network format.
… …
188This function works similarly to C<inet_ntop AF_INET || AF_INET6, ...>, 271This function works similarly to C<inet_ntop AF_INET || AF_INET6, ...>,
189except it automatically detects the address type. 272except it automatically detects the address type.
190 273
191Returns C<undef> if it cannot detect the type. 274Returns C<undef> if it cannot detect the type.
192 275
276=item $text = AnyEvent::Socket::ntoa $ipn
277
278Same as format_address, but not exported (think C<inet_ntoa>).
279
193=cut 280=cut
194 281
195sub format_address; 282sub format_address;
196sub format_address($) { 283sub format_address($) {
197 my $af = address_family $_[0]; 284 my $af = address_family $_[0];
198 if ($af == AF_INET) { 285 if ($af == AF_INET) {
199 return join ".", unpack "C4", $_[0] 286 return join ".", unpack "C4", $_[0]
200 } elsif ($af == AF_INET6) { 287 } elsif ($af == AF_INET6) {
288 if (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0 eq $_[0]) {
289 return "::";
290 } elsif (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1 eq $_[0]) {
291 return "::1";
201 if (v0.0.0.0.0.0.0.0.0.0.0.0 eq substr $_[0], 0, 12) { 292 } elsif (v0.0.0.0.0.0.0.0.0.0.0.0 eq substr $_[0], 0, 12) {
202 # v4compatible 293 # v4compatible
203 return "::" . format_address substr $_[0], 12; 294 return "::" . format_address substr $_[0], 12;
204 } elsif (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) { 295 } elsif (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) {
205 # v4mapped 296 # v4mapped
206 return "::ffff:" . format_address substr $_[0], 12; 297 return "::ffff:" . format_address substr $_[0], 12;
… …
208 # v4translated 299 # v4translated
209 return "::ffff:0:" . format_address substr $_[0], 12; 300 return "::ffff:0:" . format_address substr $_[0], 12;
210 } else { 301 } else {
211 my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0]; 302 my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];
212 303
304 # this is rather sucky, I admit
213 $ip =~ s/^0:(?:0:)*(0$)?/::/ 305 $ip =~ s/^0:(?:0:)*(0$)?/::/
214 or $ip =~ s/(:0)+$/::/ 306 or $ip =~ s/(:0){7}$/::/ or $ip =~ s/(:0){7}/:/
215 or $ip =~ s/(:0)+/:/; 307 or $ip =~ s/(:0){6}$/::/ or $ip =~ s/(:0){6}/:/
308 or $ip =~ s/(:0){5}$/::/ or $ip =~ s/(:0){5}/:/
309 or $ip =~ s/(:0){4}$/::/ or $ip =~ s/(:0){4}/:/
310 or $ip =~ s/(:0){3}$/::/ or $ip =~ s/(:0){3}/:/
311 or $ip =~ s/(:0){2}$/::/ or $ip =~ s/(:0){2}/:/
312 or $ip =~ s/(:0){1}$/::/ or $ip =~ s/(:0){1}/:/;
216 return $ip 313 return $ip
217 } 314 }
218 } elsif ($af == AF_UNIX) { 315 } elsif ($af == AF_UNIX) {
219 return "unix/" 316 return "unix/"
220 } else { 317 } else {
221 return undef 318 return undef
222 } 319 }
223} 320}
224 321
225*format_ip = \&format_address; 322*ntoa = \&format_address;
226 323
227=item inet_aton $name_or_address, $cb->(@addresses) 324=item inet_aton $name_or_address, $cb->(@addresses)
228 325
229Works similarly to its Socket counterpart, except that it uses a 326Works similarly to its Socket counterpart, except that it uses a
230callback. Also, if a host has only an IPv6 address, this might be passed 327callback. Also, if a host has only an IPv6 address, this might be passed
… …
262 359
263# check for broken platforms with extra field in sockaddr structure 360# check for broken platforms with extra field in sockaddr structure
264# kind of a rfc vs. bsd issue, as usual (ok, normally it's a 361# kind of a rfc vs. bsd issue, as usual (ok, normally it's a
265# unix vs. bsd issue, a iso C vs. bsd issue or simply a 362# unix vs. bsd issue, a iso C vs. bsd issue or simply a
266# correctness vs. bsd issue. 363# correctness vs. bsd issue.
267my $pack_family = 0x55 == Socket::sockaddr_family "\x55\x55" 364my $pack_family = (0x55 == Socket::sockaddr_family "\x55\x55")
268 ? "xC" : "S"; 365 ? "xC" : "S";
269 366
270=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host 367=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host
271 368
272Pack the given port/host combination into a binary sockaddr 369Pack the given port/host combination into a binary sockaddr
… …
315 if ($af == AF_INET) { 412 if ($af == AF_INET) {
316 Socket::unpack_sockaddr_in $_[0] 413 Socket::unpack_sockaddr_in $_[0]
317 } elsif ($af == AF_INET6) { 414 } elsif ($af == AF_INET6) {
318 unpack "x2 n x4 a16", $_[0] 415 unpack "x2 n x4 a16", $_[0]
319 } elsif ($af == AF_UNIX) { 416 } elsif ($af == AF_UNIX) {
320 ((Socket::unpack_sockaddr_un $_[0]), "unix/") 417 ((Socket::unpack_sockaddr_un $_[0]), pack "S", AF_UNIX)
321 } else { 418 } else {
322 Carp::croak "unpack_sockaddr: unsupported protocol family $af"; 419 Carp::croak "unpack_sockaddr: unsupported protocol family $af";
323 } 420 }
324}
325
326sub _tcp_port($) {
327 $_[0] =~ /^(\d*)$/ and return $1*1;
328
329 (getservbyname $_[0], "tcp")[2]
330 or Carp::croak "$_[0]: service unknown"
331} 421}
332 422
333=item resolve_sockaddr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...) 423=item resolve_sockaddr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...)
334 424
335Tries to resolve the given nodename and service name into protocol families 425Tries to resolve the given nodename and service name into protocol families
… …
371 461
372 resolve_sockaddr "google.com", "http", 0, undef, undef, sub { ... }; 462 resolve_sockaddr "google.com", "http", 0, undef, undef, sub { ... };
373 463
374=cut 464=cut
375 465
466# microsoft can't even get getprotobyname working (the etc/protocols file
467# gets lost fairly often on windows), so we have to hardcode some common
468# protocol numbers ourselves.
469our %PROTO_BYNAME;
470
471$PROTO_BYNAME{tcp} = &Socket::IPPROTO_TCP if defined &Socket::IPPROTO_TCP;
472$PROTO_BYNAME{udp} = &Socket::IPPROTO_UDP if defined &Socket::IPPROTO_UDP;
473$PROTO_BYNAME{icmp} = &Socket::IPPROTO_ICMP if defined &Socket::IPPROTO_ICMP;
474
376sub resolve_sockaddr($$$$$$) { 475sub resolve_sockaddr($$$$$$) {
377 my ($node, $service, $proto, $family, $type, $cb) = @_; 476 my ($node, $service, $proto, $family, $type, $cb) = @_;
378 477
379 if ($node eq "unix/") { 478 if ($node eq "unix/") {
380 return $cb->() if $family || !/^\//; # no can do 479 return $cb->() if $family || !/^\//; # no can do
… …
396 $family ||= 6 unless $AnyEvent::PROTOCOL{ipv4}; 495 $family ||= 6 unless $AnyEvent::PROTOCOL{ipv4};
397 496
398 $proto ||= "tcp"; 497 $proto ||= "tcp";
399 $type ||= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM; 498 $type ||= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;
400 499
401 my $proton = (getprotobyname $proto)[2] 500 my $proton = $PROTO_BYNAME{lc $proto} || (getprotobyname $proto)[2]
402 or Carp::croak "$proto: protocol unknown"; 501 or Carp::croak "$proto: protocol unknown";
403 502
404 my $port; 503 my $port;
405 504
406 if ($service =~ /^(\S+)=(\d+)$/) { 505 if ($service =~ /^(\S+)=(\d+)$/) {
407 ($service, $port) = ($1, $2); 506 ($service, $port) = ($1, $2);
408 } elsif ($service =~ /^\d+$/) { 507 } elsif ($service =~ /^\d+$/) {
409 ($service, $port) = (undef, $service); 508 ($service, $port) = (undef, $service);
410 } else { 509 } else {
411 $port = (getservbyname $service, $proto)[2] 510 $port = (getservbyname $service, $proto)[2]
412 or Carp::croak "$service/$proto: service unknown"; 511 or Carp::croak "$service/$proto: service unknown";
413 } 512 }
414 513
415 my @target = [$node, $port]; 514 my @target = [$node, $port];
416 515
417 # resolve a records / provide sockaddr structures 516 # resolve a records / provide sockaddr structures
… …
431 $cv->begin; 530 $cv->begin;
432 for my $idx (0 .. $#target) { 531 for my $idx (0 .. $#target) {
433 my ($node, $port) = @{ $target[$idx] }; 532 my ($node, $port) = @{ $target[$idx] };
434 533
435 if (my $noden = parse_address $node) { 534 if (my $noden = parse_address $node) {
535 my $af = address_family $noden;
536
436 if (4 == length $noden && $family != 6) { 537 if ($af == AF_INET && $family != 6) {
437 push @res, [$idx, "ipv4", [AF_INET, $type, $proton, 538 push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
438 pack_sockaddr $port, $noden]] 539 pack_sockaddr $port, $noden]]
439 } 540 }
440 541
441 if (16 == length $noden && $family != 4) { 542 if ($af == AF_INET6 && $family != 4) {
442 push @res, [$idx, "ipv6", [AF_INET6, $type, $proton, 543 push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,
443 pack_sockaddr $port, $noden]] 544 pack_sockaddr $port, $noden]]
444 } 545 }
445 } else { 546 } else {
446 # ipv4 547 # ipv4
447 if ($family != 6) { 548 if ($family != 6) {
448 $cv->begin; 549 $cv->begin;
449 a $node, sub { 550 AnyEvent::DNS::a $node, sub {
450 push @res, [$idx, "ipv4", [AF_INET, $type, $proton, 551 push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
451 pack_sockaddr $port, parse_ipv4 $_]] 552 pack_sockaddr $port, parse_ipv4 $_]]
452 for @_; 553 for @_;
453 $cv->end; 554 $cv->end;
454 }; 555 };
455 } 556 }
456 557
457 # ipv6 558 # ipv6
458 if ($family != 4) { 559 if ($family != 4) {
459 $cv->begin; 560 $cv->begin;
460 aaaa $node, sub { 561 AnyEvent::DNS::aaaa $node, sub {
461 push @res, [$idx, "ipv6", [AF_INET6, $type, $proton, 562 push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,
462 pack_sockaddr $port, parse_ipv6 $_]] 563 pack_sockaddr $port, parse_ipv6 $_]]
463 for @_; 564 for @_;
464 $cv->end; 565 $cv->end;
465 }; 566 };
… …
472 # try srv records, if applicable 573 # try srv records, if applicable
473 if ($node eq "localhost") { 574 if ($node eq "localhost") {
474 @target = (["127.0.0.1", $port], ["::1", $port]); 575 @target = (["127.0.0.1", $port], ["::1", $port]);
475 &$resolve; 576 &$resolve;
476 } elsif (defined $service && !parse_address $node) { 577 } elsif (defined $service && !parse_address $node) {
477 srv $service, $proto, $node, sub { 578 AnyEvent::DNS::srv $service, $proto, $node, sub {
478 my (@srv) = @_; 579 my (@srv) = @_;
479 580
480 # no srv records, continue traditionally 581 # no srv records, continue traditionally
481 @srv 582 @srv
482 or return &$resolve; 583 or return &$resolve;
483 584
484 # only srv record has "." => abort 585 # the only srv record has "." ("" here) => abort
485 $srv[0][2] ne "." || $#srv 586 $srv[0][2] ne "" || $#srv
486 or return $cb->(); 587 or return $cb->();
487 588
488 # use srv records then 589 # use srv records then
489 @target = map ["$_->[3].", $_->[2]], 590 @target = map ["$_->[3].", $_->[2]],
490 grep $_->[3] ne ".", 591 grep $_->[3] ne ".",
… …
555lessen the impact of this windows bug, a default timeout of 30 seconds 656lessen the impact of this windows bug, a default timeout of 30 seconds
556will be imposed on windows. Cygwin is not affected. 657will be imposed on windows. Cygwin is not affected.
557 658
558Simple Example: connect to localhost on port 22. 659Simple Example: connect to localhost on port 22.
559 660
560 tcp_connect localhost => 22, sub { 661 tcp_connect localhost => 22, sub {
561 my $fh = shift 662 my $fh = shift
562 or die "unable to connect: $!"; 663 or die "unable to connect: $!";
563 # do something 664 # do something
564 }; 665 };
565 666
566Complex Example: connect to www.google.com on port 80 and make a simple 667Complex Example: connect to www.google.com on port 80 and make a simple
567GET request without much error handling. Also limit the connection timeout 668GET request without much error handling. Also limit the connection timeout
568to 15 seconds. 669to 15 seconds.
569 670
… …
647 $state{next}(); 748 $state{next}();
648 }) if $timeout; 749 }) if $timeout;
649 750
650 # called when the connect was successful, which, 751 # called when the connect was successful, which,
651 # in theory, could be the case immediately (but never is in practise) 752 # in theory, could be the case immediately (but never is in practise)
652 my $connected = sub { 753 $state{connected} = sub {
653 delete $state{ww}; 754 delete $state{ww};
654 delete $state{to}; 755 delete $state{to};
655 756
656 # we are connected, or maybe there was an error 757 # we are connected, or maybe there was an error
657 if (my $sin = getpeername $state{fh}) { 758 if (my $sin = getpeername $state{fh}) {
658 my ($port, $host) = unpack_sockaddr $sin; 759 my ($port, $host) = unpack_sockaddr $sin;
659 760
660 my $guard = guard { 761 my $guard = guard { %state = () };
661 %state = ();
662 };
663 762
664 $connect->($state{fh}, format_address $host, $port, sub { 763 $connect->(delete $state{fh}, format_address $host, $port, sub {
665 $guard->cancel; 764 $guard->cancel;
666 $state{next}(); 765 $state{next}();
667 }); 766 });
668 } else { 767 } else {
669 # dummy read to fetch real error code 768 # dummy read to fetch real error code
… …
672 } 771 }
673 }; 772 };
674 773
675 # now connect 774 # now connect
676 if (connect $state{fh}, $sockaddr) { 775 if (connect $state{fh}, $sockaddr) {
677 $connected->(); 776 $state{connected}->();
678 } elsif ($! == &Errno::EINPROGRESS # POSIX 777 } elsif ($! == &Errno::EINPROGRESS # POSIX
679 || $! == &Errno::EWOULDBLOCK 778 || $! == &Errno::EWOULDBLOCK
680 # WSAEINPROGRESS intentionally not checked - it means something else entirely 779 # WSAEINPROGRESS intentionally not checked - it means something else entirely
681 || $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt 780 || $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt
682 || $! == AnyEvent::Util::WSAEWOULDBLOCK) { 781 || $! == AnyEvent::Util::WSAEWOULDBLOCK) {
683 $state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $connected); 782 $state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $state{connected});
684 } else { 783 } else {
685 $state{next}(); 784 $state{next}();
686 } 785 }
687 }; 786 };
688 787
… …
691 }; 790 };
692 791
693 defined wantarray && guard { %state = () } 792 defined wantarray && guard { %state = () }
694} 793}
695 794
696=item $guard = tcp_server $host, $port, $accept_cb[, $prepare_cb] 795=item $guard = tcp_server $host, $service, $accept_cb[, $prepare_cb]
697 796
698Create and bind a TCP socket to the given host, and port, set the 797Create and bind a stream socket to the given host, and port, set the
699SO_REUSEADDR flag and call C<listen>. 798SO_REUSEADDR flag (if applicable) and call C<listen>. Unlike the name
799implies, this function can also bind on UNIX domain sockets.
700 800
701C<$host> must be an IPv4 or IPv6 address (or C<undef>, in which case it 801For internet sockets, C<$host> must be an IPv4 or IPv6 address (or
702binds either to C<0> or to C<::>, depending on whether IPv4 or IPv6 is the 802C<undef>, in which case it binds either to C<0> or to C<::>, depending
703preferred protocol). 803on whether IPv4 or IPv6 is the preferred protocol, and maybe to both in
804future versions, as applicable).
704 805
705To bind to the IPv4 wildcard address, use C<0>, to bind to the IPv6 806To bind to the IPv4 wildcard address, use C<0>, to bind to the IPv6
706wildcard address, use C<::>. 807wildcard address, use C<::>.
707 808
708The port is specified by C<$port>, which must be either a service name or 809The port is specified by C<$service>, which must be either a service name or
709a numeric port number (or C<0> or C<undef>, in which case an ephemeral 810a numeric port number (or C<0> or C<undef>, in which case an ephemeral
710port will be used). 811port will be used).
812
813For UNIX domain sockets, C<$host> must be C<unix/> and C<$service> must be
814the absolute pathname of the socket. This function will try to C<unlink>
815the socket before it tries to bind to it. See SECURITY CONSIDERATIONS,
816below.
711 817
712For each new connection that could be C<accept>ed, call the C<< 818For each new connection that could be C<accept>ed, call the C<<
713$accept_cb->($fh, $host, $port) >> with the file handle (in non-blocking 819$accept_cb->($fh, $host, $port) >> with the file handle (in non-blocking
714mode) as first and the peer host and port as second and third arguments 820mode) as first and the peer host and port as second and third arguments
715(see C<tcp_connect> for details). 821(see C<tcp_connect> for details).
… …
727address and port number of the local socket endpoint as second and third 833address and port number of the local socket endpoint as second and third
728arguments. 834arguments.
729 835
730It should return the length of the listen queue (or C<0> for the default). 836It should return the length of the listen queue (or C<0> for the default).
731 837
838Note to IPv6 users: RFC-compliant behaviour for IPv6 sockets listening on
839C<::> is to bind to both IPv6 and IPv4 addresses by default on dual-stack
840hosts. Unfortunately, only GNU/Linux seems to implement this properly, so
841if you want both IPv4 and IPv6 listening sockets you should create the
842IPv6 socket first and then attempt to bind on the IPv4 socket, but ignore
843any C<EADDRINUSE> errors.
844
732Example: bind on some TCP port on the local machine and tell each client 845Example: bind on some TCP port on the local machine and tell each client
733to go away. 846to go away.
734 847
735 tcp_server undef, undef, sub { 848 tcp_server undef, undef, sub {
736 my ($fh, $host, $port) = @_; 849 my ($fh, $host, $port) = @_;
… …
742 }; 855 };
743 856
744=cut 857=cut
745 858
746sub tcp_server($$$;$) { 859sub tcp_server($$$;$) {
747 my ($host, $port, $accept, $prepare) = @_; 860 my ($host, $service, $accept, $prepare) = @_;
748 861
749 $host = $AnyEvent::PROTOCOL{ipv4} < $AnyEvent::PROTOCOL{ipv6} && AF_INET6 862 $host = $AnyEvent::PROTOCOL{ipv4} < $AnyEvent::PROTOCOL{ipv6} && AF_INET6
750 ? "::" : "0" 863 ? "::" : "0"
751 unless defined $host; 864 unless defined $host;
752 865
753 my $ipn = parse_address $host 866 my $ipn = parse_address $host
754 or Carp::croak "AnyEvent::Socket::tcp_server: cannot parse '$host' as host address"; 867 or Carp::croak "AnyEvent::Socket::tcp_server: cannot parse '$host' as host address";
755 868
756 my $domain = 4 == length $ipn ? AF_INET : AF_INET6; 869 my $af = address_family $ipn;
757 870
758 my %state; 871 my %state;
759 872
873 # win32 perl is too stupid to get this right :/
874 Carp::croak "tcp_server/socket: address family not supported"
875 if AnyEvent::WIN32 && $af == AF_UNIX;
876
760 socket $state{fh}, $domain, SOCK_STREAM, 0 877 socket $state{fh}, $af, SOCK_STREAM, 0
761 or Carp::croak "socket: $!"; 878 or Carp::croak "tcp_server/socket: $!";
762 879
880 if ($af == AF_INET || $af == AF_INET6) {
763 setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1 881 setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1
764 or Carp::croak "so_reuseaddr: $!"; 882 or Carp::croak "tcp_server/so_reuseaddr: $!"
883 unless AnyEvent::WIN32; # work around windows bug
765 884
885 unless ($service =~ /^\d*$/) {
886 $service = (getservbyname $service, "tcp")[2]
887 or Carp::croak "$service: service unknown"
888 }
889 } elsif ($af == AF_UNIX) {
890 unlink $service;
891 }
892
766 bind $state{fh}, pack_sockaddr _tcp_port $port, $ipn 893 bind $state{fh}, pack_sockaddr $service, $ipn
767 or Carp::croak "bind: $!"; 894 or Carp::croak "bind: $!";
768 895
769 fh_nonblocking $state{fh}, 1; 896 fh_nonblocking $state{fh}, 1;
770 897
771 my $len; 898 my $len;
772 899
773 if ($prepare) { 900 if ($prepare) {
774 my ($port, $host) = unpack_sockaddr getsockname $state{fh}; 901 my ($service, $host) = unpack_sockaddr getsockname $state{fh};
775 $len = $prepare && $prepare->($state{fh}, format_address $host, $port); 902 $len = $prepare && $prepare->($state{fh}, format_address $host, $service);
776 } 903 }
777 904
778 $len ||= 128; 905 $len ||= 128;
779 906
780 listen $state{fh}, $len 907 listen $state{fh}, $len
… …
782 909
783 $state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub { 910 $state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {
784 # this closure keeps $state alive 911 # this closure keeps $state alive
785 while (my $peer = accept my $fh, $state{fh}) { 912 while (my $peer = accept my $fh, $state{fh}) {
786 fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not 913 fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not
914
787 my ($port, $host) = unpack_sockaddr $peer; 915 my ($service, $host) = unpack_sockaddr $peer;
788 $accept->($fh, format_address $host, $port); 916 $accept->($fh, format_address $host, $service);
789 } 917 }
790 }); 918 });
791 919
792 defined wantarray 920 defined wantarray
793 ? guard { %state = () } # clear fh and watcher, which breaks the circular dependency 921 ? guard { %state = () } # clear fh and watcher, which breaks the circular dependency
… …
796 924
7971; 9251;
798 926
799=back 927=back
800 928
929=head1 SECURITY CONSIDERATIONS
930
931This module is quite powerful, with with power comes the ability to abuse
932as well: If you accept "hostnames" and ports from untrusted sources,
933then note that this can be abused to delete files (host=C<unix/>). This
934is not really a problem with this module, however, as blindly accepting
935any address and protocol and trying to bind a server or connect to it is
936harmful in general.
937
801=head1 AUTHOR 938=head1 AUTHOR
802 939
803 Marc Lehmann <schmorp@schmorp.de> 940 Marc Lehmann <schmorp@schmorp.de>
804 http://home.schmorp.de/ 941 http://home.schmorp.de/
805 942

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines