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.15 by root, Sat May 24 01:15:19 2008 UTC vs.
Revision 1.52 by root, Thu Jul 3 02:03:33 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
9 tcp_connect "gameserver.deliantra.net", 13327, sub {
10 my ($fh) = @_
11 or die "gameserver.deliantra.net connect failed: $!";
12
13 # enjoy your filehandle
14 };
15
16 # a simple tcp server
17 tcp_server undef, 8888, sub {
18 my ($fh, $host, $port) = @_;
19
20 syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";
21 };
8 22
9=head1 DESCRIPTION 23=head1 DESCRIPTION
10 24
11This module implements various utility functions for handling internet 25This module implements various utility functions for handling internet
12protocol addresses and sockets, in an as transparent and simple way as 26protocol addresses and sockets, in an as transparent and simple way as
… …
24no warnings; 38no warnings;
25use strict; 39use strict;
26 40
27use Carp (); 41use Carp ();
28use Errno (); 42use Errno ();
29use Socket (); 43use Socket qw(AF_INET AF_UNIX SOCK_STREAM SOCK_DGRAM SOL_SOCKET SO_REUSEADDR);
30 44
31use AnyEvent (); 45use AnyEvent ();
32use AnyEvent::Util qw(guard fh_nonblocking); 46use AnyEvent::Util qw(guard fh_nonblocking AF_INET6);
47use AnyEvent::DNS ();
33 48
34use base 'Exporter'; 49use base 'Exporter';
35 50
36BEGIN { 51our @EXPORT = qw(
37 *socket_inet_aton = \&Socket::inet_aton; # take a copy, in case Coro::LWP overrides it 52 parse_ipv4 parse_ipv6
38} 53 parse_ip parse_address
54 format_ip format_address
55 address_family
56 inet_aton
57 tcp_server
58 tcp_connect
59);
39 60
40BEGIN {
41 my $af_inet6 = eval { &Socket::AF_INET6 };
42 eval "sub AF_INET6() { $af_inet6 }"; die if $@;
43
44 delete $AnyEvent::PROTOCOL{ipv6} unless $af_inet6;
45}
46
47our @EXPORT = qw(parse_ipv4 parse_ipv6 parse_ip format_ip inet_aton tcp_server tcp_connect);
48
49our $VERSION = '1.0'; 61our $VERSION = 4.160;
50 62
51=item $ipn = parse_ipv4 $dotted_quad 63=item $ipn = parse_ipv4 $dotted_quad
52 64
53Tries 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
54octet 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
… …
66 78
67 # check leading parts against range 79 # check leading parts against range
68 return undef if grep $_ >= 256, @_[0 .. @_ - 2]; 80 return undef if grep $_ >= 256, @_[0 .. @_ - 2];
69 81
70 # check trailing part against range 82 # check trailing part against range
71 return undef if $_[-1] >= 1 << (8 * (4 - $#_)); 83 return undef if $_[-1] >= 2 ** (8 * (4 - $#_));
72 84
73 pack "N", (pop) 85 pack "N", (pop)
74 + ($_[0] << 24) 86 + ($_[0] << 24)
75 + ($_[1] << 16) 87 + ($_[1] << 16)
76 + ($_[2] << 8); 88 + ($_[2] << 8);
… …
80 92
81Tries to parse the given IPv6 address and return it in 93Tries to parse the given IPv6 address and return it in
82octet form (or undef when it isn't in a parsable format). 94octet form (or undef when it isn't in a parsable format).
83 95
84Should support all forms specified by RFC 2373 (and additionally all IPv4 96Should support all forms specified by RFC 2373 (and additionally all IPv4
85forms supported by parse_ipv4). 97forms supported by parse_ipv4). Note that scope-id's are not supported
98(and will not parse).
86 99
87This function works similarly to C<inet_pton AF_INET6, ...>. 100This function works similarly to C<inet_pton AF_INET6, ...>.
88 101
89=cut 102=cut
90 103
… …
123 136
124 # and done 137 # and done
125 pack "n*", map hex, @h, @t 138 pack "n*", map hex, @h, @t
126} 139}
127 140
141sub parse_unix($) {
142 $_[0] eq "unix/"
143 ? pack "S", AF_UNIX
144 : undef
145
146}
147
128=item $ipn = parse_ip $text 148=item $ipn = parse_address $text
129 149
130Combines 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).
131 153
132=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".
133 157
158=cut
159
134sub parse_ip($) { 160sub parse_address($) {
135 &parse_ipv4 || &parse_ipv6 161 &parse_ipv4 || &parse_ipv6 || &parse_unix
136} 162}
137 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
138=item $text = format_ip $ipn 181=item $text = format_address $ipn
139 182
140Takes 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
141and converts it into textual form. 184octets for IPv6) and convert it into textual form.
185
186Returns C<unix/> for UNIX domain sockets.
142 187
143This function works similarly to C<inet_ntop AF_INET || AF_INET6, ...>, 188This function works similarly to C<inet_ntop AF_INET || AF_INET6, ...>,
144except it automatically detects the address type. 189except it automatically detects the address type.
145 190
146=cut 191Returns C<undef> if it cannot detect the type.
147 192
148sub format_ip; 193=cut
194
195sub format_address;
149sub format_ip($) { 196sub format_address($) {
150 if (4 == length $_[0]) { 197 my $af = address_family $_[0];
198 if ($af == AF_INET) {
151 return join ".", unpack "C4", $_[0] 199 return join ".", unpack "C4", $_[0]
152 } 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;
153 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) {
154 # v4mapped 209 # v4mapped
155 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;
156 } else { 214 } else {
157 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];
158 216
217 # this is rather sucky, I admit
159 $ip =~ s/^0:(?:0:)*/::/ 218 $ip =~ s/^0:(?:0:)*(0$)?/::/
160 or $ip =~ s/(:0)+$/::/ 219 or $ip =~ s/(:0){7}$/::/ or $ip =~ s/(:0){7}/:/
161 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}/:/;
162 return $ip 226 return $ip
163 } 227 }
228 } elsif ($af == AF_UNIX) {
229 return "unix/"
164 } else { 230 } else {
165 return undef 231 return undef
166 } 232 }
167} 233}
234
235*format_ip = \&format_address;
168 236
169=item inet_aton $name_or_address, $cb->(@addresses) 237=item inet_aton $name_or_address, $cb->(@addresses)
170 238
171Works similarly to its Socket counterpart, except that it uses a 239Works similarly to its Socket counterpart, except that it uses a
172callback. 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
173to 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
174for IPv6). 242for IPv6).
175 243
176Unlike 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
177and IPv6 addresses as result. 245and IPv6 addresses as result (and maybe even other adrdess types).
178 246
179=cut 247=cut
180 248
181sub inet_aton { 249sub inet_aton {
182 my ($name, $cb) = @_; 250 my ($name, $cb) = @_;
… …
200 } 268 }
201 }); 269 });
202 } 270 }
203} 271}
204 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
205=item $sa = AnyEvent::Socket::pack_sockaddr $port, $host 280=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host
206 281
207Pack the given port/hst combination into a binary sockaddr structure. Handles 282Pack the given port/host combination into a binary sockaddr
208both 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).
209 286
210=cut 287=cut
211 288
212sub pack_sockaddr($$) { 289sub pack_sockaddr($$) {
213 if (4 == length $_[1]) { 290 my $af = address_family $_[1];
291
292 if ($af == AF_INET) {
214 Socket::pack_sockaddr_in $_[0], $_[1] 293 Socket::pack_sockaddr_in $_[0], $_[1]
215 } elsif (16 == length $_[1]) { 294 } elsif ($af == AF_INET6) {
216 pack "SSL a16 L", 295 pack "$pack_family nL a16 L",
217 Socket::AF_INET6, 296 AF_INET6,
218 $_[0], # port 297 $_[0], # port
219 0, # flowinfo 298 0, # flowinfo
220 $_[1], # addr 299 $_[1], # addr
221 0 # scope id 300 0 # scope id
301 } elsif ($af == AF_UNIX) {
302 Socket::pack_sockaddr_un $_[0]
222 } else { 303 } else {
223 Carp::croak "pack_sockaddr: invalid host"; 304 Carp::croak "pack_sockaddr: invalid host";
224 } 305 }
225} 306}
226 307
227=item ($port, $host) = AnyEvent::Socket::unpack_sockaddr $sa 308=item ($service, $host) = AnyEvent::Socket::unpack_sockaddr $sa
228 309
229Unpack the given binary sockaddr structure (as used by bind, getpeername 310Unpack the given binary sockaddr structure (as used by bind, getpeername
230etc.) into a C<$port, $host> combination. 311etc.) into a C<$service, $host> combination.
231 312
232Handles 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/>).
233 319
234=cut 320=cut
235 321
236sub unpack_sockaddr($) { 322sub unpack_sockaddr($) {
237 my $af = unpack "S", $_[0]; 323 my $af = Socket::sockaddr_family $_[0];
238 324
239 if ($af == &Socket::AF_INET) { 325 if ($af == AF_INET) {
240 Socket::unpack_sockaddr_in $_[0] 326 Socket::unpack_sockaddr_in $_[0]
241 } elsif ($af == AF_INET6) { 327 } elsif ($af == AF_INET6) {
242 (unpack "SSL a16 L")[1, 3] 328 unpack "x2 n x4 a16", $_[0]
329 } elsif ($af == AF_UNIX) {
330 ((Socket::unpack_sockaddr_un $_[0]), pack "S", AF_UNIX)
243 } else { 331 } else {
244 Carp::croak "unpack_sockaddr: unsupported protocol family $af"; 332 Carp::croak "unpack_sockaddr: unsupported protocol family $af";
245 } 333 }
246} 334}
247 335
248sub _tcp_port($) { 336=item resolve_sockaddr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...)
249 $_[0] =~ /^(\d*)$/ and return $1*1;
250 337
251 (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]
252 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 }
253} 503}
254 504
255=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb] 505=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]
256 506
257This 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%
258non-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)
259textual 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,
260a service name, or a C<servicename=portnumber> string). 511or a C<servicename=portnumber> string, or the pathname to a UNIX domain
512socket).
261 513
262If 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
263records to locate the real target(s). 515records to locate the real target(s).
264 516
265In 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
266hosts or hosts with both IPv4 and IPV6 addrsesses) and try to connetc to 518hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to
267each in turn. 519each in turn.
268 520
269If the connect is successful, then the C<$connect_cb> will be invoked with 521If the connect is successful, then the C<$connect_cb> will be invoked with
270the socket filehandle (in non-blocking mode) as first and the peer host 522the socket file handle (in non-blocking mode) as first and the peer host
271(as a textual IP address) and peer port as second and third arguments, 523(as a textual IP address) and peer port as second and third arguments,
272respectively. The fourth argument is a code reference that you can call 524respectively. The fourth argument is a code reference that you can call
273if, for some reason, you don't like this connection, which will cause 525if, for some reason, you don't like this connection, which will cause
274C<tcp_connect> to try the next one (or call your callback without any 526C<tcp_connect> to try the next one (or call your callback without any
275arguments if there are no more connections). In most cases, you can simply 527arguments if there are no more connections). In most cases, you can simply
… …
277 529
278 $cb->($filehandle, $host, $port, $retry) 530 $cb->($filehandle, $host, $port, $retry)
279 531
280If the connect is unsuccessful, then the C<$connect_cb> will be invoked 532If the connect is unsuccessful, then the C<$connect_cb> will be invoked
281without any arguments and C<$!> will be set appropriately (with C<ENXIO> 533without any arguments and C<$!> will be set appropriately (with C<ENXIO>
282indicating a dns resolution failure). 534indicating a DNS resolution failure).
283 535
284The filehandle is suitable to be plugged into L<AnyEvent::Handle>, but can 536The file handle is perfect for being plugged into L<AnyEvent::Handle>, but
285be used as a normal perl file handle as well. 537can be used as a normal perl file handle as well.
286 538
287Unless called in void context, C<tcp_connect> returns a guard object that 539Unless called in void context, C<tcp_connect> returns a guard object that
288will automatically abort connecting when it gets destroyed (it does not do 540will automatically abort connecting when it gets destroyed (it does not do
289anything to the socket after the connect was successful). 541anything to the socket after the connect was successful).
290 542
… …
294a second callback, C<$prepare_cb>. It will be called with the file handle 546a second callback, C<$prepare_cb>. It will be called with the file handle
295in not-yet-connected state as only argument and must return the connection 547in not-yet-connected state as only argument and must return the connection
296timeout value (or C<0>, C<undef> or the empty list to indicate the default 548timeout value (or C<0>, C<undef> or the empty list to indicate the default
297timeout is to be used). 549timeout is to be used).
298 550
299Note that the socket could be either a IPv4 TCP socket or an IPv6 tcp 551Note that the socket could be either a IPv4 TCP socket or an IPv6 TCP
300socket (although only IPv4 is currently supported by this module). 552socket (although only IPv4 is currently supported by this module).
301 553
554Note to the poor Microsoft Windows users: Windows (of course) doesn't
555correctly signal connection errors, so unless your event library works
556around this, failed connections will simply hang. The only event libraries
557that handle this condition correctly are L<EV> and L<Glib>. Additionally,
558AnyEvent works around this bug with L<Event> and in its pure-perl
559backend. All other libraries cannot correctly handle this condition. To
560lessen the impact of this windows bug, a default timeout of 30 seconds
561will be imposed on windows. Cygwin is not affected.
562
302Simple Example: connect to localhost on port 22. 563Simple Example: connect to localhost on port 22.
303 564
304 tcp_connect localhost => 22, sub { 565 tcp_connect localhost => 22, sub {
305 my $fh = shift 566 my $fh = shift
306 or die "unable to connect: $!"; 567 or die "unable to connect: $!";
307 # do something 568 # do something
308 }; 569 };
309 570
310Complex 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
311GET request without much error handling. Also limit the connection timeout 572GET request without much error handling. Also limit the connection timeout
312to 15 seconds. 573to 15 seconds.
313 574
… …
343 # could call $fh->bind etc. here 604 # could call $fh->bind etc. here
344 605
345 15 606 15
346 }; 607 };
347 608
609Example: connect to a UNIX domain socket.
610
611 tcp_connect "unix/", "/tmp/.X11-unix/X0", sub {
612 ...
613 }
614
348=cut 615=cut
349 616
350sub tcp_connect($$$;$) { 617sub tcp_connect($$$;$) {
351 my ($host, $port, $connect, $prepare) = @_; 618 my ($host, $port, $connect, $prepare) = @_;
352 619
353 # 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
354 622
355 my %state = ( fh => undef ); 623 my %state = ( fh => undef );
356 624
357 # name resolution 625 # name/service to type/sockaddr resolution
358 AnyEvent::DNS::addr $host, $port, 0, 0, 0, sub { 626 resolve_sockaddr $host, $port, 0, 0, 0, sub {
359 my @target = @_; 627 my @target = @_;
360 628
361 $state{next} = sub { 629 $state{next} = sub {
362 return unless exists $state{fh}; 630 return unless exists $state{fh};
363 631
… …
373 socket $state{fh}, $domain, $type, $proto 641 socket $state{fh}, $domain, $type, $proto
374 or return $state{next}(); 642 or return $state{next}();
375 643
376 fh_nonblocking $state{fh}, 1; 644 fh_nonblocking $state{fh}, 1;
377 645
378 # prepare and optional timeout
379 if ($prepare) {
380 my $timeout = $prepare->($state{fh}); 646 my $timeout = $prepare && $prepare->($state{fh});
381 647
648 $timeout ||= 30 if AnyEvent::WIN32;
649
382 $state{to} = AnyEvent->timer (after => $timeout, cb => sub { 650 $state{to} = AnyEvent->timer (after => $timeout, cb => sub {
383 $! = &Errno::ETIMEDOUT; 651 $! = &Errno::ETIMEDOUT;
384 $state{next}(); 652 $state{next}();
385 }) if $timeout; 653 }) if $timeout;
386 }
387 654
388 # called when the connect was successful, which, 655 # called when the connect was successful, which,
389 # in theory, could be the case immediately (but never is in practise) 656 # in theory, could be the case immediately (but never is in practise)
390 my $connected = sub { 657 my $connected = sub {
391 delete $state{ww}; 658 delete $state{ww};
… …
397 664
398 my $guard = guard { 665 my $guard = guard {
399 %state = (); 666 %state = ();
400 }; 667 };
401 668
402 $connect->($state{fh}, format_ip $host, $port, sub { 669 $connect->($state{fh}, format_address $host, $port, sub {
403 $guard->cancel; 670 $guard->cancel;
404 $state{next}(); 671 $state{next}();
405 }); 672 });
406 } else { 673 } else {
407 # dummy read to fetch real error code 674 # dummy read to fetch real error code
… …
411 }; 678 };
412 679
413 # now connect 680 # now connect
414 if (connect $state{fh}, $sockaddr) { 681 if (connect $state{fh}, $sockaddr) {
415 $connected->(); 682 $connected->();
416 } 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) {
417 $state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $connected); 688 $state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $connected);
418 } else { 689 } else {
419 %state = (); 690 $state{next}();
420 $connect->();
421 } 691 }
422 }; 692 };
423 693
424 $! = &Errno::ENXIO; 694 $! = &Errno::ENXIO;
425 $state{next}(); 695 $state{next}();
426 }; 696 };
427 697
428 defined wantarray && guard { %state = () } 698 defined wantarray && guard { %state = () }
429} 699}
430 700
431=item $guard = tcp_server $host, $port, $accept_cb[, $prepare_cb] 701=item $guard = tcp_server $host, $service, $accept_cb[, $prepare_cb]
432 702
433Create and bind a tcp socket to the given host (any IPv4 host if undef, 703Create and bind a stream socket to the given host, and port, set the
434otherwise it must be an IPv4 or IPv6 address) and port (service name or 704SO_REUSEADDR flag (if applicable) and call C<listen>. Unlike the name
435numeric port number, or an ephemeral port if given as zero or undef), set 705implies, this function can also bind on UNIX domain sockets.
436the SO_REUSEADDR flag and call C<listen>.
437 706
707For internet sockets, C<$host> must be an IPv4 or IPv6 address (or
708C<undef>, in which case it binds either to C<0> or to C<::>, depending
709on whether IPv4 or IPv6 is the preferred protocol, and maybe to both in
710future versions, as applicable).
711
712To bind to the IPv4 wildcard address, use C<0>, to bind to the IPv6
713wildcard address, use C<::>.
714
715The port is specified by C<$service>, which must be either a service name or
716a numeric port number (or C<0> or C<undef>, in which case an ephemeral
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.
723
438For each new connection that could be C<accept>ed, call the C<$accept_cb> 724For each new connection that could be C<accept>ed, call the C<<
439with the filehandle (in non-blocking mode) as first and the peer host and 725$accept_cb->($fh, $host, $port) >> with the file handle (in non-blocking
440port as second and third arguments (see C<tcp_connect> for details). 726mode) as first and the peer host and port as second and third arguments
727(see C<tcp_connect> for details).
441 728
442Croaks on any errors. 729Croaks on any errors it can detect before the listen.
443 730
444If called in non-void context, then this function returns a guard object 731If called in non-void context, then this function returns a guard object
445whose lifetime it tied to the tcp server: If the object gets destroyed, 732whose lifetime it tied to the TCP server: If the object gets destroyed,
446the server will be stopped (but existing accepted connections will 733the server will be stopped (but existing accepted connections will
447continue). 734continue).
448 735
449If you need more control over the listening socket, you can provide a 736If you need more control over the listening socket, you can provide a
450C<$prepare_cb>, which is called just before the C<listen ()> call, with 737C<< $prepare_cb->($fh, $host, $port) >>, which is called just before the
451the listen file handle as first argument. 738C<listen ()> call, with the listen file handle as first argument, and IP
739address and port number of the local socket endpoint as second and third
740arguments.
452 741
453It 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).
454 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
455Example: bind on tcp port 8888 on the local machine and tell each client 751Example: bind on some TCP port on the local machine and tell each client
456to go away. 752to go away.
457 753
458 tcp_server undef, 8888, sub { 754 tcp_server undef, undef, sub {
459 my ($fh, $host, $port) = @_; 755 my ($fh, $host, $port) = @_;
460 756
461 syswrite $fh, "The internet is full, $host:$port. Go away!\015\012"; 757 syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";
758 }, sub {
759 my ($fh, $thishost, $thisport) = @_;
760 warn "bound to $thishost, port $thisport\n";
462 }; 761 };
463 762
464=cut 763=cut
465 764
466sub tcp_server($$$;$) { 765sub tcp_server($$$;$) {
467 my ($host, $port, $accept, $prepare) = @_; 766 my ($host, $service, $accept, $prepare) = @_;
767
768 $host = $AnyEvent::PROTOCOL{ipv4} < $AnyEvent::PROTOCOL{ipv6} && AF_INET6
769 ? "::" : "0"
770 unless defined $host;
771
772 my $ipn = parse_address $host
773 or Carp::croak "AnyEvent::Socket::tcp_server: cannot parse '$host' as host address";
774
775 my $af = address_family $ipn;
468 776
469 my %state; 777 my %state;
470 778
471 socket $state{fh}, &Socket::AF_INET, &Socket::SOCK_STREAM, 0 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
783 socket $state{fh}, $af, SOCK_STREAM, 0
472 or Carp::croak "socket: $!"; 784 or Carp::croak "tcp_server/socket: $!";
473 785
786 if ($af == AF_INET || $af == AF_INET6) {
474 setsockopt $state{fh}, &Socket::SOL_SOCKET, &Socket::SO_REUSEADDR, 1 787 setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1
475 or Carp::croak "so_reuseaddr: $!"; 788 or Carp::croak "tcp_server/so_reuseaddr: $!"
789 unless AnyEvent::WIN32; # work around windows bug
476 790
477 bind $state{fh}, Socket::pack_sockaddr_in _tcp_port $port, socket_inet_aton ($host || "0.0.0.0") 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
799 bind $state{fh}, pack_sockaddr $service, $ipn
478 or Carp::croak "bind: $!"; 800 or Carp::croak "bind: $!";
479 801
480 fh_nonblocking $state{fh}, 1; 802 fh_nonblocking $state{fh}, 1;
481 803
482 my $len = ($prepare && $prepare->($state{fh})) || 128; 804 my $len;
805
806 if ($prepare) {
807 my ($service, $host) = unpack_sockaddr getsockname $state{fh};
808 $len = $prepare && $prepare->($state{fh}, format_address $host, $service);
809 }
810
811 $len ||= 128;
483 812
484 listen $state{fh}, $len 813 listen $state{fh}, $len
485 or Carp::croak "listen: $!"; 814 or Carp::croak "listen: $!";
486 815
487 $state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub { 816 $state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {
488 # this closure keeps $state alive 817 # this closure keeps $state alive
489 while (my $peer = accept my $fh, $state{fh}) { 818 while (my $peer = accept my $fh, $state{fh}) {
490 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
491 my ($port, $host) = Socket::unpack_sockaddr_in $peer; 821 my ($service, $host) = unpack_sockaddr $peer;
492 $accept->($fh, (Socket::inet_ntoa $host), $port); 822 $accept->($fh, format_address $host, $service);
493 } 823 }
494 }); 824 });
495 825
496 defined wantarray 826 defined wantarray
497 ? guard { %state = () } # clear fh and watcher, which breaks the circular dependency 827 ? guard { %state = () } # clear fh and watcher, which breaks the circular dependency
… …
500 830
5011; 8311;
502 832
503=back 833=back
504 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
505=head1 AUTHOR 844=head1 AUTHOR
506 845
507 Marc Lehmann <schmorp@schmorp.de> 846 Marc Lehmann <schmorp@schmorp.de>
508 http://home.schmorp.de/ 847 http://home.schmorp.de/
509 848

Diff Legend

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