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.36 by root, Wed May 28 21:29:03 2008 UTC vs.
Revision 1.93 by root, Thu Jul 16 23:27:46 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
47use AnyEvent::DNS (); 47use AnyEvent::DNS ();
48 48
49use base 'Exporter'; 49use base 'Exporter';
50 50
51our @EXPORT = qw( 51our @EXPORT = qw(
52 getprotobyname
53 parse_hostport
52 parse_ipv4 parse_ipv6 54 parse_ipv4 parse_ipv6
53 parse_ip parse_address 55 parse_ip parse_address
56 format_ipv4 format_ipv6
54 format_ip format_address 57 format_ip format_address
55 address_family 58 address_family
56 inet_aton 59 inet_aton
57 tcp_server 60 tcp_server
58 tcp_connect 61 tcp_connect
59); 62);
60 63
61our $VERSION = '1.0'; 64our $VERSION = 4.82;
62 65
63=item $ipn = parse_ipv4 $dotted_quad 66=item $ipn = parse_ipv4 $dotted_quad
64 67
65Tries to parse the given dotted quad IPv4 address and return it in 68Tries 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 69octet form (or undef when it isn't in a parsable format). Supports all
78 81
79 # check leading parts against range 82 # check leading parts against range
80 return undef if grep $_ >= 256, @_[0 .. @_ - 2]; 83 return undef if grep $_ >= 256, @_[0 .. @_ - 2];
81 84
82 # check trailing part against range 85 # check trailing part against range
83 return undef if $_[-1] >= 1 << (8 * (4 - $#_)); 86 return undef if $_[-1] >= 2 ** (8 * (4 - $#_));
84 87
85 pack "N", (pop) 88 pack "N", (pop)
86 + ($_[0] << 24) 89 + ($_[0] << 24)
87 + ($_[1] << 16) 90 + ($_[1] << 16)
88 + ($_[2] << 8); 91 + ($_[2] << 8);
143 ? pack "S", AF_UNIX 146 ? pack "S", AF_UNIX
144 : undef 147 : undef
145 148
146} 149}
147 150
148=item $ipn = parse_address $text 151=item $ipn = parse_address $ip
149 152
150Combines C<parse_ipv4> and C<parse_ipv6> in one function. The address 153Combines C<parse_ipv4> and C<parse_ipv6> in one function. The address
151here refers to the host address (not socket address) in network form 154here refers to the host address (not socket address) in network form
152(binary). 155(binary).
153 156
154If the C<$text> is C<unix/>, then this function returns a special token 157If 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 158recognised by the other functions in this module to mean "UNIX domain
156socket". 159socket".
157 160
161If the C<$text> to parse is a mapped IPv4 in IPv6 address (:ffff::<ipv4>),
162then it will be treated as an IPv4 address. If you don't want that, you
163have to call C<parse_ipv4> and/or C<parse_ipv6> manually.
164
165=item $ipn = AnyEvent::Socket::aton $ip
166
167Same as C<parse_address>, but not exported (think C<Socket::inet_aton> but
168I<without> name resolution).
169
158=cut 170=cut
159 171
160sub parse_address($) { 172sub parse_address($) {
161 &parse_ipv4 || &parse_ipv6 || &parse_unix 173 for (&parse_ipv6) {
174 if ($_) {
175 s/^\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff//;
176 return $_;
177 } else {
178 return &parse_ipv4 || &parse_unix
179 }
180 }
162} 181}
163 182
164*parse_ip =\&parse_address; #d# 183*aton = \&parse_address;
184
185=item ($name, $aliases, $proto) = getprotobyname $name
186
187Works like the builtin function of the same name, except it tries hard to
188work even on broken platforms (well, that's windows), where getprotobyname
189is traditionally very unreliable.
190
191=cut
192
193# microsoft can't even get getprotobyname working (the etc/protocols file
194# gets lost fairly often on windows), so we have to hardcode some common
195# protocol numbers ourselves.
196our %PROTO_BYNAME;
197
198$PROTO_BYNAME{tcp} = Socket::IPPROTO_TCP () if defined &Socket::IPPROTO_TCP;
199$PROTO_BYNAME{udp} = Socket::IPPROTO_UDP () if defined &Socket::IPPROTO_UDP;
200$PROTO_BYNAME{icmp} = Socket::IPPROTO_ICMP() if defined &Socket::IPPROTO_ICMP;
201
202sub getprotobyname($) {
203 my $name = lc shift;
204
205 defined (my $proton = $PROTO_BYNAME{$name} || (getprotobyname $name)[2])
206 or return;
207
208 ($name, uc $name, $proton)
209}
210
211=item ($host, $service) = parse_hostport $string[, $default_service]
212
213Splitting a string of the form C<hostname:port> is a common
214problem. Unfortunately, just splitting on the colon makes it hard to
215specify IPv6 addresses and doesn't support the less common but well
216standardised C<[ip literal]> syntax.
217
218This function tries to do this job in a better way, it supports the
219following formats, where C<port> can be a numerical port number of a
220service name, or a C<name=port> string, and the C< port> and C<:port>
221parts are optional. Also, everywhere where an IP address is supported
222a hostname or unix domain socket address is also supported (see
223C<parse_unix>).
224
225 hostname:port e.g. "www.linux.org", "www.x.de:443", "www.x.de:https=443"
226 ipv4:port e.g. "198.182.196.56", "127.1:22"
227 ipv6 e.g. "::1", "affe::1"
228 [ipv4or6]:port e.g. "[::1]", "[10.0.1]:80"
229 [ipv4or6] port e.g. "[127.0.0.1]", "[www.x.org] 17"
230 ipv4or6 port e.g. "::1 443", "10.0.0.1 smtp"
231
232It also supports defaulting the service name in a simple way by using
233C<$default_service> if no service was detected. If neither a service was
234detected nor a default was specified, then this function returns the
235empty list. The same happens when a parse error weas detected, such as a
236hostname with a colon in it (the function is rather conservative, though).
237
238Example:
239
240 print join ",", parse_hostport "localhost:443";
241 # => "localhost,443"
242
243 print join ",", parse_hostport "localhost", "https";
244 # => "localhost,https"
245
246 print join ",", parse_hostport "[::1]";
247 # => "," (empty list)
248
249=cut
250
251sub parse_hostport($;$) {
252 my ($host, $port);
253
254 for ("$_[0]") { # work on a copy, just in case, and also reset pos
255
256 # parse host, special cases: "ipv6" or "ipv6 port"
257 unless (
258 ($host) = /^\s* ([0-9a-fA-F:]*:[0-9a-fA-F:]*:[0-9a-fA-F\.:]*)/xgc
259 and parse_ipv6 $host
260 ) {
261 /^\s*/xgc;
262
263 if (/^ \[ ([^\[\]]+) \]/xgc) {
264 $host = $1;
265 } elsif (/^ ([^\[\]:\ ]+) /xgc) {
266 $host = $1;
267 } else {
268 return;
269 }
270 }
271
272 # parse port
273 if (/\G (?:\s+|:) ([^:[:space:]]+) \s*$/xgc) {
274 $port = $1;
275 } elsif (/\G\s*$/gc && length $_[1]) {
276 $port = $_[1];
277 } else {
278 return;
279 }
280 }
281
282 # hostnames must not contain :'s
283 return if $host =~ /:/ && !parse_ipv6 $host;
284
285 ($host, $port)
286}
165 287
166=item $sa_family = address_family $ipn 288=item $sa_family = address_family $ipn
167 289
168Returns the address family/protocol-family (AF_xxx/PF_xxx, in one value :) 290Returns the address family/protocol-family (AF_xxx/PF_xxx, in one value :)
169of the given host address in network format. 291of the given host address in network format.
176 : 16 == length $_[0] 298 : 16 == length $_[0]
177 ? AF_INET6 299 ? AF_INET6
178 : unpack "S", $_[0] 300 : unpack "S", $_[0]
179} 301}
180 302
303=item $text = format_ipv4 $ipn
304
305Expects a four octet string representing a binary IPv4 address and returns
306its textual format. Rarely used, see C<format_address> for a nicer
307interface.
308
309=item $text = format_ipv6 $ipn
310
311Expects a sixteen octet string representing a binary IPv6 address and
312returns its textual format. Rarely used, see C<format_address> for a
313nicer interface.
314
181=item $text = format_address $ipn 315=item $text = format_address $ipn
182 316
183Covnvert a host address in network format (e.g. 4 octets for IPv4 or 16 317Covnvert a host address in network format (e.g. 4 octets for IPv4 or 16
184octets for IPv6) and convert it into textual form. 318octets for IPv6) and convert it into textual form.
185 319
188This function works similarly to C<inet_ntop AF_INET || AF_INET6, ...>, 322This function works similarly to C<inet_ntop AF_INET || AF_INET6, ...>,
189except it automatically detects the address type. 323except it automatically detects the address type.
190 324
191Returns C<undef> if it cannot detect the type. 325Returns C<undef> if it cannot detect the type.
192 326
193=cut 327If the C<$ipn> is a mapped IPv4 in IPv6 address (:ffff::<ipv4>), then just
328the contained IPv4 address will be returned. If you do not want that, you
329have to call C<format_ipv6> manually.
194 330
195sub format_address; 331=item $text = AnyEvent::Socket::ntoa $ipn
332
333Same as format_address, but not exported (think C<inet_ntoa>).
334
335=cut
336
337sub format_ipv4($) {
338 join ".", unpack "C4", $_[0]
339}
340
341sub format_ipv6($) {
342 if (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0 eq $_[0]) {
343 return "::";
344 } elsif (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1 eq $_[0]) {
345 return "::1";
346 } elsif (v0.0.0.0.0.0.0.0.0.0.0.0 eq substr $_[0], 0, 12) {
347 # v4compatible
348 return "::" . format_ipv4 substr $_[0], 12;
349 } elsif (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) {
350 # v4mapped
351 return "::ffff:" . format_ipv4 substr $_[0], 12;
352 } elsif (v0.0.0.0.0.0.0.0.255.255.0.0 eq substr $_[0], 0, 12) {
353 # v4translated
354 return "::ffff:0:" . format_ipv4 substr $_[0], 12;
355 } else {
356 my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];
357
358 # this is rather sucky, I admit
359 $ip =~ s/^0:(?:0:)*(0$)?/::/
360 or $ip =~ s/(:0){7}$/::/ or $ip =~ s/(:0){7}/:/
361 or $ip =~ s/(:0){6}$/::/ or $ip =~ s/(:0){6}/:/
362 or $ip =~ s/(:0){5}$/::/ or $ip =~ s/(:0){5}/:/
363 or $ip =~ s/(:0){4}$/::/ or $ip =~ s/(:0){4}/:/
364 or $ip =~ s/(:0){3}$/::/ or $ip =~ s/(:0){3}/:/
365 or $ip =~ s/(:0){2}$/::/ or $ip =~ s/(:0){2}/:/
366 or $ip =~ s/(:0){1}$/::/ or $ip =~ s/(:0){1}/:/;
367 return $ip
368 }
369}
370
196sub format_address($) { 371sub format_address($) {
197 my $af = address_family $_[0]; 372 my $af = address_family $_[0];
198 if ($af == AF_INET) { 373 if ($af == AF_INET) {
199 return join ".", unpack "C4", $_[0] 374 return &format_ipv4;
200 } elsif ($af == AF_INET6) { 375 } 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) { 376 return (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12)
205 # v4mapped 377 ? format_ipv4 substr $_[0], 12
206 return "::ffff:" . format_address substr $_[0], 12; 378 : &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) { 379 } elsif ($af == AF_UNIX) {
219 return "unix/" 380 return "unix/"
220 } else { 381 } else {
221 return undef 382 return undef
222 } 383 }
223} 384}
224 385
225*format_ip = \&format_address; 386*ntoa = \&format_address;
226 387
227=item inet_aton $name_or_address, $cb->(@addresses) 388=item inet_aton $name_or_address, $cb->(@addresses)
228 389
229Works similarly to its Socket counterpart, except that it uses a 390Works similarly to its Socket counterpart, except that it uses a
230callback. Also, if a host has only an IPv6 address, this might be passed 391callback. Also, if a host has only an IPv6 address, this might be passed
262 423
263# check for broken platforms with extra field in sockaddr structure 424# 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 425# 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 426# unix vs. bsd issue, a iso C vs. bsd issue or simply a
266# correctness vs. bsd issue. 427# correctness vs. bsd issue.
267my $pack_family = 0x55 == Socket::sockaddr_family "\x55\x55" 428my $pack_family = (0x55 == Socket::sockaddr_family "\x55\x55")
268 ? "xC" : "S"; 429 ? "xC" : "S";
269 430
270=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host 431=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host
271 432
272Pack the given port/host combination into a binary sockaddr 433Pack the given port/host combination into a binary sockaddr
346C<sctp>. The default is currently C<tcp>, but in the future, this function 507C<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 508might try to use other protocols such as C<sctp>, depending on the socket
348type and any SRV records it might find. 509type and any SRV records it might find.
349 510
350C<$family> must be either C<0> (meaning any protocol is OK), C<4> (use 511C<$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 512only IPv4) or C<6> (use only IPv6). The default is influenced by
352C<$ENV{PERL_ANYEVENT_PROTOCOLS}>. 513C<$ENV{PERL_ANYEVENT_PROTOCOLS}>.
353 514
354C<$type> must be C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_SEQPACKET> (or 515C<$type> must be C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_SEQPACKET> (or
355C<undef> in which case it gets automatically chosen). 516C<undef> in which case it gets automatically chosen to be C<SOCK_STREAM>
517unless C<$proto> is C<udp>).
356 518
357The callback will receive zero or more array references that contain 519The callback will receive zero or more array references that contain
358C<$family, $type, $proto> for use in C<socket> and a binary 520C<$family, $type, $proto> for use in C<socket> and a binary
359C<$sockaddr> for use in C<connect> (or C<bind>). 521C<$sockaddr> for use in C<connect> (or C<bind>).
360 522
368 530
369sub resolve_sockaddr($$$$$$) { 531sub resolve_sockaddr($$$$$$) {
370 my ($node, $service, $proto, $family, $type, $cb) = @_; 532 my ($node, $service, $proto, $family, $type, $cb) = @_;
371 533
372 if ($node eq "unix/") { 534 if ($node eq "unix/") {
373 return $cb->() if $family || !/^\//; # no can do 535 return $cb->() if $family || $service !~ /^\//; # no can do
374 536
375 return $cb->([AF_UNIX, $type, 0, Socket::pack_sockaddr_un $service]); 537 return $cb->([AF_UNIX, defined $type ? $type : SOCK_STREAM, 0, Socket::pack_sockaddr_un $service]);
376 } 538 }
377 539
378 unless (AF_INET6) { 540 unless (AF_INET6) {
379 $family != 6 541 $family != 6
380 or return $cb->(); 542 or return $cb->();
389 $family ||= 6 unless $AnyEvent::PROTOCOL{ipv4}; 551 $family ||= 6 unless $AnyEvent::PROTOCOL{ipv4};
390 552
391 $proto ||= "tcp"; 553 $proto ||= "tcp";
392 $type ||= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM; 554 $type ||= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;
393 555
394 my $proton = (getprotobyname $proto)[2] 556 my $proton = getprotobyname $proto
395 or Carp::croak "$proto: protocol unknown"; 557 or Carp::croak "$proto: protocol unknown";
396 558
397 my $port; 559 my $port;
398 560
399 if ($service =~ /^(\S+)=(\d+)$/) { 561 if ($service =~ /^(\S+)=(\d+)$/) {
424 $cv->begin; 586 $cv->begin;
425 for my $idx (0 .. $#target) { 587 for my $idx (0 .. $#target) {
426 my ($node, $port) = @{ $target[$idx] }; 588 my ($node, $port) = @{ $target[$idx] };
427 589
428 if (my $noden = parse_address $node) { 590 if (my $noden = parse_address $node) {
591 my $af = address_family $noden;
592
429 if (4 == length $noden && $family != 6) { 593 if ($af == AF_INET && $family != 6) {
430 push @res, [$idx, "ipv4", [AF_INET, $type, $proton, 594 push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
431 pack_sockaddr $port, $noden]] 595 pack_sockaddr $port, $noden]]
432 } 596 }
433 597
434 if (16 == length $noden && $family != 4) { 598 if ($af == AF_INET6 && $family != 4) {
435 push @res, [$idx, "ipv6", [AF_INET6, $type, $proton, 599 push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,
436 pack_sockaddr $port, $noden]] 600 pack_sockaddr $port, $noden]]
437 } 601 }
438 } else { 602 } else {
439 # ipv4 603 # ipv4
440 if ($family != 6) { 604 if ($family != 6) {
441 $cv->begin; 605 $cv->begin;
442 a $node, sub { 606 AnyEvent::DNS::a $node, sub {
443 push @res, [$idx, "ipv4", [AF_INET, $type, $proton, 607 push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
444 pack_sockaddr $port, parse_ipv4 $_]] 608 pack_sockaddr $port, parse_ipv4 $_]]
445 for @_; 609 for @_;
446 $cv->end; 610 $cv->end;
447 }; 611 };
448 } 612 }
449 613
450 # ipv6 614 # ipv6
451 if ($family != 4) { 615 if ($family != 4) {
452 $cv->begin; 616 $cv->begin;
453 aaaa $node, sub { 617 AnyEvent::DNS::aaaa $node, sub {
454 push @res, [$idx, "ipv6", [AF_INET6, $type, $proton, 618 push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,
455 pack_sockaddr $port, parse_ipv6 $_]] 619 pack_sockaddr $port, parse_ipv6 $_]]
456 for @_; 620 for @_;
457 $cv->end; 621 $cv->end;
458 }; 622 };
465 # try srv records, if applicable 629 # try srv records, if applicable
466 if ($node eq "localhost") { 630 if ($node eq "localhost") {
467 @target = (["127.0.0.1", $port], ["::1", $port]); 631 @target = (["127.0.0.1", $port], ["::1", $port]);
468 &$resolve; 632 &$resolve;
469 } elsif (defined $service && !parse_address $node) { 633 } elsif (defined $service && !parse_address $node) {
470 srv $service, $proto, $node, sub { 634 AnyEvent::DNS::srv $service, $proto, $node, sub {
471 my (@srv) = @_; 635 my (@srv) = @_;
472 636
473 # no srv records, continue traditionally 637 # no srv records, continue traditionally
474 @srv 638 @srv
475 or return &$resolve; 639 or return &$resolve;
476 640
477 # only srv record has "." => abort 641 # the only srv record has "." ("" here) => abort
478 $srv[0][2] ne "." || $#srv 642 $srv[0][2] ne "" || $#srv
479 or return $cb->(); 643 or return $cb->();
480 644
481 # use srv records then 645 # use srv records then
482 @target = map ["$_->[3].", $_->[2]], 646 @target = map ["$_->[3].", $_->[2]],
483 grep $_->[3] ne ".", 647 grep $_->[3] ne ".",
548lessen the impact of this windows bug, a default timeout of 30 seconds 712lessen the impact of this windows bug, a default timeout of 30 seconds
549will be imposed on windows. Cygwin is not affected. 713will be imposed on windows. Cygwin is not affected.
550 714
551Simple Example: connect to localhost on port 22. 715Simple Example: connect to localhost on port 22.
552 716
553 tcp_connect localhost => 22, sub { 717 tcp_connect localhost => 22, sub {
554 my $fh = shift 718 my $fh = shift
555 or die "unable to connect: $!"; 719 or die "unable to connect: $!";
556 # do something 720 # do something
557 }; 721 };
558 722
559Complex Example: connect to www.google.com on port 80 and make a simple 723Complex Example: connect to www.google.com on port 80 and make a simple
560GET request without much error handling. Also limit the connection timeout 724GET request without much error handling. Also limit the connection timeout
561to 15 seconds. 725to 15 seconds.
562 726
566 or die "unable to connect: $!"; 730 or die "unable to connect: $!";
567 731
568 my $handle; # avoid direct assignment so on_eof has it in scope. 732 my $handle; # avoid direct assignment so on_eof has it in scope.
569 $handle = new AnyEvent::Handle 733 $handle = new AnyEvent::Handle
570 fh => $fh, 734 fh => $fh,
735 on_error => sub {
736 warn "error $_[2]\n";
737 $_[0]->destroy;
738 },
571 on_eof => sub { 739 on_eof => sub {
572 undef $handle; # keep it alive till eof 740 $handle->destroy; # destroy handle
573 warn "done.\n"; 741 warn "done.\n";
574 }; 742 };
575 743
576 $handle->push_write ("GET / HTTP/1.0\015\012\015\012"); 744 $handle->push_write ("GET / HTTP/1.0\015\012\015\012");
577 745
609 # also http://advogato.org/article/672.html 777 # also http://advogato.org/article/672.html
610 778
611 my %state = ( fh => undef ); 779 my %state = ( fh => undef );
612 780
613 # name/service to type/sockaddr resolution 781 # name/service to type/sockaddr resolution
614 resolve_sockaddr $host, $port, 0, 0, 0, sub { 782 resolve_sockaddr $host, $port, 0, 0, undef, sub {
615 my @target = @_; 783 my @target = @_;
616 784
617 $state{next} = sub { 785 $state{next} = sub {
618 return unless exists $state{fh}; 786 return unless exists $state{fh};
619 787
620 my $target = shift @target 788 my $target = shift @target
621 or do {
622 %state = ();
623 return $connect->(); 789 or return (%state = (), $connect->());
624 };
625 790
626 my ($domain, $type, $proto, $sockaddr) = @$target; 791 my ($domain, $type, $proto, $sockaddr) = @$target;
627 792
628 # socket creation 793 # socket creation
629 socket $state{fh}, $domain, $type, $proto 794 socket $state{fh}, $domain, $type, $proto
634 my $timeout = $prepare && $prepare->($state{fh}); 799 my $timeout = $prepare && $prepare->($state{fh});
635 800
636 $timeout ||= 30 if AnyEvent::WIN32; 801 $timeout ||= 30 if AnyEvent::WIN32;
637 802
638 $state{to} = AnyEvent->timer (after => $timeout, cb => sub { 803 $state{to} = AnyEvent->timer (after => $timeout, cb => sub {
639 $! = &Errno::ETIMEDOUT; 804 $! = Errno::ETIMEDOUT;
640 $state{next}(); 805 $state{next}();
641 }) if $timeout; 806 }) if $timeout;
642 807
643 # called when the connect was successful, which, 808 # called when the connect was successful, which,
644 # in theory, could be the case immediately (but never is in practise) 809 # in theory, could be the case immediately (but never is in practise)
645 my $connected = sub { 810 $state{connected} = sub {
646 delete $state{ww};
647 delete $state{to};
648
649 # we are connected, or maybe there was an error 811 # we are connected, or maybe there was an error
650 if (my $sin = getpeername $state{fh}) { 812 if (my $sin = getpeername $state{fh}) {
651 my ($port, $host) = unpack_sockaddr $sin; 813 my ($port, $host) = unpack_sockaddr $sin;
652 814
815 delete $state{ww}; delete $state{to};
816
653 my $guard = guard { 817 my $guard = guard { %state = () };
654 %state = ();
655 };
656 818
657 $connect->($state{fh}, format_address $host, $port, sub { 819 $connect->(delete $state{fh}, format_address $host, $port, sub {
658 $guard->cancel; 820 $guard->cancel;
659 $state{next}(); 821 $state{next}();
660 }); 822 });
661 } else { 823 } else {
662 # dummy read to fetch real error code 824 # dummy read to fetch real error code
663 sysread $state{fh}, my $buf, 1 if $! == &Errno::ENOTCONN; 825 sysread $state{fh}, my $buf, 1 if $! == Errno::ENOTCONN;
826
827 return if $! == Errno::EAGAIN; # skip spurious wake-ups
828
829 delete $state{ww}; delete $state{to};
830
664 $state{next}(); 831 $state{next}();
665 } 832 }
666 }; 833 };
667 834
668 # now connect 835 # now connect
669 if (connect $state{fh}, $sockaddr) { 836 if (connect $state{fh}, $sockaddr) {
670 $connected->(); 837 $state{connected}->();
671 } elsif ($! == &Errno::EINPROGRESS # POSIX 838 } elsif ($! == Errno::EINPROGRESS # POSIX
672 || $! == &Errno::EWOULDBLOCK 839 || $! == Errno::EWOULDBLOCK
673 # WSAEINPROGRESS intentionally not checked - it means something else entirely 840 # WSAEINPROGRESS intentionally not checked - it means something else entirely
674 || $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt 841 || $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt
675 || $! == AnyEvent::Util::WSAEWOULDBLOCK) { 842 || $! == AnyEvent::Util::WSAEWOULDBLOCK) {
676 $state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $connected); 843 $state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $state{connected});
677 } else { 844 } else {
678 $state{next}(); 845 $state{next}();
679 } 846 }
680 }; 847 };
681 848
682 $! = &Errno::ENXIO; 849 $! = Errno::ENXIO;
683 $state{next}(); 850 $state{next}();
684 }; 851 };
685 852
686 defined wantarray && guard { %state = () } 853 defined wantarray && guard { %state = () }
687} 854}
691Create and bind a stream socket to the given host, and port, set the 858Create 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 859SO_REUSEADDR flag (if applicable) and call C<listen>. Unlike the name
693implies, this function can also bind on UNIX domain sockets. 860implies, this function can also bind on UNIX domain sockets.
694 861
695For internet sockets, C<$host> must be an IPv4 or IPv6 address (or 862For 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 863C<undef>, in which case it binds either to C<0> or to C<::>, depending
697whether IPv4 or IPv6 is the preferred protocol). 864on whether IPv4 or IPv6 is the preferred protocol, and maybe to both in
865future versions, as applicable).
698 866
699To bind to the IPv4 wildcard address, use C<0>, to bind to the IPv6 867To bind to the IPv4 wildcard address, use C<0>, to bind to the IPv6
700wildcard address, use C<::>. 868wildcard address, use C<::>.
701 869
702The port is specified by C<$service>, which must be either a service name or 870The 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 894address and port number of the local socket endpoint as second and third
727arguments. 895arguments.
728 896
729It should return the length of the listen queue (or C<0> for the default). 897It should return the length of the listen queue (or C<0> for the default).
730 898
899Note to IPv6 users: RFC-compliant behaviour for IPv6 sockets listening on
900C<::> is to bind to both IPv6 and IPv4 addresses by default on dual-stack
901hosts. Unfortunately, only GNU/Linux seems to implement this properly, so
902if you want both IPv4 and IPv6 listening sockets you should create the
903IPv6 socket first and then attempt to bind on the IPv4 socket, but ignore
904any C<EADDRINUSE> errors.
905
731Example: bind on some TCP port on the local machine and tell each client 906Example: bind on some TCP port on the local machine and tell each client
732to go away. 907to go away.
733 908
734 tcp_server undef, undef, sub { 909 tcp_server undef, undef, sub {
735 my ($fh, $host, $port) = @_; 910 my ($fh, $host, $port) = @_;
738 }, sub { 913 }, sub {
739 my ($fh, $thishost, $thisport) = @_; 914 my ($fh, $thishost, $thisport) = @_;
740 warn "bound to $thishost, port $thisport\n"; 915 warn "bound to $thishost, port $thisport\n";
741 }; 916 };
742 917
918Example: bind a server on a unix domain socket.
919
920 tcp_server "unix/", "/tmp/mydir/mysocket", sub {
921 my ($fh) = @_;
922 };
923
743=cut 924=cut
744 925
745sub tcp_server($$$;$) { 926sub tcp_server($$$;$) {
746 my ($host, $service, $accept, $prepare) = @_; 927 my ($host, $service, $accept, $prepare) = @_;
747 928
764 or Carp::croak "tcp_server/socket: $!"; 945 or Carp::croak "tcp_server/socket: $!";
765 946
766 if ($af == AF_INET || $af == AF_INET6) { 947 if ($af == AF_INET || $af == AF_INET6) {
767 setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1 948 setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1
768 or Carp::croak "tcp_server/so_reuseaddr: $!" 949 or Carp::croak "tcp_server/so_reuseaddr: $!"
769 unless !AnyEvent::WIN32; # work around windows bug 950 unless AnyEvent::WIN32; # work around windows bug
770 951
771 unless ($service =~ /^\d*$/) { 952 unless ($service =~ /^\d*$/) {
772 $service = (getservbyname $service, "tcp")[2] 953 $service = (getservbyname $service, "tcp")[2]
773 or Carp::croak "$service: service unknown" 954 or Carp::croak "$service: service unknown"
774 } 955 }
795 976
796 $state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub { 977 $state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {
797 # this closure keeps $state alive 978 # this closure keeps $state alive
798 while (my $peer = accept my $fh, $state{fh}) { 979 while (my $peer = accept my $fh, $state{fh}) {
799 fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not 980 fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not
981
800 my ($service, $host) = unpack_sockaddr $peer; 982 my ($service, $host) = unpack_sockaddr $peer;
801 $accept->($fh, format_address $host, $service); 983 $accept->($fh, format_address $host, $service);
802 } 984 }
803 }); 985 });
804 986
809 991
8101; 9921;
811 993
812=back 994=back
813 995
996=head1 SECURITY CONSIDERATIONS
997
998This module is quite powerful, with with power comes the ability to abuse
999as well: If you accept "hostnames" and ports from untrusted sources,
1000then note that this can be abused to delete files (host=C<unix/>). This
1001is not really a problem with this module, however, as blindly accepting
1002any address and protocol and trying to bind a server or connect to it is
1003harmful in general.
1004
814=head1 AUTHOR 1005=head1 AUTHOR
815 1006
816 Marc Lehmann <schmorp@schmorp.de> 1007 Marc Lehmann <schmorp@schmorp.de>
817 http://home.schmorp.de/ 1008 http://home.schmorp.de/
818 1009

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines