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.87 by root, Thu Jul 9 08:31:16 2009 UTC vs.
Revision 1.96 by root, Fri Jul 17 23:12:20 2009 UTC

… …
33 33
34=cut 34=cut
35 35
36package AnyEvent::Socket; 36package AnyEvent::Socket;
37 37
38no warnings;
39use strict;
40
41use Carp (); 38use Carp ();
42use Errno (); 39use Errno ();
43use Socket qw(AF_INET AF_UNIX SOCK_STREAM SOCK_DGRAM SOL_SOCKET SO_REUSEADDR); 40use Socket qw(AF_INET AF_UNIX SOCK_STREAM SOCK_DGRAM SOL_SOCKET SO_REUSEADDR);
44 41
45use AnyEvent (); 42use AnyEvent (); BEGIN { AnyEvent::common_sense }
46use AnyEvent::Util qw(guard fh_nonblocking AF_INET6); 43use AnyEvent::Util qw(guard fh_nonblocking AF_INET6);
47use AnyEvent::DNS (); 44use AnyEvent::DNS ();
48 45
49use base 'Exporter'; 46use base 'Exporter';
50 47
51our @EXPORT = qw( 48our @EXPORT = qw(
49 getprotobyname
52 parse_hostport 50 parse_hostport
53 parse_ipv4 parse_ipv6 51 parse_ipv4 parse_ipv6
54 parse_ip parse_address 52 parse_ip parse_address
55 format_ipv4 format_ipv6 53 format_ipv4 format_ipv6
56 format_ip format_address 54 format_ip format_address
… …
58 inet_aton 56 inet_aton
59 tcp_server 57 tcp_server
60 tcp_connect 58 tcp_connect
61); 59);
62 60
63our $VERSION = 4.81; 61our $VERSION = 4.83;
64 62
65=item $ipn = parse_ipv4 $dotted_quad 63=item $ipn = parse_ipv4 $dotted_quad
66 64
67Tries 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
68octet 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
… …
178 } 176 }
179 } 177 }
180} 178}
181 179
182*aton = \&parse_address; 180*aton = \&parse_address;
181
182=item ($name, $aliases, $proto) = getprotobyname $name
183
184Works like the builtin function of the same name, except it tries hard to
185work even on broken platforms (well, that's windows), where getprotobyname
186is traditionally very unreliable.
187
188=cut
189
190# microsoft can't even get getprotobyname working (the etc/protocols file
191# gets lost fairly often on windows), so we have to hardcode some common
192# protocol numbers ourselves.
193our %PROTO_BYNAME;
194
195$PROTO_BYNAME{tcp} = Socket::IPPROTO_TCP () if defined &Socket::IPPROTO_TCP;
196$PROTO_BYNAME{udp} = Socket::IPPROTO_UDP () if defined &Socket::IPPROTO_UDP;
197$PROTO_BYNAME{icmp} = Socket::IPPROTO_ICMP() if defined &Socket::IPPROTO_ICMP;
198
199sub getprotobyname($) {
200 my $name = lc shift;
201
202 defined (my $proton = $PROTO_BYNAME{$name} || (getprotobyname $name)[2])
203 or return;
204
205 ($name, uc $name, $proton)
206}
183 207
184=item ($host, $service) = parse_hostport $string[, $default_service] 208=item ($host, $service) = parse_hostport $string[, $default_service]
185 209
186Splitting a string of the form C<hostname:port> is a common 210Splitting a string of the form C<hostname:port> is a common
187problem. Unfortunately, just splitting on the colon makes it hard to 211problem. Unfortunately, just splitting on the colon makes it hard to
… …
392 } 416 }
393 }); 417 });
394 } 418 }
395} 419}
396 420
421BEGIN {
422 *sockaddr_family = $Socket::VERSION >= 1.75
423 ? \&Socket::sockaddr_family
424 : # for 5.6.x, we need to do something much more horrible
425 (Socket::pack_sockaddr_in 0x5555, "\x55\x55\x55\x55"
426 | eval { Socket::pack_sockaddr_un "U" }) =~ /^\x00/
427 ? sub { unpack "xC", $_[0] }
428 : sub { unpack "S" , $_[0] };
429}
430
397# check for broken platforms with extra field in sockaddr structure 431# check for broken platforms with extra field in sockaddr structure
398# kind of a rfc vs. bsd issue, as usual (ok, normally it's a 432# kind of a rfc vs. bsd issue, as usual (ok, normally it's a
399# unix vs. bsd issue, a iso C vs. bsd issue or simply a 433# unix vs. bsd issue, a iso C vs. bsd issue or simply a
400# correctness vs. bsd issue. 434# correctness vs. bsd issue.)
401my $pack_family = (0x55 == Socket::sockaddr_family "\x55\x55") 435my $pack_family = 0x55 == sockaddr_family ("\x55\x55")
402 ? "xC" : "S"; 436 ? "xC" : "S";
403 437
404=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host 438=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host
405 439
406Pack the given port/host combination into a binary sockaddr 440Pack the given port/host combination into a binary sockaddr
… …
442module (C<format_address> converts it to C<unix/>). 476module (C<format_address> converts it to C<unix/>).
443 477
444=cut 478=cut
445 479
446sub unpack_sockaddr($) { 480sub unpack_sockaddr($) {
447 my $af = Socket::sockaddr_family $_[0]; 481 my $af = sockaddr_family $_[0];
448 482
449 if ($af == AF_INET) { 483 if ($af == AF_INET) {
450 Socket::unpack_sockaddr_in $_[0] 484 Socket::unpack_sockaddr_in $_[0]
451 } elsif ($af == AF_INET6) { 485 } elsif ($af == AF_INET6) {
452 unpack "x2 n x4 a16", $_[0] 486 unpack "x2 n x4 a16", $_[0]
… …
499 533
500 resolve_sockaddr "google.com", "http", 0, undef, undef, sub { ... }; 534 resolve_sockaddr "google.com", "http", 0, undef, undef, sub { ... };
501 535
502=cut 536=cut
503 537
504# microsoft can't even get getprotobyname working (the etc/protocols file
505# gets lost fairly often on windows), so we have to hardcode some common
506# protocol numbers ourselves.
507our %PROTO_BYNAME;
508
509$PROTO_BYNAME{tcp} = &Socket::IPPROTO_TCP if defined &Socket::IPPROTO_TCP;
510$PROTO_BYNAME{udp} = &Socket::IPPROTO_UDP if defined &Socket::IPPROTO_UDP;
511$PROTO_BYNAME{icmp} = &Socket::IPPROTO_ICMP if defined &Socket::IPPROTO_ICMP;
512
513sub resolve_sockaddr($$$$$$) { 538sub resolve_sockaddr($$$$$$) {
514 my ($node, $service, $proto, $family, $type, $cb) = @_; 539 my ($node, $service, $proto, $family, $type, $cb) = @_;
515 540
516 if ($node eq "unix/") { 541 if ($node eq "unix/") {
517 return $cb->() if $family || $service !~ /^\//; # no can do 542 return $cb->() if $family || $service !~ /^\//; # no can do
… …
533 $family ||= 6 unless $AnyEvent::PROTOCOL{ipv4}; 558 $family ||= 6 unless $AnyEvent::PROTOCOL{ipv4};
534 559
535 $proto ||= "tcp"; 560 $proto ||= "tcp";
536 $type ||= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM; 561 $type ||= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;
537 562
538 my $proton = $PROTO_BYNAME{lc $proto} || (getprotobyname $proto)[2] 563 my $proton = getprotobyname $proto
539 or Carp::croak "$proto: protocol unknown"; 564 or Carp::croak "$proto: protocol unknown";
540 565
541 my $port; 566 my $port;
542 567
543 if ($service =~ /^(\S+)=(\d+)$/) { 568 if ($service =~ /^(\S+)=(\d+)$/) {
… …
712 or die "unable to connect: $!"; 737 or die "unable to connect: $!";
713 738
714 my $handle; # avoid direct assignment so on_eof has it in scope. 739 my $handle; # avoid direct assignment so on_eof has it in scope.
715 $handle = new AnyEvent::Handle 740 $handle = new AnyEvent::Handle
716 fh => $fh, 741 fh => $fh,
742 on_error => sub {
743 warn "error $_[2]\n";
744 $_[0]->destroy;
745 },
717 on_eof => sub { 746 on_eof => sub {
718 undef $handle; # keep it alive till eof 747 $handle->destroy; # destroy handle
719 warn "done.\n"; 748 warn "done.\n";
720 }; 749 };
721 750
722 $handle->push_write ("GET / HTTP/1.0\015\012\015\012"); 751 $handle->push_write ("GET / HTTP/1.0\015\012\015\012");
723 752
… …
762 791
763 $state{next} = sub { 792 $state{next} = sub {
764 return unless exists $state{fh}; 793 return unless exists $state{fh};
765 794
766 my $target = shift @target 795 my $target = shift @target
767 or do {
768 %state = ();
769 return $connect->(); 796 or return (%state = (), $connect->());
770 };
771 797
772 my ($domain, $type, $proto, $sockaddr) = @$target; 798 my ($domain, $type, $proto, $sockaddr) = @$target;
773 799
774 # socket creation 800 # socket creation
775 socket $state{fh}, $domain, $type, $proto 801 socket $state{fh}, $domain, $type, $proto
… …
780 my $timeout = $prepare && $prepare->($state{fh}); 806 my $timeout = $prepare && $prepare->($state{fh});
781 807
782 $timeout ||= 30 if AnyEvent::WIN32; 808 $timeout ||= 30 if AnyEvent::WIN32;
783 809
784 $state{to} = AnyEvent->timer (after => $timeout, cb => sub { 810 $state{to} = AnyEvent->timer (after => $timeout, cb => sub {
785 $! = &Errno::ETIMEDOUT; 811 $! = Errno::ETIMEDOUT;
786 $state{next}(); 812 $state{next}();
787 }) if $timeout; 813 }) if $timeout;
788 814
789 # called when the connect was successful, which, 815 # called when the connect was successful, which,
790 # in theory, could be the case immediately (but never is in practise) 816 # in theory, could be the case immediately (but never is in practise)
791 $state{connected} = sub { 817 $state{connected} = sub {
792 delete $state{ww};
793 delete $state{to};
794
795 # we are connected, or maybe there was an error 818 # we are connected, or maybe there was an error
796 if (my $sin = getpeername $state{fh}) { 819 if (my $sin = getpeername $state{fh}) {
797 my ($port, $host) = unpack_sockaddr $sin; 820 my ($port, $host) = unpack_sockaddr $sin;
821
822 delete $state{ww}; delete $state{to};
798 823
799 my $guard = guard { %state = () }; 824 my $guard = guard { %state = () };
800 825
801 $connect->(delete $state{fh}, format_address $host, $port, sub { 826 $connect->(delete $state{fh}, format_address $host, $port, sub {
802 $guard->cancel; 827 $guard->cancel;
803 $state{next}(); 828 $state{next}();
804 }); 829 });
805 } else { 830 } else {
806 # dummy read to fetch real error code 831 # dummy read to fetch real error code
807 sysread $state{fh}, my $buf, 1 if $! == &Errno::ENOTCONN; 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
808 $state{next}(); 838 $state{next}();
809 } 839 }
810 }; 840 };
811 841
812 # now connect 842 # now connect
813 if (connect $state{fh}, $sockaddr) { 843 if (connect $state{fh}, $sockaddr) {
814 $state{connected}->(); 844 $state{connected}->();
815 } elsif ($! == &Errno::EINPROGRESS # POSIX 845 } elsif ($! == Errno::EINPROGRESS # POSIX
816 || $! == &Errno::EWOULDBLOCK 846 || $! == Errno::EWOULDBLOCK
817 # WSAEINPROGRESS intentionally not checked - it means something else entirely 847 # WSAEINPROGRESS intentionally not checked - it means something else entirely
818 || $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt 848 || $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt
819 || $! == AnyEvent::Util::WSAEWOULDBLOCK) { 849 || $! == AnyEvent::Util::WSAEWOULDBLOCK) {
820 $state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $state{connected}); 850 $state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $state{connected});
821 } else { 851 } else {
822 $state{next}(); 852 $state{next}();
823 } 853 }
824 }; 854 };
825 855
826 $! = &Errno::ENXIO; 856 $! = Errno::ENXIO;
827 $state{next}(); 857 $state{next}();
828 }; 858 };
829 859
830 defined wantarray && guard { %state = () } 860 defined wantarray && guard { %state = () }
831} 861}

Diff Legend

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