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.99 by root, Sun Jul 26 00:17:25 2009 UTC vs.
Revision 1.113 by root, Sun Aug 16 16:54:51 2009 UTC

… …
45 45
46use base 'Exporter'; 46use base 'Exporter';
47 47
48our @EXPORT = qw( 48our @EXPORT = qw(
49 getprotobyname 49 getprotobyname
50 parse_hostport 50 parse_hostport format_hostport
51 parse_ipv4 parse_ipv6 51 parse_ipv4 parse_ipv6
52 parse_ip parse_address 52 parse_ip parse_address
53 format_ipv4 format_ipv6 53 format_ipv4 format_ipv6
54 format_ip format_address 54 format_ip format_address
55 address_family 55 address_family
56 inet_aton 56 inet_aton
57 tcp_server 57 tcp_server
58 tcp_connect 58 tcp_connect
59); 59);
60 60
61our $VERSION = 4.87; 61our $VERSION = $AnyEvent::VERSION;
62
63# used in cases where we may return immediately but want the
64# caller to do stuff first
65sub _postpone {
66 my ($cb, @args) = (@_, $!);
67
68 my $w; $w = AE::timer 0, 0, sub {
69 undef $w;
70 $! = pop @args;
71 $cb->(@args);
72 };
73}
62 74
63=item $ipn = parse_ipv4 $dotted_quad 75=item $ipn = parse_ipv4 $dotted_quad
64 76
65Tries to parse the given dotted quad IPv4 address and return it in 77Tries 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 78octet form (or undef when it isn't in a parsable format). Supports all
… …
227 ipv4or6 port e.g. "::1 443", "10.0.0.1 smtp" 239 ipv4or6 port e.g. "::1 443", "10.0.0.1 smtp"
228 240
229It also supports defaulting the service name in a simple way by using 241It also supports defaulting the service name in a simple way by using
230C<$default_service> if no service was detected. If neither a service was 242C<$default_service> if no service was detected. If neither a service was
231detected nor a default was specified, then this function returns the 243detected nor a default was specified, then this function returns the
232empty list. The same happens when a parse error weas detected, such as a 244empty list. The same happens when a parse error was detected, such as a
233hostname with a colon in it (the function is rather conservative, though). 245hostname with a colon in it (the function is rather conservative, though).
234 246
235Example: 247Example:
236 248
237 print join ",", parse_hostport "localhost:443"; 249 print join ",", parse_hostport "localhost:443";
… …
278 290
279 # hostnames must not contain :'s 291 # hostnames must not contain :'s
280 return if $host =~ /:/ && !parse_ipv6 $host; 292 return if $host =~ /:/ && !parse_ipv6 $host;
281 293
282 ($host, $port) 294 ($host, $port)
295}
296
297=item $string = format_hostport $host, $port
298
299Takes a host (in textual form) and a port and formats in unambigiously in
300a way that C<parse_hostport> can parse it again. C<$port> can be C<undef>.
301
302=cut
303
304sub format_hostport($;$) {
305 my ($host, $port) = @_;
306
307 $port = ":$port" if length $port;
308 $host = "[$host]" if $host =~ /:/;
309
310 "$host$port"
283} 311}
284 312
285=item $sa_family = address_family $ipn 313=item $sa_family = address_family $ipn
286 314
287Returns the address family/protocol-family (AF_xxx/PF_xxx, in one value :) 315Returns the address family/protocol-family (AF_xxx/PF_xxx, in one value :)
… …
475is a special token that is understood by the other functions in this 503is a special token that is understood by the other functions in this
476module (C<format_address> converts it to C<unix/>). 504module (C<format_address> converts it to C<unix/>).
477 505
478=cut 506=cut
479 507
508# perl contains a bug (imho) where it requires that the kernel always returns
509# sockaddr_un structures of maximum length (which is not, AFAICS, required
510# by any standard). try to 0-pad structures for the benefit of those platforms.
511
512my $sa_un_zero = Socket::pack_sockaddr_un ""; $sa_un_zero ^= $sa_un_zero;
513
480sub unpack_sockaddr($) { 514sub unpack_sockaddr($) {
481 my $af = sockaddr_family $_[0]; 515 my $af = sockaddr_family $_[0];
482 516
483 if ($af == AF_INET) { 517 if ($af == AF_INET) {
484 Socket::unpack_sockaddr_in $_[0] 518 Socket::unpack_sockaddr_in $_[0]
485 } elsif ($af == AF_INET6) { 519 } elsif ($af == AF_INET6) {
486 unpack "x2 n x4 a16", $_[0] 520 unpack "x2 n x4 a16", $_[0]
487 } elsif ($af == AF_UNIX) { 521 } elsif ($af == AF_UNIX) {
488 ((Socket::unpack_sockaddr_un $_[0]), pack "S", AF_UNIX) 522 ((Socket::unpack_sockaddr_un $_[0] ^ $sa_un_zero), pack "S", AF_UNIX)
489 } else { 523 } else {
490 Carp::croak "unpack_sockaddr: unsupported protocol family $af"; 524 Carp::croak "unpack_sockaddr: unsupported protocol family $af";
491 } 525 }
492} 526}
493 527
… …
577 my @target = [$node, $port]; 611 my @target = [$node, $port];
578 612
579 # resolve a records / provide sockaddr structures 613 # resolve a records / provide sockaddr structures
580 my $resolve = sub { 614 my $resolve = sub {
581 my @res; 615 my @res;
582 my $cv = AnyEvent->condvar (cb => sub { 616 my $cv = AE::cv {
583 $cb->( 617 $cb->(
584 map $_->[2], 618 map $_->[2],
585 sort { 619 sort {
586 $AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]} 620 $AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]}
587 or $a->[0] <=> $b->[0] 621 or $a->[0] <=> $b->[0]
588 } 622 }
589 @res 623 @res
590 ) 624 )
591 }); 625 };
592 626
593 $cv->begin; 627 $cv->begin;
594 for my $idx (0 .. $#target) { 628 for my $idx (0 .. $#target) {
595 my ($node, $port) = @{ $target[$idx] }; 629 my ($node, $port) = @{ $target[$idx] };
596 630
… …
675 709
676In either case, it will create a list of target hosts (e.g. for multihomed 710In either case, it will create a list of target hosts (e.g. for multihomed
677hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to 711hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to
678each in turn. 712each in turn.
679 713
680If the connect is successful, then the C<$connect_cb> will be invoked with 714After the connection is established, then the C<$connect_cb> will be
681the socket file handle (in non-blocking mode) as first and the peer host 715invoked with the socket file handle (in non-blocking mode) as first and
682(as a textual IP address) and peer port as second and third arguments, 716the peer host (as a textual IP address) and peer port as second and third
683respectively. The fourth argument is a code reference that you can call 717arguments, respectively. The fourth argument is a code reference that you
684if, for some reason, you don't like this connection, which will cause 718can call if, for some reason, you don't like this connection, which will
685C<tcp_connect> to try the next one (or call your callback without any 719cause C<tcp_connect> to try the next one (or call your callback without
686arguments if there are no more connections). In most cases, you can simply 720any arguments if there are no more connections). In most cases, you can
687ignore this argument. 721simply ignore this argument.
688 722
689 $cb->($filehandle, $host, $port, $retry) 723 $cb->($filehandle, $host, $port, $retry)
690 724
691If the connect is unsuccessful, then the C<$connect_cb> will be invoked 725If the connect is unsuccessful, then the C<$connect_cb> will be invoked
692without any arguments and C<$!> will be set appropriately (with C<ENXIO> 726without any arguments and C<$!> will be set appropriately (with C<ENXIO>
693indicating a DNS resolution failure). 727indicating a DNS resolution failure).
728
729The callback will I<never> be invoked before C<tcp_connect> returns, even
730if C<tcp_connect> was able to connect immediately (e.g. on unix domain
731sockets).
694 732
695The file handle is perfect for being plugged into L<AnyEvent::Handle>, but 733The file handle is perfect for being plugged into L<AnyEvent::Handle>, but
696can be used as a normal perl file handle as well. 734can be used as a normal perl file handle as well.
697 735
698Unless called in void context, C<tcp_connect> returns a guard object that 736Unless called in void context, C<tcp_connect> returns a guard object that
… …
748 warn "done.\n"; 786 warn "done.\n";
749 }; 787 };
750 788
751 $handle->push_write ("GET / HTTP/1.0\015\012\015\012"); 789 $handle->push_write ("GET / HTTP/1.0\015\012\015\012");
752 790
753 $handle->push_read_line ("\015\012\015\012", sub { 791 $handle->push_read (line => "\015\012\015\012", sub {
754 my ($handle, $line) = @_; 792 my ($handle, $line) = @_;
755 793
756 # print response header 794 # print response header
757 print "HEADER\n$line\n\nBODY\n"; 795 print "HEADER\n$line\n\nBODY\n";
758 796
… …
791 829
792 $state{next} = sub { 830 $state{next} = sub {
793 return unless exists $state{fh}; 831 return unless exists $state{fh};
794 832
795 my $target = shift @target 833 my $target = shift @target
796 or return (%state = (), $connect->()); 834 or return (%state = (), _postpone $connect);
797 835
798 my ($domain, $type, $proto, $sockaddr) = @$target; 836 my ($domain, $type, $proto, $sockaddr) = @$target;
799 837
800 # socket creation 838 # socket creation
801 socket $state{fh}, $domain, $type, $proto 839 socket $state{fh}, $domain, $type, $proto
… …
805 843
806 my $timeout = $prepare && $prepare->($state{fh}); 844 my $timeout = $prepare && $prepare->($state{fh});
807 845
808 $timeout ||= 30 if AnyEvent::WIN32; 846 $timeout ||= 30 if AnyEvent::WIN32;
809 847
810 $state{to} = AnyEvent->timer (after => $timeout, cb => sub { 848 $state{to} = AE::timer $timeout, 0, sub {
811 $! = Errno::ETIMEDOUT; 849 $! = Errno::ETIMEDOUT;
812 $state{next}(); 850 $state{next}();
813 }) if $timeout; 851 } if $timeout;
814 852
815 # called when the connect was successful, which, 853 # now connect
816 # in theory, could be the case immediately (but never is in practise) 854 if (
817 $state{connected} = sub { 855 (connect $state{fh}, $sockaddr)
856 || ($! == Errno::EINPROGRESS # POSIX
857 || $! == Errno::EWOULDBLOCK
858 # WSAEINPROGRESS intentionally not checked - it means something else entirely
859 || $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt
860 || $! == AnyEvent::Util::WSAEWOULDBLOCK)
861 ) {
862 $state{ww} = AE::io $state{fh}, 1, sub {
818 # we are connected, or maybe there was an error 863 # we are connected, or maybe there was an error
819 if (my $sin = getpeername $state{fh}) { 864 if (my $sin = getpeername $state{fh}) {
820 my ($port, $host) = unpack_sockaddr $sin; 865 my ($port, $host) = unpack_sockaddr $sin;
821 866
822 delete $state{ww}; delete $state{to}; 867 delete $state{ww}; delete $state{to};
823 868
824 my $guard = guard { %state = () }; 869 my $guard = guard { %state = () };
825 870
826 $connect->(delete $state{fh}, format_address $host, $port, sub { 871 $connect->(delete $state{fh}, format_address $host, $port, sub {
827 $guard->cancel; 872 $guard->cancel;
873 $state{next}();
874 });
875 } else {
876 # dummy read to fetch real error code
877 sysread $state{fh}, my $buf, 1 if $! == Errno::ENOTCONN;
878
879 return if $! == Errno::EAGAIN; # skip spurious wake-ups
880
881 delete $state{ww}; delete $state{to};
882
828 $state{next}(); 883 $state{next}();
829 }); 884 }
830 } else {
831 # dummy read to fetch real error code
832 sysread $state{fh}, my $buf, 1 if $! == Errno::ENOTCONN;
833
834 return if $! == Errno::EAGAIN; # skip spurious wake-ups
835
836 delete $state{ww}; delete $state{to};
837
838 $state{next}();
839 } 885 };
840 };
841
842 # now connect
843 if (connect $state{fh}, $sockaddr) {
844 $state{connected}->();
845 } elsif ($! == Errno::EINPROGRESS # POSIX
846 || $! == Errno::EWOULDBLOCK
847 # WSAEINPROGRESS intentionally not checked - it means something else entirely
848 || $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt
849 || $! == AnyEvent::Util::WSAEWOULDBLOCK) {
850 $state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $state{connected});
851 } else { 886 } else {
852 $state{next}(); 887 $state{next}();
853 } 888 }
854 }; 889 };
855 890
… …
979 $len ||= 128; 1014 $len ||= 128;
980 1015
981 listen $state{fh}, $len 1016 listen $state{fh}, $len
982 or Carp::croak "listen: $!"; 1017 or Carp::croak "listen: $!";
983 1018
984 $state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub { 1019 $state{aw} = AE::io $state{fh}, 0, sub {
985 # this closure keeps $state alive 1020 # this closure keeps $state alive
986 while (my $peer = accept my $fh, $state{fh}) { 1021 while (my $peer = accept my $fh, $state{fh}) {
987 fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not 1022 fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not
988 1023
989 my ($service, $host) = unpack_sockaddr $peer; 1024 my ($service, $host) = unpack_sockaddr $peer;
990 $accept->($fh, format_address $host, $service); 1025 $accept->($fh, format_address $host, $service);
991 } 1026 }
992 }); 1027 };
993 1028
994 defined wantarray 1029 defined wantarray
995 ? guard { %state = () } # clear fh and watcher, which breaks the circular dependency 1030 ? guard { %state = () } # clear fh and watcher, which breaks the circular dependency
996 : () 1031 : ()
997} 1032}

Diff Legend

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