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.37 by root, Wed May 28 21:52:20 2008 UTC vs.
Revision 1.97 by root, Sat Jul 18 05:19:09 2009 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
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
50 parse_hostport
52 parse_ipv4 parse_ipv6 51 parse_ipv4 parse_ipv6
53 parse_ip parse_address 52 parse_ip parse_address
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 = '1.0'; 61our $VERSION = 4.85;
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
78 78
79 # check leading parts against range 79 # check leading parts against range
80 return undef if grep $_ >= 256, @_[0 .. @_ - 2]; 80 return undef if grep $_ >= 256, @_[0 .. @_ - 2];
81 81
82 # check trailing part against range 82 # check trailing part against range
83 return undef if $_[-1] >= 1 << (8 * (4 - $#_)); 83 return undef if $_[-1] >= 2 ** (8 * (4 - $#_));
84 84
85 pack "N", (pop) 85 pack "N", (pop)
86 + ($_[0] << 24) 86 + ($_[0] << 24)
87 + ($_[1] << 16) 87 + ($_[1] << 16)
88 + ($_[2] << 8); 88 + ($_[2] << 8);
143 ? pack "S", AF_UNIX 143 ? pack "S", AF_UNIX
144 : undef 144 : undef
145 145
146} 146}
147 147
148=item $ipn = parse_address $text 148=item $ipn = parse_address $ip
149 149
150Combines 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
151here refers to the host address (not socket address) in network form 151here refers to the host address (not socket address) in network form
152(binary). 152(binary).
153 153
154If 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
155recognised by the other functions in this module to mean "UNIX domain 155recognised by the other functions in this module to mean "UNIX domain
156socket". 156socket".
157 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
162=item $ipn = AnyEvent::Socket::aton $ip
163
164Same as C<parse_address>, but not exported (think C<Socket::inet_aton> but
165I<without> name resolution).
166
158=cut 167=cut
159 168
160sub parse_address($) { 169sub parse_address($) {
161 &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 }
162} 178}
163 179
164*parse_ip =\&parse_address; #d# 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}
207
208=item ($host, $service) = parse_hostport $string[, $default_service]
209
210Splitting a string of the form C<hostname:port> is a common
211problem. Unfortunately, just splitting on the colon makes it hard to
212specify IPv6 addresses and doesn't support the less common but well
213standardised C<[ip literal]> syntax.
214
215This function tries to do this job in a better way, it supports the
216following formats, where C<port> can be a numerical port number of a
217service name, or a C<name=port> string, and the C< port> and C<:port>
218parts are optional. Also, everywhere where an IP address is supported
219a hostname or unix domain socket address is also supported (see
220C<parse_unix>).
221
222 hostname:port e.g. "www.linux.org", "www.x.de:443", "www.x.de:https=443"
223 ipv4:port e.g. "198.182.196.56", "127.1:22"
224 ipv6 e.g. "::1", "affe::1"
225 [ipv4or6]:port e.g. "[::1]", "[10.0.1]:80"
226 [ipv4or6] port e.g. "[127.0.0.1]", "[www.x.org] 17"
227 ipv4or6 port e.g. "::1 443", "10.0.0.1 smtp"
228
229It 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
231detected nor a default was specified, then this function returns the
232empty list. The same happens when a parse error weas detected, such as a
233hostname with a colon in it (the function is rather conservative, though).
234
235Example:
236
237 print join ",", parse_hostport "localhost:443";
238 # => "localhost,443"
239
240 print join ",", parse_hostport "localhost", "https";
241 # => "localhost,https"
242
243 print join ",", parse_hostport "[::1]";
244 # => "," (empty list)
245
246=cut
247
248sub parse_hostport($;$) {
249 my ($host, $port);
250
251 for ("$_[0]") { # work on a copy, just in case, and also reset pos
252
253 # parse host, special cases: "ipv6" or "ipv6 port"
254 unless (
255 ($host) = /^\s* ([0-9a-fA-F:]*:[0-9a-fA-F:]*:[0-9a-fA-F\.:]*)/xgc
256 and parse_ipv6 $host
257 ) {
258 /^\s*/xgc;
259
260 if (/^ \[ ([^\[\]]+) \]/xgc) {
261 $host = $1;
262 } elsif (/^ ([^\[\]:\ ]+) /xgc) {
263 $host = $1;
264 } else {
265 return;
266 }
267 }
268
269 # parse port
270 if (/\G (?:\s+|:) ([^:[:space:]]+) \s*$/xgc) {
271 $port = $1;
272 } elsif (/\G\s*$/gc && length $_[1]) {
273 $port = $_[1];
274 } else {
275 return;
276 }
277 }
278
279 # hostnames must not contain :'s
280 return if $host =~ /:/ && !parse_ipv6 $host;
281
282 ($host, $port)
283}
165 284
166=item $sa_family = address_family $ipn 285=item $sa_family = address_family $ipn
167 286
168Returns the address family/protocol-family (AF_xxx/PF_xxx, in one value :) 287Returns the address family/protocol-family (AF_xxx/PF_xxx, in one value :)
169of the given host address in network format. 288of the given host address in network format.
176 : 16 == length $_[0] 295 : 16 == length $_[0]
177 ? AF_INET6 296 ? AF_INET6
178 : unpack "S", $_[0] 297 : unpack "S", $_[0]
179} 298}
180 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
181=item $text = format_address $ipn 312=item $text = format_address $ipn
182 313
183Covnvert 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
184octets for IPv6) and convert it into textual form. 315octets for IPv6) and convert it into textual form.
185 316
188This function works similarly to C<inet_ntop AF_INET || AF_INET6, ...>, 319This function works similarly to C<inet_ntop AF_INET || AF_INET6, ...>,
189except it automatically detects the address type. 320except it automatically detects the address type.
190 321
191Returns C<undef> if it cannot detect the type. 322Returns C<undef> if it cannot detect the type.
192 323
193=cut 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.
194 327
195sub format_address; 328=item $text = AnyEvent::Socket::ntoa $ipn
329
330Same as format_address, but not exported (think C<inet_ntoa>).
331
332=cut
333
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
196sub format_address($) { 368sub format_address($) {
197 my $af = address_family $_[0]; 369 my $af = address_family $_[0];
198 if ($af == AF_INET) { 370 if ($af == AF_INET) {
199 return join ".", unpack "C4", $_[0] 371 return &format_ipv4;
200 } elsif ($af == AF_INET6) { 372 } elsif ($af == AF_INET6) {
201 if (v0.0.0.0.0.0.0.0.0.0.0.0 eq substr $_[0], 0, 12) {
202 # v4compatible
203 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) { 373 return (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12)
205 # v4mapped 374 ? format_ipv4 substr $_[0], 12
206 return "::ffff:" . format_address substr $_[0], 12; 375 : &format_ipv6;
207 } elsif (v0.0.0.0.0.0.0.0.255.255.0.0 eq substr $_[0], 0, 12) {
208 # v4translated
209 return "::ffff:0:" . format_address substr $_[0], 12;
210 } else {
211 my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];
212
213 $ip =~ s/^0:(?:0:)*(0$)?/::/
214 or $ip =~ s/(:0)+$/::/
215 or $ip =~ s/(:0)+/:/;
216 return $ip
217 }
218 } elsif ($af == AF_UNIX) { 376 } elsif ($af == AF_UNIX) {
219 return "unix/" 377 return "unix/"
220 } else { 378 } else {
221 return undef 379 return undef
222 } 380 }
223} 381}
224 382
225*format_ip = \&format_address; 383*ntoa = \&format_address;
226 384
227=item inet_aton $name_or_address, $cb->(@addresses) 385=item inet_aton $name_or_address, $cb->(@addresses)
228 386
229Works similarly to its Socket counterpart, except that it uses a 387Works similarly to its Socket counterpart, except that it uses a
230callback. Also, if a host has only an IPv6 address, this might be passed 388callback. Also, if a host has only an IPv6 address, this might be passed
258 } 416 }
259 }); 417 });
260 } 418 }
261} 419}
262 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
263# check for broken platforms with extra field in sockaddr structure 431# 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 432# 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 433# unix vs. bsd issue, a iso C vs. bsd issue or simply a
266# correctness vs. bsd issue. 434# correctness vs. bsd issue.)
267my $pack_family = 0x55 == Socket::sockaddr_family "\x55\x55" 435my $pack_family = 0x55 == sockaddr_family ("\x55\x55")
268 ? "xC" : "S"; 436 ? "xC" : "S";
269 437
270=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host 438=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host
271 439
272Pack the given port/host combination into a binary sockaddr 440Pack the given port/host combination into a binary sockaddr
308module (C<format_address> converts it to C<unix/>). 476module (C<format_address> converts it to C<unix/>).
309 477
310=cut 478=cut
311 479
312sub unpack_sockaddr($) { 480sub unpack_sockaddr($) {
313 my $af = Socket::sockaddr_family $_[0]; 481 my $af = sockaddr_family $_[0];
314 482
315 if ($af == AF_INET) { 483 if ($af == AF_INET) {
316 Socket::unpack_sockaddr_in $_[0] 484 Socket::unpack_sockaddr_in $_[0]
317 } elsif ($af == AF_INET6) { 485 } elsif ($af == AF_INET6) {
318 unpack "x2 n x4 a16", $_[0] 486 unpack "x2 n x4 a16", $_[0]
346C<sctp>. The default is currently C<tcp>, but in the future, this function 514C<sctp>. The default is currently C<tcp>, but in the future, this function
347might try to use other protocols such as C<sctp>, depending on the socket 515might try to use other protocols such as C<sctp>, depending on the socket
348type and any SRV records it might find. 516type and any SRV records it might find.
349 517
350C<$family> must be either C<0> (meaning any protocol is OK), C<4> (use 518C<$family> must be either C<0> (meaning any protocol is OK), C<4> (use
351only IPv4) or C<6> (use only IPv6). This setting might be influenced by 519only IPv4) or C<6> (use only IPv6). The default is influenced by
352C<$ENV{PERL_ANYEVENT_PROTOCOLS}>. 520C<$ENV{PERL_ANYEVENT_PROTOCOLS}>.
353 521
354C<$type> must be C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_SEQPACKET> (or 522C<$type> must be C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_SEQPACKET> (or
355C<undef> in which case it gets automatically chosen). 523C<undef> in which case it gets automatically chosen to be C<SOCK_STREAM>
524unless C<$proto> is C<udp>).
356 525
357The callback will receive zero or more array references that contain 526The callback will receive zero or more array references that contain
358C<$family, $type, $proto> for use in C<socket> and a binary 527C<$family, $type, $proto> for use in C<socket> and a binary
359C<$sockaddr> for use in C<connect> (or C<bind>). 528C<$sockaddr> for use in C<connect> (or C<bind>).
360 529
368 537
369sub resolve_sockaddr($$$$$$) { 538sub resolve_sockaddr($$$$$$) {
370 my ($node, $service, $proto, $family, $type, $cb) = @_; 539 my ($node, $service, $proto, $family, $type, $cb) = @_;
371 540
372 if ($node eq "unix/") { 541 if ($node eq "unix/") {
373 return $cb->() if $family || !/^\//; # no can do 542 return $cb->() if $family || $service !~ /^\//; # no can do
374 543
375 return $cb->([AF_UNIX, $type, 0, Socket::pack_sockaddr_un $service]); 544 return $cb->([AF_UNIX, defined $type ? $type : SOCK_STREAM, 0, Socket::pack_sockaddr_un $service]);
376 } 545 }
377 546
378 unless (AF_INET6) { 547 unless (AF_INET6) {
379 $family != 6 548 $family != 6
380 or return $cb->(); 549 or return $cb->();
389 $family ||= 6 unless $AnyEvent::PROTOCOL{ipv4}; 558 $family ||= 6 unless $AnyEvent::PROTOCOL{ipv4};
390 559
391 $proto ||= "tcp"; 560 $proto ||= "tcp";
392 $type ||= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM; 561 $type ||= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;
393 562
394 my $proton = (getprotobyname $proto)[2] 563 my $proton = getprotobyname $proto
395 or Carp::croak "$proto: protocol unknown"; 564 or Carp::croak "$proto: protocol unknown";
396 565
397 my $port; 566 my $port;
398 567
399 if ($service =~ /^(\S+)=(\d+)$/) { 568 if ($service =~ /^(\S+)=(\d+)$/) {
424 $cv->begin; 593 $cv->begin;
425 for my $idx (0 .. $#target) { 594 for my $idx (0 .. $#target) {
426 my ($node, $port) = @{ $target[$idx] }; 595 my ($node, $port) = @{ $target[$idx] };
427 596
428 if (my $noden = parse_address $node) { 597 if (my $noden = parse_address $node) {
598 my $af = address_family $noden;
599
429 if (4 == length $noden && $family != 6) { 600 if ($af == AF_INET && $family != 6) {
430 push @res, [$idx, "ipv4", [AF_INET, $type, $proton, 601 push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
431 pack_sockaddr $port, $noden]] 602 pack_sockaddr $port, $noden]]
432 } 603 }
433 604
434 if (16 == length $noden && $family != 4) { 605 if ($af == AF_INET6 && $family != 4) {
435 push @res, [$idx, "ipv6", [AF_INET6, $type, $proton, 606 push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,
436 pack_sockaddr $port, $noden]] 607 pack_sockaddr $port, $noden]]
437 } 608 }
438 } else { 609 } else {
439 # ipv4 610 # ipv4
440 if ($family != 6) { 611 if ($family != 6) {
441 $cv->begin; 612 $cv->begin;
442 a $node, sub { 613 AnyEvent::DNS::a $node, sub {
443 push @res, [$idx, "ipv4", [AF_INET, $type, $proton, 614 push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
444 pack_sockaddr $port, parse_ipv4 $_]] 615 pack_sockaddr $port, parse_ipv4 $_]]
445 for @_; 616 for @_;
446 $cv->end; 617 $cv->end;
447 }; 618 };
448 } 619 }
449 620
450 # ipv6 621 # ipv6
451 if ($family != 4) { 622 if ($family != 4) {
452 $cv->begin; 623 $cv->begin;
453 aaaa $node, sub { 624 AnyEvent::DNS::aaaa $node, sub {
454 push @res, [$idx, "ipv6", [AF_INET6, $type, $proton, 625 push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,
455 pack_sockaddr $port, parse_ipv6 $_]] 626 pack_sockaddr $port, parse_ipv6 $_]]
456 for @_; 627 for @_;
457 $cv->end; 628 $cv->end;
458 }; 629 };
465 # try srv records, if applicable 636 # try srv records, if applicable
466 if ($node eq "localhost") { 637 if ($node eq "localhost") {
467 @target = (["127.0.0.1", $port], ["::1", $port]); 638 @target = (["127.0.0.1", $port], ["::1", $port]);
468 &$resolve; 639 &$resolve;
469 } elsif (defined $service && !parse_address $node) { 640 } elsif (defined $service && !parse_address $node) {
470 srv $service, $proto, $node, sub { 641 AnyEvent::DNS::srv $service, $proto, $node, sub {
471 my (@srv) = @_; 642 my (@srv) = @_;
472 643
473 # no srv records, continue traditionally 644 # no srv records, continue traditionally
474 @srv 645 @srv
475 or return &$resolve; 646 or return &$resolve;
476 647
477 # only srv record has "." => abort 648 # the only srv record has "." ("" here) => abort
478 $srv[0][2] ne "." || $#srv 649 $srv[0][2] ne "" || $#srv
479 or return $cb->(); 650 or return $cb->();
480 651
481 # use srv records then 652 # use srv records then
482 @target = map ["$_->[3].", $_->[2]], 653 @target = map ["$_->[3].", $_->[2]],
483 grep $_->[3] ne ".", 654 grep $_->[3] ne ".",
548lessen the impact of this windows bug, a default timeout of 30 seconds 719lessen the impact of this windows bug, a default timeout of 30 seconds
549will be imposed on windows. Cygwin is not affected. 720will be imposed on windows. Cygwin is not affected.
550 721
551Simple Example: connect to localhost on port 22. 722Simple Example: connect to localhost on port 22.
552 723
553 tcp_connect localhost => 22, sub { 724 tcp_connect localhost => 22, sub {
554 my $fh = shift 725 my $fh = shift
555 or die "unable to connect: $!"; 726 or die "unable to connect: $!";
556 # do something 727 # do something
557 }; 728 };
558 729
559Complex Example: connect to www.google.com on port 80 and make a simple 730Complex Example: connect to www.google.com on port 80 and make a simple
560GET request without much error handling. Also limit the connection timeout 731GET request without much error handling. Also limit the connection timeout
561to 15 seconds. 732to 15 seconds.
562 733
566 or die "unable to connect: $!"; 737 or die "unable to connect: $!";
567 738
568 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.
569 $handle = new AnyEvent::Handle 740 $handle = new AnyEvent::Handle
570 fh => $fh, 741 fh => $fh,
742 on_error => sub {
743 warn "error $_[2]\n";
744 $_[0]->destroy;
745 },
571 on_eof => sub { 746 on_eof => sub {
572 undef $handle; # keep it alive till eof 747 $handle->destroy; # destroy handle
573 warn "done.\n"; 748 warn "done.\n";
574 }; 749 };
575 750
576 $handle->push_write ("GET / HTTP/1.0\015\012\015\012"); 751 $handle->push_write ("GET / HTTP/1.0\015\012\015\012");
577 752
609 # also http://advogato.org/article/672.html 784 # also http://advogato.org/article/672.html
610 785
611 my %state = ( fh => undef ); 786 my %state = ( fh => undef );
612 787
613 # name/service to type/sockaddr resolution 788 # name/service to type/sockaddr resolution
614 resolve_sockaddr $host, $port, 0, 0, 0, sub { 789 resolve_sockaddr $host, $port, 0, 0, undef, sub {
615 my @target = @_; 790 my @target = @_;
616 791
617 $state{next} = sub { 792 $state{next} = sub {
618 return unless exists $state{fh}; 793 return unless exists $state{fh};
619 794
620 my $target = shift @target 795 my $target = shift @target
621 or do {
622 %state = ();
623 return $connect->(); 796 or return (%state = (), $connect->());
624 };
625 797
626 my ($domain, $type, $proto, $sockaddr) = @$target; 798 my ($domain, $type, $proto, $sockaddr) = @$target;
627 799
628 # socket creation 800 # socket creation
629 socket $state{fh}, $domain, $type, $proto 801 socket $state{fh}, $domain, $type, $proto
634 my $timeout = $prepare && $prepare->($state{fh}); 806 my $timeout = $prepare && $prepare->($state{fh});
635 807
636 $timeout ||= 30 if AnyEvent::WIN32; 808 $timeout ||= 30 if AnyEvent::WIN32;
637 809
638 $state{to} = AnyEvent->timer (after => $timeout, cb => sub { 810 $state{to} = AnyEvent->timer (after => $timeout, cb => sub {
639 $! = &Errno::ETIMEDOUT; 811 $! = Errno::ETIMEDOUT;
640 $state{next}(); 812 $state{next}();
641 }) if $timeout; 813 }) if $timeout;
642 814
643 # called when the connect was successful, which, 815 # called when the connect was successful, which,
644 # 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)
645 my $connected = sub { 817 $state{connected} = sub {
646 delete $state{ww};
647 delete $state{to};
648
649 # we are connected, or maybe there was an error 818 # we are connected, or maybe there was an error
650 if (my $sin = getpeername $state{fh}) { 819 if (my $sin = getpeername $state{fh}) {
651 my ($port, $host) = unpack_sockaddr $sin; 820 my ($port, $host) = unpack_sockaddr $sin;
652 821
822 delete $state{ww}; delete $state{to};
823
653 my $guard = guard { 824 my $guard = guard { %state = () };
654 %state = ();
655 };
656 825
657 $connect->($state{fh}, format_address $host, $port, sub { 826 $connect->(delete $state{fh}, format_address $host, $port, sub {
658 $guard->cancel; 827 $guard->cancel;
659 $state{next}(); 828 $state{next}();
660 }); 829 });
661 } else { 830 } else {
662 # dummy read to fetch real error code 831 # dummy read to fetch real error code
663 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
664 $state{next}(); 838 $state{next}();
665 } 839 }
666 }; 840 };
667 841
668 # now connect 842 # now connect
669 if (connect $state{fh}, $sockaddr) { 843 if (connect $state{fh}, $sockaddr) {
670 $connected->(); 844 $state{connected}->();
671 } elsif ($! == &Errno::EINPROGRESS # POSIX 845 } elsif ($! == Errno::EINPROGRESS # POSIX
672 || $! == &Errno::EWOULDBLOCK 846 || $! == Errno::EWOULDBLOCK
673 # WSAEINPROGRESS intentionally not checked - it means something else entirely 847 # WSAEINPROGRESS intentionally not checked - it means something else entirely
674 || $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt 848 || $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt
675 || $! == AnyEvent::Util::WSAEWOULDBLOCK) { 849 || $! == AnyEvent::Util::WSAEWOULDBLOCK) {
676 $state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $connected); 850 $state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $state{connected});
677 } else { 851 } else {
678 $state{next}(); 852 $state{next}();
679 } 853 }
680 }; 854 };
681 855
682 $! = &Errno::ENXIO; 856 $! = Errno::ENXIO;
683 $state{next}(); 857 $state{next}();
684 }; 858 };
685 859
686 defined wantarray && guard { %state = () } 860 defined wantarray && guard { %state = () }
687} 861}
691Create and bind a stream socket to the given host, and port, set the 865Create and bind a stream socket to the given host, and port, set the
692SO_REUSEADDR flag (if applicable) and call C<listen>. Unlike the name 866SO_REUSEADDR flag (if applicable) and call C<listen>. Unlike the name
693implies, this function can also bind on UNIX domain sockets. 867implies, this function can also bind on UNIX domain sockets.
694 868
695For internet sockets, C<$host> must be an IPv4 or IPv6 address (or 869For internet sockets, C<$host> must be an IPv4 or IPv6 address (or
696C<undef>, in which case it binds either to C<0> or to C<::>, depending on 870C<undef>, in which case it binds either to C<0> or to C<::>, depending
697whether IPv4 or IPv6 is the preferred protocol). 871on whether IPv4 or IPv6 is the preferred protocol, and maybe to both in
872future versions, as applicable).
698 873
699To bind to the IPv4 wildcard address, use C<0>, to bind to the IPv6 874To bind to the IPv4 wildcard address, use C<0>, to bind to the IPv6
700wildcard address, use C<::>. 875wildcard address, use C<::>.
701 876
702The port is specified by C<$service>, which must be either a service name or 877The port is specified by C<$service>, which must be either a service name or
726address and port number of the local socket endpoint as second and third 901address and port number of the local socket endpoint as second and third
727arguments. 902arguments.
728 903
729It should return the length of the listen queue (or C<0> for the default). 904It should return the length of the listen queue (or C<0> for the default).
730 905
906Note to IPv6 users: RFC-compliant behaviour for IPv6 sockets listening on
907C<::> is to bind to both IPv6 and IPv4 addresses by default on dual-stack
908hosts. Unfortunately, only GNU/Linux seems to implement this properly, so
909if you want both IPv4 and IPv6 listening sockets you should create the
910IPv6 socket first and then attempt to bind on the IPv4 socket, but ignore
911any C<EADDRINUSE> errors.
912
731Example: bind on some TCP port on the local machine and tell each client 913Example: bind on some TCP port on the local machine and tell each client
732to go away. 914to go away.
733 915
734 tcp_server undef, undef, sub { 916 tcp_server undef, undef, sub {
735 my ($fh, $host, $port) = @_; 917 my ($fh, $host, $port) = @_;
736 918
737 syswrite $fh, "The internet is full, $host:$port. Go away!\015\012"; 919 syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";
738 }, sub { 920 }, sub {
739 my ($fh, $thishost, $thisport) = @_; 921 my ($fh, $thishost, $thisport) = @_;
740 warn "bound to $thishost, port $thisport\n"; 922 warn "bound to $thishost, port $thisport\n";
923 };
924
925Example: bind a server on a unix domain socket.
926
927 tcp_server "unix/", "/tmp/mydir/mysocket", sub {
928 my ($fh) = @_;
741 }; 929 };
742 930
743=cut 931=cut
744 932
745sub tcp_server($$$;$) { 933sub tcp_server($$$;$) {
810 998
8111; 9991;
812 1000
813=back 1001=back
814 1002
1003=head1 SECURITY CONSIDERATIONS
1004
1005This module is quite powerful, with with power comes the ability to abuse
1006as well: If you accept "hostnames" and ports from untrusted sources,
1007then note that this can be abused to delete files (host=C<unix/>). This
1008is not really a problem with this module, however, as blindly accepting
1009any address and protocol and trying to bind a server or connect to it is
1010harmful in general.
1011
815=head1 AUTHOR 1012=head1 AUTHOR
816 1013
817 Marc Lehmann <schmorp@schmorp.de> 1014 Marc Lehmann <schmorp@schmorp.de>
818 http://home.schmorp.de/ 1015 http://home.schmorp.de/
819 1016

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines