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.48 by root, Thu Jun 5 18:30:08 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
… …
56 inet_aton 56 inet_aton
57 tcp_server 57 tcp_server
58 tcp_connect 58 tcp_connect
59); 59);
60 60
61our $VERSION = '1.0'; 61our $VERSION = 4.14;
62 62
63=item $ipn = parse_ipv4 $dotted_quad 63=item $ipn = parse_ipv4 $dotted_quad
64 64
65Tries to parse the given dotted quad IPv4 address and return it in 65Tries 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 66octet form (or undef when it isn't in a parsable format). Supports all
… …
196sub format_address($) { 196sub format_address($) {
197 my $af = address_family $_[0]; 197 my $af = address_family $_[0];
198 if ($af == AF_INET) { 198 if ($af == AF_INET) {
199 return join ".", unpack "C4", $_[0] 199 return join ".", unpack "C4", $_[0]
200 } elsif ($af == AF_INET6) { 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";
201 if (v0.0.0.0.0.0.0.0.0.0.0.0 eq substr $_[0], 0, 12) { 205 } elsif (v0.0.0.0.0.0.0.0.0.0.0.0 eq substr $_[0], 0, 12) {
202 # v4compatible 206 # v4compatible
203 return "::" . format_address substr $_[0], 12; 207 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) { 208 } elsif (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) {
205 # v4mapped 209 # v4mapped
206 return "::ffff:" . format_address substr $_[0], 12; 210 return "::ffff:" . format_address substr $_[0], 12;
… …
208 # v4translated 212 # v4translated
209 return "::ffff:0:" . format_address substr $_[0], 12; 213 return "::ffff:0:" . format_address substr $_[0], 12;
210 } else { 214 } else {
211 my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0]; 215 my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];
212 216
217 # this is rather sucky, I admit
213 $ip =~ s/^0:(?:0:)*(0$)?/::/ 218 $ip =~ s/^0:(?:0:)*(0$)?/::/
214 or $ip =~ s/(:0)+$/::/ 219 or $ip =~ s/(:0){7}$/::/ or $ip =~ s/(:0){7}/:/
215 or $ip =~ s/(:0)+/:/; 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}/:/;
216 return $ip 226 return $ip
217 } 227 }
218 } elsif ($af == AF_UNIX) { 228 } elsif ($af == AF_UNIX) {
219 return "unix/" 229 return "unix/"
220 } else { 230 } else {
… …
262 272
263# check for broken platforms with extra field in sockaddr structure 273# 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 274# 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 275# unix vs. bsd issue, a iso C vs. bsd issue or simply a
266# correctness vs. bsd issue. 276# correctness vs. bsd issue.
267my $pack_family = 0x55 == Socket::sockaddr_family "\x55\x55" 277my $pack_family = (0x55 == Socket::sockaddr_family "\x55\x55")
268 ? "xC" : "S"; 278 ? "xC" : "S";
269 279
270=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host 280=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host
271 281
272Pack the given port/host combination into a binary sockaddr 282Pack the given port/host combination into a binary sockaddr
… …
315 if ($af == AF_INET) { 325 if ($af == AF_INET) {
316 Socket::unpack_sockaddr_in $_[0] 326 Socket::unpack_sockaddr_in $_[0]
317 } elsif ($af == AF_INET6) { 327 } elsif ($af == AF_INET6) {
318 unpack "x2 n x4 a16", $_[0] 328 unpack "x2 n x4 a16", $_[0]
319 } elsif ($af == AF_UNIX) { 329 } elsif ($af == AF_UNIX) {
320 ((Socket::unpack_sockaddr_un $_[0]), "unix/") 330 ((Socket::unpack_sockaddr_un $_[0]), pack "S", AF_UNIX)
321 } else { 331 } else {
322 Carp::croak "unpack_sockaddr: unsupported protocol family $af"; 332 Carp::croak "unpack_sockaddr: unsupported protocol family $af";
323 } 333 }
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} 334}
332 335
333=item resolve_sockaddr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...) 336=item resolve_sockaddr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...)
334 337
335Tries to resolve the given nodename and service name into protocol families 338Tries to resolve the given nodename and service name into protocol families
… …
407 ($service, $port) = ($1, $2); 410 ($service, $port) = ($1, $2);
408 } elsif ($service =~ /^\d+$/) { 411 } elsif ($service =~ /^\d+$/) {
409 ($service, $port) = (undef, $service); 412 ($service, $port) = (undef, $service);
410 } else { 413 } else {
411 $port = (getservbyname $service, $proto)[2] 414 $port = (getservbyname $service, $proto)[2]
412 or Carp::croak "$service/$proto: service unknown"; 415 or Carp::croak "$service/$proto: service unknown";
413 } 416 }
414 417
415 my @target = [$node, $port]; 418 my @target = [$node, $port];
416 419
417 # resolve a records / provide sockaddr structures 420 # resolve a records / provide sockaddr structures
… …
431 $cv->begin; 434 $cv->begin;
432 for my $idx (0 .. $#target) { 435 for my $idx (0 .. $#target) {
433 my ($node, $port) = @{ $target[$idx] }; 436 my ($node, $port) = @{ $target[$idx] };
434 437
435 if (my $noden = parse_address $node) { 438 if (my $noden = parse_address $node) {
439 my $af = address_family $noden;
440
436 if (4 == length $noden && $family != 6) { 441 if ($af == AF_INET && $family != 6) {
437 push @res, [$idx, "ipv4", [AF_INET, $type, $proton, 442 push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
438 pack_sockaddr $port, $noden]] 443 pack_sockaddr $port, $noden]]
439 } 444 }
440 445
441 if (16 == length $noden && $family != 4) { 446 if ($af == AF_INET6 && $family != 4) {
442 push @res, [$idx, "ipv6", [AF_INET6, $type, $proton, 447 push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,
443 pack_sockaddr $port, $noden]] 448 pack_sockaddr $port, $noden]]
444 } 449 }
445 } else { 450 } else {
446 # ipv4 451 # ipv4
447 if ($family != 6) { 452 if ($family != 6) {
448 $cv->begin; 453 $cv->begin;
449 a $node, sub { 454 AnyEvent::DNS::a $node, sub {
450 push @res, [$idx, "ipv4", [AF_INET, $type, $proton, 455 push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
451 pack_sockaddr $port, parse_ipv4 $_]] 456 pack_sockaddr $port, parse_ipv4 $_]]
452 for @_; 457 for @_;
453 $cv->end; 458 $cv->end;
454 }; 459 };
455 } 460 }
456 461
457 # ipv6 462 # ipv6
458 if ($family != 4) { 463 if ($family != 4) {
459 $cv->begin; 464 $cv->begin;
460 aaaa $node, sub { 465 AnyEvent::DNS::aaaa $node, sub {
461 push @res, [$idx, "ipv6", [AF_INET6, $type, $proton, 466 push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,
462 pack_sockaddr $port, parse_ipv6 $_]] 467 pack_sockaddr $port, parse_ipv6 $_]]
463 for @_; 468 for @_;
464 $cv->end; 469 $cv->end;
465 }; 470 };
… …
472 # try srv records, if applicable 477 # try srv records, if applicable
473 if ($node eq "localhost") { 478 if ($node eq "localhost") {
474 @target = (["127.0.0.1", $port], ["::1", $port]); 479 @target = (["127.0.0.1", $port], ["::1", $port]);
475 &$resolve; 480 &$resolve;
476 } elsif (defined $service && !parse_address $node) { 481 } elsif (defined $service && !parse_address $node) {
477 srv $service, $proto, $node, sub { 482 AnyEvent::DNS::srv $service, $proto, $node, sub {
478 my (@srv) = @_; 483 my (@srv) = @_;
479 484
480 # no srv records, continue traditionally 485 # no srv records, continue traditionally
481 @srv 486 @srv
482 or return &$resolve; 487 or return &$resolve;
483 488
484 # only srv record has "." => abort 489 # the only srv record has "." ("" here) => abort
485 $srv[0][2] ne "." || $#srv 490 $srv[0][2] ne "" || $#srv
486 or return $cb->(); 491 or return $cb->();
487 492
488 # use srv records then 493 # use srv records then
489 @target = map ["$_->[3].", $_->[2]], 494 @target = map ["$_->[3].", $_->[2]],
490 grep $_->[3] ne ".", 495 grep $_->[3] ne ".",
… …
555lessen the impact of this windows bug, a default timeout of 30 seconds 560lessen the impact of this windows bug, a default timeout of 30 seconds
556will be imposed on windows. Cygwin is not affected. 561will be imposed on windows. Cygwin is not affected.
557 562
558Simple Example: connect to localhost on port 22. 563Simple Example: connect to localhost on port 22.
559 564
560 tcp_connect localhost => 22, sub { 565 tcp_connect localhost => 22, sub {
561 my $fh = shift 566 my $fh = shift
562 or die "unable to connect: $!"; 567 or die "unable to connect: $!";
563 # do something 568 # do something
564 }; 569 };
565 570
566Complex Example: connect to www.google.com on port 80 and make a simple 571Complex Example: connect to www.google.com on port 80 and make a simple
567GET request without much error handling. Also limit the connection timeout 572GET request without much error handling. Also limit the connection timeout
568to 15 seconds. 573to 15 seconds.
569 574
… …
691 }; 696 };
692 697
693 defined wantarray && guard { %state = () } 698 defined wantarray && guard { %state = () }
694} 699}
695 700
696=item $guard = tcp_server $host, $port, $accept_cb[, $prepare_cb] 701=item $guard = tcp_server $host, $service, $accept_cb[, $prepare_cb]
697 702
698Create and bind a TCP socket to the given host, and port, set the 703Create and bind a stream socket to the given host, and port, set the
699SO_REUSEADDR flag and call C<listen>. 704SO_REUSEADDR flag (if applicable) and call C<listen>. Unlike the name
705implies, this function can also bind on UNIX domain sockets.
700 706
701C<$host> must be an IPv4 or IPv6 address (or C<undef>, in which case it 707For 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 708C<undef>, in which case it binds either to C<0> or to C<::>, depending
703preferred protocol). 709on whether IPv4 or IPv6 is the preferred protocol, and maybe to both in
710future versions, as applicable).
704 711
705To bind to the IPv4 wildcard address, use C<0>, to bind to the IPv6 712To bind to the IPv4 wildcard address, use C<0>, to bind to the IPv6
706wildcard address, use C<::>. 713wildcard address, use C<::>.
707 714
708The port is specified by C<$port>, which must be either a service name or 715The 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 716a numeric port number (or C<0> or C<undef>, in which case an ephemeral
710port will be used). 717port will be used).
718
719For UNIX domain sockets, C<$host> must be C<unix/> and C<$service> must be
720the absolute pathname of the socket. This function will try to C<unlink>
721the socket before it tries to bind to it. See SECURITY CONSIDERATIONS,
722below.
711 723
712For each new connection that could be C<accept>ed, call the C<< 724For 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 725$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 726mode) as first and the peer host and port as second and third arguments
715(see C<tcp_connect> for details). 727(see C<tcp_connect> for details).
… …
727address and port number of the local socket endpoint as second and third 739address and port number of the local socket endpoint as second and third
728arguments. 740arguments.
729 741
730It should return the length of the listen queue (or C<0> for the default). 742It should return the length of the listen queue (or C<0> for the default).
731 743
744Note to IPv6 users: RFC-compliant behaviour for IPv6 sockets listening on
745C<::> is to bind to both IPv6 and IPv4 addresses by default on dual-stack
746hosts. Unfortunately, only GNU/Linux seems to implement this properly, so
747if you want both IPv4 and IPv6 listening sockets you should create the
748IPv6 socket first and then attempt to bind on the IPv4 socket, but ignore
749any C<EADDRINUSE> errors.
750
732Example: bind on some TCP port on the local machine and tell each client 751Example: bind on some TCP port on the local machine and tell each client
733to go away. 752to go away.
734 753
735 tcp_server undef, undef, sub { 754 tcp_server undef, undef, sub {
736 my ($fh, $host, $port) = @_; 755 my ($fh, $host, $port) = @_;
… …
742 }; 761 };
743 762
744=cut 763=cut
745 764
746sub tcp_server($$$;$) { 765sub tcp_server($$$;$) {
747 my ($host, $port, $accept, $prepare) = @_; 766 my ($host, $service, $accept, $prepare) = @_;
748 767
749 $host = $AnyEvent::PROTOCOL{ipv4} < $AnyEvent::PROTOCOL{ipv6} && AF_INET6 768 $host = $AnyEvent::PROTOCOL{ipv4} < $AnyEvent::PROTOCOL{ipv6} && AF_INET6
750 ? "::" : "0" 769 ? "::" : "0"
751 unless defined $host; 770 unless defined $host;
752 771
753 my $ipn = parse_address $host 772 my $ipn = parse_address $host
754 or Carp::croak "AnyEvent::Socket::tcp_server: cannot parse '$host' as host address"; 773 or Carp::croak "AnyEvent::Socket::tcp_server: cannot parse '$host' as host address";
755 774
756 my $domain = 4 == length $ipn ? AF_INET : AF_INET6; 775 my $af = address_family $ipn;
757 776
758 my %state; 777 my %state;
759 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
760 socket $state{fh}, $domain, SOCK_STREAM, 0 783 socket $state{fh}, $af, SOCK_STREAM, 0
761 or Carp::croak "socket: $!"; 784 or Carp::croak "tcp_server/socket: $!";
762 785
786 if ($af == AF_INET || $af == AF_INET6) {
763 setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1 787 setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1
764 or Carp::croak "so_reuseaddr: $!"; 788 or Carp::croak "tcp_server/so_reuseaddr: $!"
789 unless AnyEvent::WIN32; # work around windows bug
765 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
766 bind $state{fh}, pack_sockaddr _tcp_port $port, $ipn 799 bind $state{fh}, pack_sockaddr $service, $ipn
767 or Carp::croak "bind: $!"; 800 or Carp::croak "bind: $!";
768 801
769 fh_nonblocking $state{fh}, 1; 802 fh_nonblocking $state{fh}, 1;
770 803
771 my $len; 804 my $len;
772 805
773 if ($prepare) { 806 if ($prepare) {
774 my ($port, $host) = unpack_sockaddr getsockname $state{fh}; 807 my ($service, $host) = unpack_sockaddr getsockname $state{fh};
775 $len = $prepare && $prepare->($state{fh}, format_address $host, $port); 808 $len = $prepare && $prepare->($state{fh}, format_address $host, $service);
776 } 809 }
777 810
778 $len ||= 128; 811 $len ||= 128;
779 812
780 listen $state{fh}, $len 813 listen $state{fh}, $len
… …
782 815
783 $state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub { 816 $state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {
784 # this closure keeps $state alive 817 # this closure keeps $state alive
785 while (my $peer = accept my $fh, $state{fh}) { 818 while (my $peer = accept my $fh, $state{fh}) {
786 fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not 819 fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not
820
787 my ($port, $host) = unpack_sockaddr $peer; 821 my ($service, $host) = unpack_sockaddr $peer;
788 $accept->($fh, format_address $host, $port); 822 $accept->($fh, format_address $host, $service);
789 } 823 }
790 }); 824 });
791 825
792 defined wantarray 826 defined wantarray
793 ? guard { %state = () } # clear fh and watcher, which breaks the circular dependency 827 ? guard { %state = () } # clear fh and watcher, which breaks the circular dependency
… …
796 830
7971; 8311;
798 832
799=back 833=back
800 834
835=head1 SECURITY CONSIDERATIONS
836
837This module is quite powerful, with with power comes the ability to abuse
838as well: If you accept "hostnames" and ports from untrusted sources,
839then note that this can be abused to delete files (host=C<unix/>). This
840is not really a problem with this module, however, as blindly accepting
841any address and protocol and trying to bind a server or connect to it is
842harmful in general.
843
801=head1 AUTHOR 844=head1 AUTHOR
802 845
803 Marc Lehmann <schmorp@schmorp.de> 846 Marc Lehmann <schmorp@schmorp.de>
804 http://home.schmorp.de/ 847 http://home.schmorp.de/
805 848

Diff Legend

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