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.71 by root, Thu Feb 12 17:33:38 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
53 format_ipv4 format_ipv6
55 format_ip format_address 54 format_ip format_address
56 address_family 55 address_family
57 inet_aton 56 inet_aton
58 tcp_server 57 tcp_server
59 tcp_connect 58 tcp_connect
60); 59);
61 60
62our $VERSION = 4.34; 61our $VERSION = 4.83;
63 62
64=item $ipn = parse_ipv4 $dotted_quad 63=item $ipn = parse_ipv4 $dotted_quad
65 64
66Tries 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
67octet 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
… …
144 ? pack "S", AF_UNIX 143 ? pack "S", AF_UNIX
145 : undef 144 : undef
146 145
147} 146}
148 147
149=item $ipn = parse_address $text 148=item $ipn = parse_address $ip
150 149
151Combines C<parse_ipv4> and C<parse_ipv6> in one function. The address 150Combines C<parse_ipv4> and C<parse_ipv6> in one function. The address
152here refers to the host address (not socket address) in network form 151here refers to the host address (not socket address) in network form
153(binary). 152(binary).
154 153
155If the C<$text> is C<unix/>, then this function returns a special token 154If the C<$text> is C<unix/>, then this function returns a special token
156recognised by the other functions in this module to mean "UNIX domain 155recognised by the other functions in this module to mean "UNIX domain
157socket". 156socket".
158 157
158If the C<$text> to parse is a mapped IPv4 in IPv6 address (:ffff::<ipv4>),
159then it will be treated as an IPv4 address. If you don't want that, you
160have to call C<parse_ipv4> and/or C<parse_ipv6> manually.
161
159=item $text = AnyEvent::Socket::aton $ipn 162=item $ipn = AnyEvent::Socket::aton $ip
160 163
161Same as C<parse_address>, but not exported (think C<Socket::inet_aton> but 164Same as C<parse_address>, but not exported (think C<Socket::inet_aton> but
162I<without> name resolution). 165I<without> name resolution).
163 166
164=cut 167=cut
165 168
166sub parse_address($) { 169sub parse_address($) {
167 &parse_ipv4 || &parse_ipv6 || &parse_unix 170 for (&parse_ipv6) {
171 if ($_) {
172 s/^\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff//;
173 return $_;
174 } else {
175 return &parse_ipv4 || &parse_unix
176 }
177 }
168} 178}
169 179
170*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}
171 207
172=item ($host, $service) = parse_hostport $string[, $default_service] 208=item ($host, $service) = parse_hostport $string[, $default_service]
173 209
174Splitting a string of the form C<hostname:port> is a common 210Splitting a string of the form C<hostname:port> is a common
175problem. Unfortunately, just splitting on the colon makes it hard to 211problem. Unfortunately, just splitting on the colon makes it hard to
… …
259 : 16 == length $_[0] 295 : 16 == length $_[0]
260 ? AF_INET6 296 ? AF_INET6
261 : unpack "S", $_[0] 297 : unpack "S", $_[0]
262} 298}
263 299
300=item $text = format_ipv4 $ipn
301
302Expects a four octet string representing a binary IPv4 address and returns
303its textual format. Rarely used, see C<format_address> for a nicer
304interface.
305
306=item $text = format_ipv6 $ipn
307
308Expects a sixteen octet string representing a binary IPv6 address and
309returns its textual format. Rarely used, see C<format_address> for a
310nicer interface.
311
264=item $text = format_address $ipn 312=item $text = format_address $ipn
265 313
266Covnvert a host address in network format (e.g. 4 octets for IPv4 or 16 314Covnvert a host address in network format (e.g. 4 octets for IPv4 or 16
267octets for IPv6) and convert it into textual form. 315octets for IPv6) and convert it into textual form.
268 316
… …
271This function works similarly to C<inet_ntop AF_INET || AF_INET6, ...>, 319This function works similarly to C<inet_ntop AF_INET || AF_INET6, ...>,
272except it automatically detects the address type. 320except it automatically detects the address type.
273 321
274Returns C<undef> if it cannot detect the type. 322Returns C<undef> if it cannot detect the type.
275 323
324If the C<$ipn> is a mapped IPv4 in IPv6 address (:ffff::<ipv4>), then just
325the contained IPv4 address will be returned. If you do not want that, you
326have to call C<format_ipv6> manually.
327
276=item $text = AnyEvent::Socket::ntoa $ipn 328=item $text = AnyEvent::Socket::ntoa $ipn
277 329
278Same as format_address, but not exported (think C<inet_ntoa>). 330Same as format_address, but not exported (think C<inet_ntoa>).
279 331
280=cut 332=cut
281 333
282sub format_address; 334sub format_ipv4($) {
335 join ".", unpack "C4", $_[0]
336}
337
338sub format_ipv6($) {
339 if (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0 eq $_[0]) {
340 return "::";
341 } elsif (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1 eq $_[0]) {
342 return "::1";
343 } elsif (v0.0.0.0.0.0.0.0.0.0.0.0 eq substr $_[0], 0, 12) {
344 # v4compatible
345 return "::" . format_ipv4 substr $_[0], 12;
346 } elsif (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) {
347 # v4mapped
348 return "::ffff:" . format_ipv4 substr $_[0], 12;
349 } elsif (v0.0.0.0.0.0.0.0.255.255.0.0 eq substr $_[0], 0, 12) {
350 # v4translated
351 return "::ffff:0:" . format_ipv4 substr $_[0], 12;
352 } else {
353 my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];
354
355 # this is rather sucky, I admit
356 $ip =~ s/^0:(?:0:)*(0$)?/::/
357 or $ip =~ s/(:0){7}$/::/ or $ip =~ s/(:0){7}/:/
358 or $ip =~ s/(:0){6}$/::/ or $ip =~ s/(:0){6}/:/
359 or $ip =~ s/(:0){5}$/::/ or $ip =~ s/(:0){5}/:/
360 or $ip =~ s/(:0){4}$/::/ or $ip =~ s/(:0){4}/:/
361 or $ip =~ s/(:0){3}$/::/ or $ip =~ s/(:0){3}/:/
362 or $ip =~ s/(:0){2}$/::/ or $ip =~ s/(:0){2}/:/
363 or $ip =~ s/(:0){1}$/::/ or $ip =~ s/(:0){1}/:/;
364 return $ip
365 }
366}
367
283sub format_address($) { 368sub format_address($) {
284 my $af = address_family $_[0]; 369 my $af = address_family $_[0];
285 if ($af == AF_INET) { 370 if ($af == AF_INET) {
286 return join ".", unpack "C4", $_[0] 371 return &format_ipv4;
287 } elsif ($af == AF_INET6) { 372 } 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";
292 } elsif (v0.0.0.0.0.0.0.0.0.0.0.0 eq substr $_[0], 0, 12) {
293 # v4compatible
294 return "::" . format_address substr $_[0], 12;
295 } elsif (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) { 373 return (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12)
296 # v4mapped 374 ? format_ipv4 substr $_[0], 12
297 return "::ffff:" . format_address substr $_[0], 12; 375 : &format_ipv6;
298 } elsif (v0.0.0.0.0.0.0.0.255.255.0.0 eq substr $_[0], 0, 12) {
299 # v4translated
300 return "::ffff:0:" . format_address substr $_[0], 12;
301 } else {
302 my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];
303
304 # this is rather sucky, I admit
305 $ip =~ s/^0:(?:0:)*(0$)?/::/
306 or $ip =~ s/(:0){7}$/::/ or $ip =~ s/(:0){7}/:/
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}/:/;
313 return $ip
314 }
315 } elsif ($af == AF_UNIX) { 376 } elsif ($af == AF_UNIX) {
316 return "unix/" 377 return "unix/"
317 } else { 378 } else {
318 return undef 379 return undef
319 } 380 }
… …
355 } 416 }
356 }); 417 });
357 } 418 }
358} 419}
359 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
360# check for broken platforms with extra field in sockaddr structure 431# check for broken platforms with extra field in sockaddr structure
361# 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
362# 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
363# correctness vs. bsd issue. 434# correctness vs. bsd issue.)
364my $pack_family = (0x55 == Socket::sockaddr_family "\x55\x55") 435my $pack_family = 0x55 == sockaddr_family ("\x55\x55")
365 ? "xC" : "S"; 436 ? "xC" : "S";
366 437
367=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host 438=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host
368 439
369Pack the given port/host combination into a binary sockaddr 440Pack the given port/host combination into a binary sockaddr
… …
405module (C<format_address> converts it to C<unix/>). 476module (C<format_address> converts it to C<unix/>).
406 477
407=cut 478=cut
408 479
409sub unpack_sockaddr($) { 480sub unpack_sockaddr($) {
410 my $af = Socket::sockaddr_family $_[0]; 481 my $af = sockaddr_family $_[0];
411 482
412 if ($af == AF_INET) { 483 if ($af == AF_INET) {
413 Socket::unpack_sockaddr_in $_[0] 484 Socket::unpack_sockaddr_in $_[0]
414 } elsif ($af == AF_INET6) { 485 } elsif ($af == AF_INET6) {
415 unpack "x2 n x4 a16", $_[0] 486 unpack "x2 n x4 a16", $_[0]
… …
462 533
463 resolve_sockaddr "google.com", "http", 0, undef, undef, sub { ... }; 534 resolve_sockaddr "google.com", "http", 0, undef, undef, sub { ... };
464 535
465=cut 536=cut
466 537
467# microsoft can't even get getprotobyname working (the etc/protocols file
468# gets lost fairly often on windows), so we have to hardcode some common
469# protocol numbers ourselves.
470our %PROTO_BYNAME;
471
472$PROTO_BYNAME{tcp} = &Socket::IPPROTO_TCP if defined &Socket::IPPROTO_TCP;
473$PROTO_BYNAME{udp} = &Socket::IPPROTO_UDP if defined &Socket::IPPROTO_UDP;
474$PROTO_BYNAME{icmp} = &Socket::IPPROTO_ICMP if defined &Socket::IPPROTO_ICMP;
475
476sub resolve_sockaddr($$$$$$) { 538sub resolve_sockaddr($$$$$$) {
477 my ($node, $service, $proto, $family, $type, $cb) = @_; 539 my ($node, $service, $proto, $family, $type, $cb) = @_;
478 540
479 if ($node eq "unix/") { 541 if ($node eq "unix/") {
480 return $cb->() if $family || $service !~ /^\//; # no can do 542 return $cb->() if $family || $service !~ /^\//; # no can do
… …
496 $family ||= 6 unless $AnyEvent::PROTOCOL{ipv4}; 558 $family ||= 6 unless $AnyEvent::PROTOCOL{ipv4};
497 559
498 $proto ||= "tcp"; 560 $proto ||= "tcp";
499 $type ||= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM; 561 $type ||= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;
500 562
501 my $proton = $PROTO_BYNAME{lc $proto} || (getprotobyname $proto)[2] 563 my $proton = getprotobyname $proto
502 or Carp::croak "$proto: protocol unknown"; 564 or Carp::croak "$proto: protocol unknown";
503 565
504 my $port; 566 my $port;
505 567
506 if ($service =~ /^(\S+)=(\d+)$/) { 568 if ($service =~ /^(\S+)=(\d+)$/) {
… …
675 or die "unable to connect: $!"; 737 or die "unable to connect: $!";
676 738
677 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.
678 $handle = new AnyEvent::Handle 740 $handle = new AnyEvent::Handle
679 fh => $fh, 741 fh => $fh,
742 on_error => sub {
743 warn "error $_[2]\n";
744 $_[0]->destroy;
745 },
680 on_eof => sub { 746 on_eof => sub {
681 undef $handle; # keep it alive till eof 747 $handle->destroy; # destroy handle
682 warn "done.\n"; 748 warn "done.\n";
683 }; 749 };
684 750
685 $handle->push_write ("GET / HTTP/1.0\015\012\015\012"); 751 $handle->push_write ("GET / HTTP/1.0\015\012\015\012");
686 752
… …
725 791
726 $state{next} = sub { 792 $state{next} = sub {
727 return unless exists $state{fh}; 793 return unless exists $state{fh};
728 794
729 my $target = shift @target 795 my $target = shift @target
730 or do {
731 %state = ();
732 return $connect->(); 796 or return (%state = (), $connect->());
733 };
734 797
735 my ($domain, $type, $proto, $sockaddr) = @$target; 798 my ($domain, $type, $proto, $sockaddr) = @$target;
736 799
737 # socket creation 800 # socket creation
738 socket $state{fh}, $domain, $type, $proto 801 socket $state{fh}, $domain, $type, $proto
… …
743 my $timeout = $prepare && $prepare->($state{fh}); 806 my $timeout = $prepare && $prepare->($state{fh});
744 807
745 $timeout ||= 30 if AnyEvent::WIN32; 808 $timeout ||= 30 if AnyEvent::WIN32;
746 809
747 $state{to} = AnyEvent->timer (after => $timeout, cb => sub { 810 $state{to} = AnyEvent->timer (after => $timeout, cb => sub {
748 $! = &Errno::ETIMEDOUT; 811 $! = Errno::ETIMEDOUT;
749 $state{next}(); 812 $state{next}();
750 }) if $timeout; 813 }) if $timeout;
751 814
752 # called when the connect was successful, which, 815 # called when the connect was successful, which,
753 # 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)
754 $state{connected} = sub { 817 $state{connected} = sub {
755 delete $state{ww};
756 delete $state{to};
757
758 # we are connected, or maybe there was an error 818 # we are connected, or maybe there was an error
759 if (my $sin = getpeername $state{fh}) { 819 if (my $sin = getpeername $state{fh}) {
760 my ($port, $host) = unpack_sockaddr $sin; 820 my ($port, $host) = unpack_sockaddr $sin;
821
822 delete $state{ww}; delete $state{to};
761 823
762 my $guard = guard { %state = () }; 824 my $guard = guard { %state = () };
763 825
764 $connect->(delete $state{fh}, format_address $host, $port, sub { 826 $connect->(delete $state{fh}, format_address $host, $port, sub {
765 $guard->cancel; 827 $guard->cancel;
766 $state{next}(); 828 $state{next}();
767 }); 829 });
768 } else { 830 } else {
769 # dummy read to fetch real error code 831 # dummy read to fetch real error code
770 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
771 $state{next}(); 838 $state{next}();
772 } 839 }
773 }; 840 };
774 841
775 # now connect 842 # now connect
776 if (connect $state{fh}, $sockaddr) { 843 if (connect $state{fh}, $sockaddr) {
777 $state{connected}->(); 844 $state{connected}->();
778 } elsif ($! == &Errno::EINPROGRESS # POSIX 845 } elsif ($! == Errno::EINPROGRESS # POSIX
779 || $! == &Errno::EWOULDBLOCK 846 || $! == Errno::EWOULDBLOCK
780 # WSAEINPROGRESS intentionally not checked - it means something else entirely 847 # WSAEINPROGRESS intentionally not checked - it means something else entirely
781 || $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt 848 || $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt
782 || $! == AnyEvent::Util::WSAEWOULDBLOCK) { 849 || $! == AnyEvent::Util::WSAEWOULDBLOCK) {
783 $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});
784 } else { 851 } else {
785 $state{next}(); 852 $state{next}();
786 } 853 }
787 }; 854 };
788 855
789 $! = &Errno::ENXIO; 856 $! = Errno::ENXIO;
790 $state{next}(); 857 $state{next}();
791 }; 858 };
792 859
793 defined wantarray && guard { %state = () } 860 defined wantarray && guard { %state = () }
794} 861}

Diff Legend

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