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.28 by root, Mon May 26 05:09:53 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
38no warnings; 38no warnings;
39use strict; 39use strict;
40 40
41use Carp (); 41use Carp ();
42use Errno (); 42use Errno ();
43use Socket qw(AF_INET SOCK_STREAM SOCK_DGRAM SOL_SOCKET SO_REUSEADDR); 43use Socket qw(AF_INET AF_UNIX SOCK_STREAM SOCK_DGRAM SOL_SOCKET SO_REUSEADDR);
44 44
45use AnyEvent qw(WIN32); 45use AnyEvent ();
46use AnyEvent::Util qw(guard fh_nonblocking AF_INET6); 46use AnyEvent::Util qw(guard fh_nonblocking AF_INET6);
47use AnyEvent::DNS (); 47use AnyEvent::DNS ();
48 48
49use base 'Exporter'; 49use base 'Exporter';
50 50
51our @EXPORT = qw(parse_ipv4 parse_ipv6 parse_ip format_ip inet_aton tcp_server tcp_connect); 51our @EXPORT = qw(
52 parse_ipv4 parse_ipv6
53 parse_ip parse_address
54 format_ip format_address
55 address_family
56 inet_aton
57 tcp_server
58 tcp_connect
59);
52 60
53our $VERSION = '1.0'; 61our $VERSION = 4.14;
54 62
55=item $ipn = parse_ipv4 $dotted_quad 63=item $ipn = parse_ipv4 $dotted_quad
56 64
57Tries 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
58octet 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
128 136
129 # and done 137 # and done
130 pack "n*", map hex, @h, @t 138 pack "n*", map hex, @h, @t
131} 139}
132 140
141sub parse_unix($) {
142 $_[0] eq "unix/"
143 ? pack "S", AF_UNIX
144 : undef
145
146}
147
133=item $ipn = parse_ip $text 148=item $ipn = parse_address $text
134 149
135Combines C<parse_ipv4> and C<parse_ipv6> in one function. 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
152(binary).
136 153
137=cut 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
156socket".
138 157
158=cut
159
139sub parse_ip($) { 160sub parse_address($) {
140 &parse_ipv4 || &parse_ipv6 161 &parse_ipv4 || &parse_ipv6 || &parse_unix
141} 162}
142 163
164*parse_ip =\&parse_address; #d#
165
166=item $sa_family = address_family $ipn
167
168Returns the address family/protocol-family (AF_xxx/PF_xxx, in one value :)
169of the given host address in network format.
170
171=cut
172
173sub address_family($) {
174 4 == length $_[0]
175 ? AF_INET
176 : 16 == length $_[0]
177 ? AF_INET6
178 : unpack "S", $_[0]
179}
180
143=item $text = format_ip $ipn 181=item $text = format_address $ipn
144 182
145Takes either an IPv4 address (4 octets) or and IPv6 address (16 octets) 183Covnvert a host address in network format (e.g. 4 octets for IPv4 or 16
146and converts it into textual form. 184octets for IPv6) and convert it into textual form.
185
186Returns C<unix/> for UNIX domain sockets.
147 187
148This function works similarly to C<inet_ntop AF_INET || AF_INET6, ...>, 188This function works similarly to C<inet_ntop AF_INET || AF_INET6, ...>,
149except it automatically detects the address type. 189except it automatically detects the address type.
150 190
151=cut 191Returns C<undef> if it cannot detect the type.
152 192
153sub format_ip; 193=cut
194
195sub format_address;
154sub format_ip($) { 196sub format_address($) {
155 if (4 == length $_[0]) { 197 my $af = address_family $_[0];
198 if ($af == AF_INET) {
156 return join ".", unpack "C4", $_[0] 199 return join ".", unpack "C4", $_[0]
157 } elsif (16 == length $_[0]) { 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";
205 } elsif (v0.0.0.0.0.0.0.0.0.0.0.0 eq substr $_[0], 0, 12) {
206 # v4compatible
207 return "::" . format_address substr $_[0], 12;
158 if (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) {
159 # v4mapped 209 # v4mapped
160 return "::ffff:" . format_ip substr $_[0], 12; 210 return "::ffff:" . format_address substr $_[0], 12;
211 } elsif (v0.0.0.0.0.0.0.0.255.255.0.0 eq substr $_[0], 0, 12) {
212 # v4translated
213 return "::ffff:0:" . format_address substr $_[0], 12;
161 } else { 214 } else {
162 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];
163 216
217 # this is rather sucky, I admit
164 $ip =~ s/^0:(?:0:)*(0$)?/::/ 218 $ip =~ s/^0:(?:0:)*(0$)?/::/
165 or $ip =~ s/(:0)+$/::/ 219 or $ip =~ s/(:0){7}$/::/ or $ip =~ s/(:0){7}/:/
166 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}/:/;
167 return $ip 226 return $ip
168 } 227 }
228 } elsif ($af == AF_UNIX) {
229 return "unix/"
169 } else { 230 } else {
170 return undef 231 return undef
171 } 232 }
172} 233}
234
235*format_ip = \&format_address;
173 236
174=item inet_aton $name_or_address, $cb->(@addresses) 237=item inet_aton $name_or_address, $cb->(@addresses)
175 238
176Works similarly to its Socket counterpart, except that it uses a 239Works similarly to its Socket counterpart, except that it uses a
177callback. Also, if a host has only an IPv6 address, this might be passed 240callback. Also, if a host has only an IPv6 address, this might be passed
178to the callback instead (use the length to detect this - 4 for IPv4, 16 241to the callback instead (use the length to detect this - 4 for IPv4, 16
179for IPv6). 242for IPv6).
180 243
181Unlike the L<Socket> function of the same name, you can get multiple IPv4 244Unlike the L<Socket> function of the same name, you can get multiple IPv4
182and IPv6 addresses as result. 245and IPv6 addresses as result (and maybe even other adrdess types).
183 246
184=cut 247=cut
185 248
186sub inet_aton { 249sub inet_aton {
187 my ($name, $cb) = @_; 250 my ($name, $cb) = @_;
205 } 268 }
206 }); 269 });
207 } 270 }
208} 271}
209 272
273# check for broken platforms with extra field in sockaddr structure
274# kind of a rfc vs. bsd issue, as usual (ok, normally it's a
275# unix vs. bsd issue, a iso C vs. bsd issue or simply a
276# correctness vs. bsd issue.
277my $pack_family = (0x55 == Socket::sockaddr_family "\x55\x55")
278 ? "xC" : "S";
279
210=item $sa = AnyEvent::Socket::pack_sockaddr $port, $host 280=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host
211 281
212Pack the given port/host combination into a binary sockaddr structure. Handles 282Pack the given port/host combination into a binary sockaddr
213both IPv4 and IPv6 host addresses. 283structure. Handles both IPv4 and IPv6 host addresses, as well as UNIX
284domain sockets (C<$host> == C<unix/> and C<$service> == absolute
285pathname).
214 286
215=cut 287=cut
216 288
217sub pack_sockaddr($$) { 289sub pack_sockaddr($$) {
218 if (4 == length $_[1]) { 290 my $af = address_family $_[1];
291
292 if ($af == AF_INET) {
219 Socket::pack_sockaddr_in $_[0], $_[1] 293 Socket::pack_sockaddr_in $_[0], $_[1]
220 } elsif (16 == length $_[1]) { 294 } elsif ($af == AF_INET6) {
221 pack "SnL a16 L", 295 pack "$pack_family nL a16 L",
222 AF_INET6, 296 AF_INET6,
223 $_[0], # port 297 $_[0], # port
224 0, # flowinfo 298 0, # flowinfo
225 $_[1], # addr 299 $_[1], # addr
226 0 # scope id 300 0 # scope id
301 } elsif ($af == AF_UNIX) {
302 Socket::pack_sockaddr_un $_[0]
227 } else { 303 } else {
228 Carp::croak "pack_sockaddr: invalid host"; 304 Carp::croak "pack_sockaddr: invalid host";
229 } 305 }
230} 306}
231 307
232=item ($port, $host) = AnyEvent::Socket::unpack_sockaddr $sa 308=item ($service, $host) = AnyEvent::Socket::unpack_sockaddr $sa
233 309
234Unpack the given binary sockaddr structure (as used by bind, getpeername 310Unpack the given binary sockaddr structure (as used by bind, getpeername
235etc.) into a C<$port, $host> combination. 311etc.) into a C<$service, $host> combination.
236 312
237Handles both IPv4 and IPv6 sockaddr structures. 313For IPv4 and IPv6, C<$service> is the port number and C<$host> the host
314address in network format (binary).
315
316For UNIX domain sockets, C<$service> is the absolute pathname and C<$host>
317is a special token that is understood by the other functions in this
318module (C<format_address> converts it to C<unix/>).
238 319
239=cut 320=cut
240 321
241sub unpack_sockaddr($) { 322sub unpack_sockaddr($) {
242 my $af = unpack "S", $_[0]; 323 my $af = Socket::sockaddr_family $_[0];
243 324
244 if ($af == AF_INET) { 325 if ($af == AF_INET) {
245 Socket::unpack_sockaddr_in $_[0] 326 Socket::unpack_sockaddr_in $_[0]
246 } elsif ($af == AF_INET6) { 327 } elsif ($af == AF_INET6) {
247 unpack "x2 n x4 a16", $_[0] 328 unpack "x2 n x4 a16", $_[0]
329 } elsif ($af == AF_UNIX) {
330 ((Socket::unpack_sockaddr_un $_[0]), pack "S", AF_UNIX)
248 } else { 331 } else {
249 Carp::croak "unpack_sockaddr: unsupported protocol family $af"; 332 Carp::croak "unpack_sockaddr: unsupported protocol family $af";
250 } 333 }
251} 334}
252 335
253sub _tcp_port($) { 336=item resolve_sockaddr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...)
254 $_[0] =~ /^(\d*)$/ and return $1*1;
255 337
256 (getservbyname $_[0], "tcp")[2] 338Tries to resolve the given nodename and service name into protocol families
339and sockaddr structures usable to connect to this node and service in a
340protocol-independent way. It works remotely similar to the getaddrinfo
341posix function.
342
343For internet addresses, C<$node> is either an IPv4 or IPv6 address or an
344internet hostname, and C<$service> is either a service name (port name
345from F</etc/services>) or a numerical port number. If both C<$node> and
346C<$service> are names, then SRV records will be consulted to find the real
347service, otherwise they will be used as-is. If you know that the service
348name is not in your services database, then you can specify the service in
349the format C<name=port> (e.g. C<http=80>).
350
351For UNIX domain sockets, C<$node> must be the string C<unix/> and
352C<$service> must be the absolute pathname of the socket. In this case,
353C<$proto> will be ignored.
354
355C<$proto> must be a protocol name, currently C<tcp>, C<udp> or
356C<sctp>. The default is currently C<tcp>, but in the future, this function
357might try to use other protocols such as C<sctp>, depending on the socket
358type and any SRV records it might find.
359
360C<$family> must be either C<0> (meaning any protocol is OK), C<4> (use
361only IPv4) or C<6> (use only IPv6). This setting might be influenced by
362C<$ENV{PERL_ANYEVENT_PROTOCOLS}>.
363
364C<$type> must be C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_SEQPACKET> (or
365C<undef> in which case it gets automatically chosen).
366
367The callback will receive zero or more array references that contain
368C<$family, $type, $proto> for use in C<socket> and a binary
369C<$sockaddr> for use in C<connect> (or C<bind>).
370
371The application should try these in the order given.
372
373Example:
374
375 resolve_sockaddr "google.com", "http", 0, undef, undef, sub { ... };
376
377=cut
378
379sub resolve_sockaddr($$$$$$) {
380 my ($node, $service, $proto, $family, $type, $cb) = @_;
381
382 if ($node eq "unix/") {
383 return $cb->() if $family || !/^\//; # no can do
384
385 return $cb->([AF_UNIX, $type, 0, Socket::pack_sockaddr_un $service]);
386 }
387
388 unless (AF_INET6) {
389 $family != 6
390 or return $cb->();
391
392 $family = 4;
393 }
394
395 $cb->() if $family == 4 && !$AnyEvent::PROTOCOL{ipv4};
396 $cb->() if $family == 6 && !$AnyEvent::PROTOCOL{ipv6};
397
398 $family ||= 4 unless $AnyEvent::PROTOCOL{ipv6};
399 $family ||= 6 unless $AnyEvent::PROTOCOL{ipv4};
400
401 $proto ||= "tcp";
402 $type ||= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;
403
404 my $proton = (getprotobyname $proto)[2]
257 or Carp::croak "$_[0]: service unknown" 405 or Carp::croak "$proto: protocol unknown";
406
407 my $port;
408
409 if ($service =~ /^(\S+)=(\d+)$/) {
410 ($service, $port) = ($1, $2);
411 } elsif ($service =~ /^\d+$/) {
412 ($service, $port) = (undef, $service);
413 } else {
414 $port = (getservbyname $service, $proto)[2]
415 or Carp::croak "$service/$proto: service unknown";
416 }
417
418 my @target = [$node, $port];
419
420 # resolve a records / provide sockaddr structures
421 my $resolve = sub {
422 my @res;
423 my $cv = AnyEvent->condvar (cb => sub {
424 $cb->(
425 map $_->[2],
426 sort {
427 $AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]}
428 or $a->[0] <=> $b->[0]
429 }
430 @res
431 )
432 });
433
434 $cv->begin;
435 for my $idx (0 .. $#target) {
436 my ($node, $port) = @{ $target[$idx] };
437
438 if (my $noden = parse_address $node) {
439 my $af = address_family $noden;
440
441 if ($af == AF_INET && $family != 6) {
442 push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
443 pack_sockaddr $port, $noden]]
444 }
445
446 if ($af == AF_INET6 && $family != 4) {
447 push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,
448 pack_sockaddr $port, $noden]]
449 }
450 } else {
451 # ipv4
452 if ($family != 6) {
453 $cv->begin;
454 AnyEvent::DNS::a $node, sub {
455 push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
456 pack_sockaddr $port, parse_ipv4 $_]]
457 for @_;
458 $cv->end;
459 };
460 }
461
462 # ipv6
463 if ($family != 4) {
464 $cv->begin;
465 AnyEvent::DNS::aaaa $node, sub {
466 push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,
467 pack_sockaddr $port, parse_ipv6 $_]]
468 for @_;
469 $cv->end;
470 };
471 }
472 }
473 }
474 $cv->end;
475 };
476
477 # try srv records, if applicable
478 if ($node eq "localhost") {
479 @target = (["127.0.0.1", $port], ["::1", $port]);
480 &$resolve;
481 } elsif (defined $service && !parse_address $node) {
482 AnyEvent::DNS::srv $service, $proto, $node, sub {
483 my (@srv) = @_;
484
485 # no srv records, continue traditionally
486 @srv
487 or return &$resolve;
488
489 # the only srv record has "." ("" here) => abort
490 $srv[0][2] ne "" || $#srv
491 or return $cb->();
492
493 # use srv records then
494 @target = map ["$_->[3].", $_->[2]],
495 grep $_->[3] ne ".",
496 @srv;
497
498 &$resolve;
499 };
500 } else {
501 &$resolve;
502 }
258} 503}
259 504
260=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb] 505=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]
261 506
262This is a convenience function that creates a TCP socket and makes a 100% 507This is a convenience function that creates a TCP socket and makes a 100%
263non-blocking connect to the given C<$host> (which can be a hostname or a 508non-blocking connect to the given C<$host> (which can be a hostname or
509a textual IP address, or the string C<unix/> for UNIX domain sockets)
264textual IP address) and C<$service> (which can be a numeric port number or 510and C<$service> (which can be a numeric port number or a service name,
265a service name, or a C<servicename=portnumber> string). 511or a C<servicename=portnumber> string, or the pathname to a UNIX domain
512socket).
266 513
267If both C<$host> and C<$port> are names, then this function will use SRV 514If both C<$host> and C<$port> are names, then this function will use SRV
268records to locate the real target(s). 515records to locate the real target(s).
269 516
270In either case, it will create a list of target hosts (e.g. for multihomed 517In either case, it will create a list of target hosts (e.g. for multihomed
313lessen 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
314will be imposed on windows. Cygwin is not affected. 561will be imposed on windows. Cygwin is not affected.
315 562
316Simple Example: connect to localhost on port 22. 563Simple Example: connect to localhost on port 22.
317 564
318 tcp_connect localhost => 22, sub { 565 tcp_connect localhost => 22, sub {
319 my $fh = shift 566 my $fh = shift
320 or die "unable to connect: $!"; 567 or die "unable to connect: $!";
321 # do something 568 # do something
322 }; 569 };
323 570
324Complex 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
325GET request without much error handling. Also limit the connection timeout 572GET request without much error handling. Also limit the connection timeout
326to 15 seconds. 573to 15 seconds.
327 574
357 # could call $fh->bind etc. here 604 # could call $fh->bind etc. here
358 605
359 15 606 15
360 }; 607 };
361 608
609Example: connect to a UNIX domain socket.
610
611 tcp_connect "unix/", "/tmp/.X11-unix/X0", sub {
612 ...
613 }
614
362=cut 615=cut
363 616
364sub tcp_connect($$$;$) { 617sub tcp_connect($$$;$) {
365 my ($host, $port, $connect, $prepare) = @_; 618 my ($host, $port, $connect, $prepare) = @_;
366 619
367 # see http://cr.yp.to/docs/connect.html for some background 620 # see http://cr.yp.to/docs/connect.html for some background
621 # also http://advogato.org/article/672.html
368 622
369 my %state = ( fh => undef ); 623 my %state = ( fh => undef );
370 624
371 # name resolution 625 # name/service to type/sockaddr resolution
372 AnyEvent::DNS::addr $host, $port, 0, 0, 0, sub { 626 resolve_sockaddr $host, $port, 0, 0, 0, sub {
373 my @target = @_; 627 my @target = @_;
374 628
375 $state{next} = sub { 629 $state{next} = sub {
376 return unless exists $state{fh}; 630 return unless exists $state{fh};
377 631
389 643
390 fh_nonblocking $state{fh}, 1; 644 fh_nonblocking $state{fh}, 1;
391 645
392 my $timeout = $prepare && $prepare->($state{fh}); 646 my $timeout = $prepare && $prepare->($state{fh});
393 647
394 $timeout ||= 30 if WIN32; 648 $timeout ||= 30 if AnyEvent::WIN32;
395 649
396 $state{to} = AnyEvent->timer (after => $timeout, cb => sub { 650 $state{to} = AnyEvent->timer (after => $timeout, cb => sub {
397 $! = &Errno::ETIMEDOUT; 651 $! = &Errno::ETIMEDOUT;
398 $state{next}(); 652 $state{next}();
399 }) if $timeout; 653 }) if $timeout;
410 664
411 my $guard = guard { 665 my $guard = guard {
412 %state = (); 666 %state = ();
413 }; 667 };
414 668
415 $connect->($state{fh}, format_ip $host, $port, sub { 669 $connect->($state{fh}, format_address $host, $port, sub {
416 $guard->cancel; 670 $guard->cancel;
417 $state{next}(); 671 $state{next}();
418 }); 672 });
419 } else { 673 } else {
420 # dummy read to fetch real error code 674 # dummy read to fetch real error code
424 }; 678 };
425 679
426 # now connect 680 # now connect
427 if (connect $state{fh}, $sockaddr) { 681 if (connect $state{fh}, $sockaddr) {
428 $connected->(); 682 $connected->();
429 } elsif ($! == &Errno::EINPROGRESS || $! == &Errno::EWOULDBLOCK) { # EINPROGRESS is POSIX 683 } elsif ($! == &Errno::EINPROGRESS # POSIX
684 || $! == &Errno::EWOULDBLOCK
685 # WSAEINPROGRESS intentionally not checked - it means something else entirely
686 || $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt
687 || $! == AnyEvent::Util::WSAEWOULDBLOCK) {
430 $state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $connected); 688 $state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $connected);
431 } else { 689 } else {
432 %state = (); 690 $state{next}();
433 $connect->();
434 } 691 }
435 }; 692 };
436 693
437 $! = &Errno::ENXIO; 694 $! = &Errno::ENXIO;
438 $state{next}(); 695 $state{next}();
439 }; 696 };
440 697
441 defined wantarray && guard { %state = () } 698 defined wantarray && guard { %state = () }
442} 699}
443 700
444=item $guard = tcp_server $host, $port, $accept_cb[, $prepare_cb] 701=item $guard = tcp_server $host, $service, $accept_cb[, $prepare_cb]
445 702
446Create 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
447SO_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.
448 706
449C<$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
450binds 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
451preferred protocol). 709on whether IPv4 or IPv6 is the preferred protocol, and maybe to both in
710future versions, as applicable).
452 711
453To 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
454wildcard address, use C<::>. 713wildcard address, use C<::>.
455 714
456The 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
457a 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
458port 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.
459 723
460For 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<<
461$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
462mode) 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
463(see C<tcp_connect> for details). 727(see C<tcp_connect> for details).
475address 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
476arguments. 740arguments.
477 741
478It 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).
479 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
480Example: 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
481to go away. 752to go away.
482 753
483 tcp_server undef, undef, sub { 754 tcp_server undef, undef, sub {
484 my ($fh, $host, $port) = @_; 755 my ($fh, $host, $port) = @_;
490 }; 761 };
491 762
492=cut 763=cut
493 764
494sub tcp_server($$$;$) { 765sub tcp_server($$$;$) {
495 my ($host, $port, $accept, $prepare) = @_; 766 my ($host, $service, $accept, $prepare) = @_;
496 767
497 $host = $AnyEvent::PROTOCOL{ipv4} < $AnyEvent::PROTOCOL{ipv6} && AF_INET6 768 $host = $AnyEvent::PROTOCOL{ipv4} < $AnyEvent::PROTOCOL{ipv6} && AF_INET6
498 ? "::" : "0" 769 ? "::" : "0"
499 unless defined $host; 770 unless defined $host;
500 771
501 my $ipn = parse_ip $host 772 my $ipn = parse_address $host
502 or Carp::croak "AnyEvent::Socket::tcp_server: cannot parse '$host' as IPv4 or IPv6 address"; 773 or Carp::croak "AnyEvent::Socket::tcp_server: cannot parse '$host' as host address";
503 774
504 my $domain = 4 == length $ipn ? AF_INET : AF_INET6; 775 my $af = address_family $ipn;
505 776
506 my %state; 777 my %state;
507 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
508 socket $state{fh}, $domain, SOCK_STREAM, 0 783 socket $state{fh}, $af, SOCK_STREAM, 0
509 or Carp::croak "socket: $!"; 784 or Carp::croak "tcp_server/socket: $!";
510 785
786 if ($af == AF_INET || $af == AF_INET6) {
511 setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1 787 setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1
512 or Carp::croak "so_reuseaddr: $!"; 788 or Carp::croak "tcp_server/so_reuseaddr: $!"
789 unless AnyEvent::WIN32; # work around windows bug
513 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
514 bind $state{fh}, pack_sockaddr _tcp_port $port, $ipn 799 bind $state{fh}, pack_sockaddr $service, $ipn
515 or Carp::croak "bind: $!"; 800 or Carp::croak "bind: $!";
516 801
517 fh_nonblocking $state{fh}, 1; 802 fh_nonblocking $state{fh}, 1;
518 803
519 my $len; 804 my $len;
520 805
521 if ($prepare) { 806 if ($prepare) {
522 my ($port, $host) = unpack_sockaddr getsockname $state{fh}; 807 my ($service, $host) = unpack_sockaddr getsockname $state{fh};
523 $len = $prepare && $prepare->($state{fh}, format_ip $host, $port); 808 $len = $prepare && $prepare->($state{fh}, format_address $host, $service);
524 } 809 }
525 810
526 $len ||= 128; 811 $len ||= 128;
527 812
528 listen $state{fh}, $len 813 listen $state{fh}, $len
530 815
531 $state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub { 816 $state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {
532 # this closure keeps $state alive 817 # this closure keeps $state alive
533 while (my $peer = accept my $fh, $state{fh}) { 818 while (my $peer = accept my $fh, $state{fh}) {
534 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
535 my ($port, $host) = unpack_sockaddr $peer; 821 my ($service, $host) = unpack_sockaddr $peer;
536 $accept->($fh, format_ip $host, $port); 822 $accept->($fh, format_address $host, $service);
537 } 823 }
538 }); 824 });
539 825
540 defined wantarray 826 defined wantarray
541 ? guard { %state = () } # clear fh and watcher, which breaks the circular dependency 827 ? guard { %state = () } # clear fh and watcher, which breaks the circular dependency
544 830
5451; 8311;
546 832
547=back 833=back
548 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
549=head1 AUTHOR 844=head1 AUTHOR
550 845
551 Marc Lehmann <schmorp@schmorp.de> 846 Marc Lehmann <schmorp@schmorp.de>
552 http://home.schmorp.de/ 847 http://home.schmorp.de/
553 848

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines