1 |
=head1 NAME |
2 |
|
3 |
AnyEvent::Socket - useful IPv4 and IPv6 stuff. |
4 |
|
5 |
=head1 SYNOPSIS |
6 |
|
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 |
}; |
22 |
|
23 |
=head1 DESCRIPTION |
24 |
|
25 |
This module implements various utility functions for handling internet |
26 |
protocol addresses and sockets, in an as transparent and simple way as |
27 |
possible. |
28 |
|
29 |
All functions documented without C<AnyEvent::Socket::> prefix are exported |
30 |
by default. |
31 |
|
32 |
=over 4 |
33 |
|
34 |
=cut |
35 |
|
36 |
package AnyEvent::Socket; |
37 |
|
38 |
no warnings; |
39 |
use strict; |
40 |
|
41 |
use Carp (); |
42 |
use Errno (); |
43 |
use Socket qw(AF_INET AF_UNIX SOCK_STREAM SOCK_DGRAM SOL_SOCKET SO_REUSEADDR); |
44 |
|
45 |
use AnyEvent (); |
46 |
use AnyEvent::Util qw(guard fh_nonblocking AF_INET6); |
47 |
use AnyEvent::DNS (); |
48 |
|
49 |
use base 'Exporter'; |
50 |
|
51 |
our @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 |
); |
60 |
|
61 |
our $VERSION = '1.0'; |
62 |
|
63 |
=item $ipn = parse_ipv4 $dotted_quad |
64 |
|
65 |
Tries to parse the given dotted quad IPv4 address and return it in |
66 |
octet form (or undef when it isn't in a parsable format). Supports all |
67 |
forms specified by POSIX (e.g. C<10.0.0.1>, C<10.1>, C<10.0x020304>, |
68 |
C<0x12345678> or C<0377.0377.0377.0377>). |
69 |
|
70 |
=cut |
71 |
|
72 |
sub parse_ipv4($) { |
73 |
$_[0] =~ /^ (?: 0x[0-9a-fA-F]+ | 0[0-7]* | [1-9][0-9]* ) |
74 |
(?:\. (?: 0x[0-9a-fA-F]+ | 0[0-7]* | [1-9][0-9]* ) ){0,3}$/x |
75 |
or return undef; |
76 |
|
77 |
@_ = map /^0/ ? oct : $_, split /\./, $_[0]; |
78 |
|
79 |
# check leading parts against range |
80 |
return undef if grep $_ >= 256, @_[0 .. @_ - 2]; |
81 |
|
82 |
# check trailing part against range |
83 |
return undef if $_[-1] >= 1 << (8 * (4 - $#_)); |
84 |
|
85 |
pack "N", (pop) |
86 |
+ ($_[0] << 24) |
87 |
+ ($_[1] << 16) |
88 |
+ ($_[2] << 8); |
89 |
} |
90 |
|
91 |
=item $ipn = parse_ipv6 $textual_ipv6_address |
92 |
|
93 |
Tries to parse the given IPv6 address and return it in |
94 |
octet form (or undef when it isn't in a parsable format). |
95 |
|
96 |
Should support all forms specified by RFC 2373 (and additionally all IPv4 |
97 |
forms supported by parse_ipv4). Note that scope-id's are not supported |
98 |
(and will not parse). |
99 |
|
100 |
This function works similarly to C<inet_pton AF_INET6, ...>. |
101 |
|
102 |
=cut |
103 |
|
104 |
sub parse_ipv6($) { |
105 |
# quick test to avoid longer processing |
106 |
my $n = $_[0] =~ y/://; |
107 |
return undef if $n < 2 || $n > 8; |
108 |
|
109 |
my ($h, $t) = split /::/, $_[0], 2; |
110 |
|
111 |
unless (defined $t) { |
112 |
($h, $t) = (undef, $h); |
113 |
} |
114 |
|
115 |
my @h = split /:/, $h; |
116 |
my @t = split /:/, $t; |
117 |
|
118 |
# check for ipv4 tail |
119 |
if (@t && $t[-1]=~ /\./) { |
120 |
return undef if $n > 6; |
121 |
|
122 |
my $ipn = parse_ipv4 pop @t |
123 |
or return undef; |
124 |
|
125 |
push @t, map +(sprintf "%x", $_), unpack "nn", $ipn; |
126 |
} |
127 |
|
128 |
# no :: then we need to have exactly 8 components |
129 |
return undef unless @h + @t == 8 || $_[0] =~ /::/; |
130 |
|
131 |
# now check all parts for validity |
132 |
return undef if grep !/^[0-9a-fA-F]{1,4}$/, @h, @t; |
133 |
|
134 |
# now pad... |
135 |
push @h, 0 while @h + @t < 8; |
136 |
|
137 |
# and done |
138 |
pack "n*", map hex, @h, @t |
139 |
} |
140 |
|
141 |
sub parse_unix($) { |
142 |
$_[0] eq "unix/" |
143 |
? pack "S", AF_UNIX |
144 |
: undef |
145 |
|
146 |
} |
147 |
|
148 |
=item $ipn = parse_address $text |
149 |
|
150 |
Combines C<parse_ipv4> and C<parse_ipv6> in one function. The address |
151 |
here refers to the host address (not socket address) in network form |
152 |
(binary). |
153 |
|
154 |
If the C<$text> is C<unix/>, then this function returns a special token |
155 |
recognised by the other functions in this module to mean "UNIX domain |
156 |
socket". |
157 |
|
158 |
=cut |
159 |
|
160 |
sub parse_address($) { |
161 |
&parse_ipv4 || &parse_ipv6 || &parse_unix |
162 |
} |
163 |
|
164 |
*parse_ip =\&parse_address; #d# |
165 |
|
166 |
=item $sa_family = address_family $ipn |
167 |
|
168 |
Returns the address family/protocol-family (AF_xxx/PF_xxx, in one value :) |
169 |
of the given host address in network format. |
170 |
|
171 |
=cut |
172 |
|
173 |
sub address_family($) { |
174 |
4 == length $_[0] |
175 |
? AF_INET |
176 |
: 16 == length $_[0] |
177 |
? AF_INET6 |
178 |
: unpack "S", $_[0] |
179 |
} |
180 |
|
181 |
=item $text = format_address $ipn |
182 |
|
183 |
Covnvert a host address in network format (e.g. 4 octets for IPv4 or 16 |
184 |
octets for IPv6) and convert it into textual form. |
185 |
|
186 |
Returns C<unix/> for UNIX domain sockets. |
187 |
|
188 |
This function works similarly to C<inet_ntop AF_INET || AF_INET6, ...>, |
189 |
except it automatically detects the address type. |
190 |
|
191 |
Returns C<undef> if it cannot detect the type. |
192 |
|
193 |
=cut |
194 |
|
195 |
sub format_address; |
196 |
sub format_address($) { |
197 |
my $af = address_family $_[0]; |
198 |
if ($af == AF_INET) { |
199 |
return join ".", unpack "C4", $_[0] |
200 |
} 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) { |
205 |
# v4mapped |
206 |
return "::ffff:" . format_address substr $_[0], 12; |
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) { |
219 |
return "unix/" |
220 |
} else { |
221 |
return undef |
222 |
} |
223 |
} |
224 |
|
225 |
*format_ip = \&format_address; |
226 |
|
227 |
=item inet_aton $name_or_address, $cb->(@addresses) |
228 |
|
229 |
Works similarly to its Socket counterpart, except that it uses a |
230 |
callback. Also, if a host has only an IPv6 address, this might be passed |
231 |
to the callback instead (use the length to detect this - 4 for IPv4, 16 |
232 |
for IPv6). |
233 |
|
234 |
Unlike the L<Socket> function of the same name, you can get multiple IPv4 |
235 |
and IPv6 addresses as result (and maybe even other adrdess types). |
236 |
|
237 |
=cut |
238 |
|
239 |
sub inet_aton { |
240 |
my ($name, $cb) = @_; |
241 |
|
242 |
if (my $ipn = &parse_ipv4) { |
243 |
$cb->($ipn); |
244 |
} elsif (my $ipn = &parse_ipv6) { |
245 |
$cb->($ipn); |
246 |
} elsif ($name eq "localhost") { # rfc2606 et al. |
247 |
$cb->(v127.0.0.1, v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1); |
248 |
} else { |
249 |
require AnyEvent::DNS; |
250 |
|
251 |
# simple, bad suboptimal algorithm |
252 |
AnyEvent::DNS::a ($name, sub { |
253 |
if (@_) { |
254 |
$cb->(map +(parse_ipv4 $_), @_); |
255 |
} else { |
256 |
$cb->(); |
257 |
#AnyEvent::DNS::aaaa ($name, $cb); need inet_pton |
258 |
} |
259 |
}); |
260 |
} |
261 |
} |
262 |
|
263 |
# 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 |
265 |
# unix vs. bsd issue, a iso C vs. bsd issue or simply a |
266 |
# correctness vs. bsd issue. |
267 |
my $pack_family = (0x55 == Socket::sockaddr_family "\x55\x55") |
268 |
? "xC" : "S"; |
269 |
|
270 |
=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host |
271 |
|
272 |
Pack the given port/host combination into a binary sockaddr |
273 |
structure. Handles both IPv4 and IPv6 host addresses, as well as UNIX |
274 |
domain sockets (C<$host> == C<unix/> and C<$service> == absolute |
275 |
pathname). |
276 |
|
277 |
=cut |
278 |
|
279 |
sub pack_sockaddr($$) { |
280 |
my $af = address_family $_[1]; |
281 |
|
282 |
if ($af == AF_INET) { |
283 |
Socket::pack_sockaddr_in $_[0], $_[1] |
284 |
} elsif ($af == AF_INET6) { |
285 |
pack "$pack_family nL a16 L", |
286 |
AF_INET6, |
287 |
$_[0], # port |
288 |
0, # flowinfo |
289 |
$_[1], # addr |
290 |
0 # scope id |
291 |
} elsif ($af == AF_UNIX) { |
292 |
Socket::pack_sockaddr_un $_[0] |
293 |
} else { |
294 |
Carp::croak "pack_sockaddr: invalid host"; |
295 |
} |
296 |
} |
297 |
|
298 |
=item ($service, $host) = AnyEvent::Socket::unpack_sockaddr $sa |
299 |
|
300 |
Unpack the given binary sockaddr structure (as used by bind, getpeername |
301 |
etc.) into a C<$service, $host> combination. |
302 |
|
303 |
For IPv4 and IPv6, C<$service> is the port number and C<$host> the host |
304 |
address in network format (binary). |
305 |
|
306 |
For UNIX domain sockets, C<$service> is the absolute pathname and C<$host> |
307 |
is a special token that is understood by the other functions in this |
308 |
module (C<format_address> converts it to C<unix/>). |
309 |
|
310 |
=cut |
311 |
|
312 |
sub unpack_sockaddr($) { |
313 |
my $af = Socket::sockaddr_family $_[0]; |
314 |
|
315 |
if ($af == AF_INET) { |
316 |
Socket::unpack_sockaddr_in $_[0] |
317 |
} elsif ($af == AF_INET6) { |
318 |
unpack "x2 n x4 a16", $_[0] |
319 |
} elsif ($af == AF_UNIX) { |
320 |
((Socket::unpack_sockaddr_un $_[0]), pack "S", AF_UNIX) |
321 |
} else { |
322 |
Carp::croak "unpack_sockaddr: unsupported protocol family $af"; |
323 |
} |
324 |
} |
325 |
|
326 |
=item resolve_sockaddr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...) |
327 |
|
328 |
Tries to resolve the given nodename and service name into protocol families |
329 |
and sockaddr structures usable to connect to this node and service in a |
330 |
protocol-independent way. It works remotely similar to the getaddrinfo |
331 |
posix function. |
332 |
|
333 |
For internet addresses, C<$node> is either an IPv4 or IPv6 address or an |
334 |
internet hostname, and C<$service> is either a service name (port name |
335 |
from F</etc/services>) or a numerical port number. If both C<$node> and |
336 |
C<$service> are names, then SRV records will be consulted to find the real |
337 |
service, otherwise they will be used as-is. If you know that the service |
338 |
name is not in your services database, then you can specify the service in |
339 |
the format C<name=port> (e.g. C<http=80>). |
340 |
|
341 |
For UNIX domain sockets, C<$node> must be the string C<unix/> and |
342 |
C<$service> must be the absolute pathname of the socket. In this case, |
343 |
C<$proto> will be ignored. |
344 |
|
345 |
C<$proto> must be a protocol name, currently C<tcp>, C<udp> or |
346 |
C<sctp>. The default is currently C<tcp>, but in the future, this function |
347 |
might try to use other protocols such as C<sctp>, depending on the socket |
348 |
type and any SRV records it might find. |
349 |
|
350 |
C<$family> must be either C<0> (meaning any protocol is OK), C<4> (use |
351 |
only IPv4) or C<6> (use only IPv6). This setting might be influenced by |
352 |
C<$ENV{PERL_ANYEVENT_PROTOCOLS}>. |
353 |
|
354 |
C<$type> must be C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_SEQPACKET> (or |
355 |
C<undef> in which case it gets automatically chosen). |
356 |
|
357 |
The callback will receive zero or more array references that contain |
358 |
C<$family, $type, $proto> for use in C<socket> and a binary |
359 |
C<$sockaddr> for use in C<connect> (or C<bind>). |
360 |
|
361 |
The application should try these in the order given. |
362 |
|
363 |
Example: |
364 |
|
365 |
resolve_sockaddr "google.com", "http", 0, undef, undef, sub { ... }; |
366 |
|
367 |
=cut |
368 |
|
369 |
sub resolve_sockaddr($$$$$$) { |
370 |
my ($node, $service, $proto, $family, $type, $cb) = @_; |
371 |
|
372 |
if ($node eq "unix/") { |
373 |
return $cb->() if $family || !/^\//; # no can do |
374 |
|
375 |
return $cb->([AF_UNIX, $type, 0, Socket::pack_sockaddr_un $service]); |
376 |
} |
377 |
|
378 |
unless (AF_INET6) { |
379 |
$family != 6 |
380 |
or return $cb->(); |
381 |
|
382 |
$family = 4; |
383 |
} |
384 |
|
385 |
$cb->() if $family == 4 && !$AnyEvent::PROTOCOL{ipv4}; |
386 |
$cb->() if $family == 6 && !$AnyEvent::PROTOCOL{ipv6}; |
387 |
|
388 |
$family ||= 4 unless $AnyEvent::PROTOCOL{ipv6}; |
389 |
$family ||= 6 unless $AnyEvent::PROTOCOL{ipv4}; |
390 |
|
391 |
$proto ||= "tcp"; |
392 |
$type ||= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM; |
393 |
|
394 |
my $proton = (getprotobyname $proto)[2] |
395 |
or Carp::croak "$proto: protocol unknown"; |
396 |
|
397 |
my $port; |
398 |
|
399 |
if ($service =~ /^(\S+)=(\d+)$/) { |
400 |
($service, $port) = ($1, $2); |
401 |
} elsif ($service =~ /^\d+$/) { |
402 |
($service, $port) = (undef, $service); |
403 |
} else { |
404 |
$port = (getservbyname $service, $proto)[2] |
405 |
or Carp::croak "$service/$proto: service unknown"; |
406 |
} |
407 |
|
408 |
my @target = [$node, $port]; |
409 |
|
410 |
# resolve a records / provide sockaddr structures |
411 |
my $resolve = sub { |
412 |
my @res; |
413 |
my $cv = AnyEvent->condvar (cb => sub { |
414 |
$cb->( |
415 |
map $_->[2], |
416 |
sort { |
417 |
$AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]} |
418 |
or $a->[0] <=> $b->[0] |
419 |
} |
420 |
@res |
421 |
) |
422 |
}); |
423 |
|
424 |
$cv->begin; |
425 |
for my $idx (0 .. $#target) { |
426 |
my ($node, $port) = @{ $target[$idx] }; |
427 |
|
428 |
if (my $noden = parse_address $node) { |
429 |
if (4 == length $noden && $family != 6) { |
430 |
push @res, [$idx, "ipv4", [AF_INET, $type, $proton, |
431 |
pack_sockaddr $port, $noden]] |
432 |
} |
433 |
|
434 |
if (16 == length $noden && $family != 4) { |
435 |
push @res, [$idx, "ipv6", [AF_INET6, $type, $proton, |
436 |
pack_sockaddr $port, $noden]] |
437 |
} |
438 |
} else { |
439 |
# ipv4 |
440 |
if ($family != 6) { |
441 |
$cv->begin; |
442 |
AnyEvent::DNS::a $node, sub { |
443 |
push @res, [$idx, "ipv4", [AF_INET, $type, $proton, |
444 |
pack_sockaddr $port, parse_ipv4 $_]] |
445 |
for @_; |
446 |
$cv->end; |
447 |
}; |
448 |
} |
449 |
|
450 |
# ipv6 |
451 |
if ($family != 4) { |
452 |
$cv->begin; |
453 |
AnyEvent::DNS::aaaa $node, sub { |
454 |
push @res, [$idx, "ipv6", [AF_INET6, $type, $proton, |
455 |
pack_sockaddr $port, parse_ipv6 $_]] |
456 |
for @_; |
457 |
$cv->end; |
458 |
}; |
459 |
} |
460 |
} |
461 |
} |
462 |
$cv->end; |
463 |
}; |
464 |
|
465 |
# try srv records, if applicable |
466 |
if ($node eq "localhost") { |
467 |
@target = (["127.0.0.1", $port], ["::1", $port]); |
468 |
&$resolve; |
469 |
} elsif (defined $service && !parse_address $node) { |
470 |
AnyEvent::DNS::srv $service, $proto, $node, sub { |
471 |
my (@srv) = @_; |
472 |
|
473 |
# no srv records, continue traditionally |
474 |
@srv |
475 |
or return &$resolve; |
476 |
|
477 |
# only srv record has "." => abort |
478 |
$srv[0][2] ne "." || $#srv |
479 |
or return $cb->(); |
480 |
|
481 |
# use srv records then |
482 |
@target = map ["$_->[3].", $_->[2]], |
483 |
grep $_->[3] ne ".", |
484 |
@srv; |
485 |
|
486 |
&$resolve; |
487 |
}; |
488 |
} else { |
489 |
&$resolve; |
490 |
} |
491 |
} |
492 |
|
493 |
=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb] |
494 |
|
495 |
This is a convenience function that creates a TCP socket and makes a 100% |
496 |
non-blocking connect to the given C<$host> (which can be a hostname or |
497 |
a textual IP address, or the string C<unix/> for UNIX domain sockets) |
498 |
and C<$service> (which can be a numeric port number or a service name, |
499 |
or a C<servicename=portnumber> string, or the pathname to a UNIX domain |
500 |
socket). |
501 |
|
502 |
If both C<$host> and C<$port> are names, then this function will use SRV |
503 |
records to locate the real target(s). |
504 |
|
505 |
In either case, it will create a list of target hosts (e.g. for multihomed |
506 |
hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to |
507 |
each in turn. |
508 |
|
509 |
If the connect is successful, then the C<$connect_cb> will be invoked with |
510 |
the socket file handle (in non-blocking mode) as first and the peer host |
511 |
(as a textual IP address) and peer port as second and third arguments, |
512 |
respectively. The fourth argument is a code reference that you can call |
513 |
if, for some reason, you don't like this connection, which will cause |
514 |
C<tcp_connect> to try the next one (or call your callback without any |
515 |
arguments if there are no more connections). In most cases, you can simply |
516 |
ignore this argument. |
517 |
|
518 |
$cb->($filehandle, $host, $port, $retry) |
519 |
|
520 |
If the connect is unsuccessful, then the C<$connect_cb> will be invoked |
521 |
without any arguments and C<$!> will be set appropriately (with C<ENXIO> |
522 |
indicating a DNS resolution failure). |
523 |
|
524 |
The file handle is perfect for being plugged into L<AnyEvent::Handle>, but |
525 |
can be used as a normal perl file handle as well. |
526 |
|
527 |
Unless called in void context, C<tcp_connect> returns a guard object that |
528 |
will automatically abort connecting when it gets destroyed (it does not do |
529 |
anything to the socket after the connect was successful). |
530 |
|
531 |
Sometimes you need to "prepare" the socket before connecting, for example, |
532 |
to C<bind> it to some port, or you want a specific connect timeout that |
533 |
is lower than your kernel's default timeout. In this case you can specify |
534 |
a second callback, C<$prepare_cb>. It will be called with the file handle |
535 |
in not-yet-connected state as only argument and must return the connection |
536 |
timeout value (or C<0>, C<undef> or the empty list to indicate the default |
537 |
timeout is to be used). |
538 |
|
539 |
Note that the socket could be either a IPv4 TCP socket or an IPv6 TCP |
540 |
socket (although only IPv4 is currently supported by this module). |
541 |
|
542 |
Note to the poor Microsoft Windows users: Windows (of course) doesn't |
543 |
correctly signal connection errors, so unless your event library works |
544 |
around this, failed connections will simply hang. The only event libraries |
545 |
that handle this condition correctly are L<EV> and L<Glib>. Additionally, |
546 |
AnyEvent works around this bug with L<Event> and in its pure-perl |
547 |
backend. All other libraries cannot correctly handle this condition. To |
548 |
lessen the impact of this windows bug, a default timeout of 30 seconds |
549 |
will be imposed on windows. Cygwin is not affected. |
550 |
|
551 |
Simple Example: connect to localhost on port 22. |
552 |
|
553 |
tcp_connect localhost => 22, sub { |
554 |
my $fh = shift |
555 |
or die "unable to connect: $!"; |
556 |
# do something |
557 |
}; |
558 |
|
559 |
Complex Example: connect to www.google.com on port 80 and make a simple |
560 |
GET request without much error handling. Also limit the connection timeout |
561 |
to 15 seconds. |
562 |
|
563 |
tcp_connect "www.google.com", "http", |
564 |
sub { |
565 |
my ($fh) = @_ |
566 |
or die "unable to connect: $!"; |
567 |
|
568 |
my $handle; # avoid direct assignment so on_eof has it in scope. |
569 |
$handle = new AnyEvent::Handle |
570 |
fh => $fh, |
571 |
on_eof => sub { |
572 |
undef $handle; # keep it alive till eof |
573 |
warn "done.\n"; |
574 |
}; |
575 |
|
576 |
$handle->push_write ("GET / HTTP/1.0\015\012\015\012"); |
577 |
|
578 |
$handle->push_read_line ("\015\012\015\012", sub { |
579 |
my ($handle, $line) = @_; |
580 |
|
581 |
# print response header |
582 |
print "HEADER\n$line\n\nBODY\n"; |
583 |
|
584 |
$handle->on_read (sub { |
585 |
# print response body |
586 |
print $_[0]->rbuf; |
587 |
$_[0]->rbuf = ""; |
588 |
}); |
589 |
}); |
590 |
}, sub { |
591 |
my ($fh) = @_; |
592 |
# could call $fh->bind etc. here |
593 |
|
594 |
15 |
595 |
}; |
596 |
|
597 |
Example: connect to a UNIX domain socket. |
598 |
|
599 |
tcp_connect "unix/", "/tmp/.X11-unix/X0", sub { |
600 |
... |
601 |
} |
602 |
|
603 |
=cut |
604 |
|
605 |
sub tcp_connect($$$;$) { |
606 |
my ($host, $port, $connect, $prepare) = @_; |
607 |
|
608 |
# see http://cr.yp.to/docs/connect.html for some background |
609 |
# also http://advogato.org/article/672.html |
610 |
|
611 |
my %state = ( fh => undef ); |
612 |
|
613 |
# name/service to type/sockaddr resolution |
614 |
resolve_sockaddr $host, $port, 0, 0, 0, sub { |
615 |
my @target = @_; |
616 |
|
617 |
$state{next} = sub { |
618 |
return unless exists $state{fh}; |
619 |
|
620 |
my $target = shift @target |
621 |
or do { |
622 |
%state = (); |
623 |
return $connect->(); |
624 |
}; |
625 |
|
626 |
my ($domain, $type, $proto, $sockaddr) = @$target; |
627 |
|
628 |
# socket creation |
629 |
socket $state{fh}, $domain, $type, $proto |
630 |
or return $state{next}(); |
631 |
|
632 |
fh_nonblocking $state{fh}, 1; |
633 |
|
634 |
my $timeout = $prepare && $prepare->($state{fh}); |
635 |
|
636 |
$timeout ||= 30 if AnyEvent::WIN32; |
637 |
|
638 |
$state{to} = AnyEvent->timer (after => $timeout, cb => sub { |
639 |
$! = &Errno::ETIMEDOUT; |
640 |
$state{next}(); |
641 |
}) if $timeout; |
642 |
|
643 |
# called when the connect was successful, which, |
644 |
# in theory, could be the case immediately (but never is in practise) |
645 |
my $connected = sub { |
646 |
delete $state{ww}; |
647 |
delete $state{to}; |
648 |
|
649 |
# we are connected, or maybe there was an error |
650 |
if (my $sin = getpeername $state{fh}) { |
651 |
my ($port, $host) = unpack_sockaddr $sin; |
652 |
|
653 |
my $guard = guard { |
654 |
%state = (); |
655 |
}; |
656 |
|
657 |
$connect->($state{fh}, format_address $host, $port, sub { |
658 |
$guard->cancel; |
659 |
$state{next}(); |
660 |
}); |
661 |
} else { |
662 |
# dummy read to fetch real error code |
663 |
sysread $state{fh}, my $buf, 1 if $! == &Errno::ENOTCONN; |
664 |
$state{next}(); |
665 |
} |
666 |
}; |
667 |
|
668 |
# now connect |
669 |
if (connect $state{fh}, $sockaddr) { |
670 |
$connected->(); |
671 |
} elsif ($! == &Errno::EINPROGRESS # POSIX |
672 |
|| $! == &Errno::EWOULDBLOCK |
673 |
# WSAEINPROGRESS intentionally not checked - it means something else entirely |
674 |
|| $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt |
675 |
|| $! == AnyEvent::Util::WSAEWOULDBLOCK) { |
676 |
$state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $connected); |
677 |
} else { |
678 |
$state{next}(); |
679 |
} |
680 |
}; |
681 |
|
682 |
$! = &Errno::ENXIO; |
683 |
$state{next}(); |
684 |
}; |
685 |
|
686 |
defined wantarray && guard { %state = () } |
687 |
} |
688 |
|
689 |
=item $guard = tcp_server $host, $service, $accept_cb[, $prepare_cb] |
690 |
|
691 |
Create and bind a stream socket to the given host, and port, set the |
692 |
SO_REUSEADDR flag (if applicable) and call C<listen>. Unlike the name |
693 |
implies, this function can also bind on UNIX domain sockets. |
694 |
|
695 |
For internet sockets, C<$host> must be an IPv4 or IPv6 address (or |
696 |
C<undef>, in which case it binds either to C<0> or to C<::>, depending |
697 |
on whether IPv4 or IPv6 is the preferred protocol, and maybe to both in |
698 |
future versions, as applicable). |
699 |
|
700 |
To bind to the IPv4 wildcard address, use C<0>, to bind to the IPv6 |
701 |
wildcard address, use C<::>. |
702 |
|
703 |
The port is specified by C<$service>, which must be either a service name or |
704 |
a numeric port number (or C<0> or C<undef>, in which case an ephemeral |
705 |
port will be used). |
706 |
|
707 |
For UNIX domain sockets, C<$host> must be C<unix/> and C<$service> must be |
708 |
the absolute pathname of the socket. This function will try to C<unlink> |
709 |
the socket before it tries to bind to it. See SECURITY CONSIDERATIONS, |
710 |
below. |
711 |
|
712 |
For each new connection that could be C<accept>ed, call the C<< |
713 |
$accept_cb->($fh, $host, $port) >> with the file handle (in non-blocking |
714 |
mode) as first and the peer host and port as second and third arguments |
715 |
(see C<tcp_connect> for details). |
716 |
|
717 |
Croaks on any errors it can detect before the listen. |
718 |
|
719 |
If called in non-void context, then this function returns a guard object |
720 |
whose lifetime it tied to the TCP server: If the object gets destroyed, |
721 |
the server will be stopped (but existing accepted connections will |
722 |
continue). |
723 |
|
724 |
If you need more control over the listening socket, you can provide a |
725 |
C<< $prepare_cb->($fh, $host, $port) >>, which is called just before the |
726 |
C<listen ()> call, with the listen file handle as first argument, and IP |
727 |
address and port number of the local socket endpoint as second and third |
728 |
arguments. |
729 |
|
730 |
It should return the length of the listen queue (or C<0> for the default). |
731 |
|
732 |
Note to IPv6 users: RFC-compliant behaviour for IPv6 sockets listening on |
733 |
C<::> is to bind to both IPv6 and IPv4 addresses by default on dual-stack |
734 |
hosts. Unfortunately, only GNU/Linux seems to implement this properly, so |
735 |
if you want both IPv4 and IPv6 listening sockets you should create the |
736 |
IPv6 socket first and then attempt to bind on the IPv4 socket, but ignore |
737 |
any C<EADDRINUSE> errors. |
738 |
|
739 |
Example: bind on some TCP port on the local machine and tell each client |
740 |
to go away. |
741 |
|
742 |
tcp_server undef, undef, sub { |
743 |
my ($fh, $host, $port) = @_; |
744 |
|
745 |
syswrite $fh, "The internet is full, $host:$port. Go away!\015\012"; |
746 |
}, sub { |
747 |
my ($fh, $thishost, $thisport) = @_; |
748 |
warn "bound to $thishost, port $thisport\n"; |
749 |
}; |
750 |
|
751 |
=cut |
752 |
|
753 |
sub tcp_server($$$;$) { |
754 |
my ($host, $service, $accept, $prepare) = @_; |
755 |
|
756 |
$host = $AnyEvent::PROTOCOL{ipv4} < $AnyEvent::PROTOCOL{ipv6} && AF_INET6 |
757 |
? "::" : "0" |
758 |
unless defined $host; |
759 |
|
760 |
my $ipn = parse_address $host |
761 |
or Carp::croak "AnyEvent::Socket::tcp_server: cannot parse '$host' as host address"; |
762 |
|
763 |
my $af = address_family $ipn; |
764 |
|
765 |
my %state; |
766 |
|
767 |
# win32 perl is too stupid to get this right :/ |
768 |
Carp::croak "tcp_server/socket: address family not supported" |
769 |
if AnyEvent::WIN32 && $af == AF_UNIX; |
770 |
|
771 |
socket $state{fh}, $af, SOCK_STREAM, 0 |
772 |
or Carp::croak "tcp_server/socket: $!"; |
773 |
|
774 |
if ($af == AF_INET || $af == AF_INET6) { |
775 |
setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1 |
776 |
or Carp::croak "tcp_server/so_reuseaddr: $!" |
777 |
unless AnyEvent::WIN32; # work around windows bug |
778 |
|
779 |
unless ($service =~ /^\d*$/) { |
780 |
$service = (getservbyname $service, "tcp")[2] |
781 |
or Carp::croak "$service: service unknown" |
782 |
} |
783 |
} elsif ($af == AF_UNIX) { |
784 |
unlink $service; |
785 |
} |
786 |
|
787 |
bind $state{fh}, pack_sockaddr $service, $ipn |
788 |
or Carp::croak "bind: $!"; |
789 |
|
790 |
fh_nonblocking $state{fh}, 1; |
791 |
|
792 |
my $len; |
793 |
|
794 |
if ($prepare) { |
795 |
my ($service, $host) = unpack_sockaddr getsockname $state{fh}; |
796 |
$len = $prepare && $prepare->($state{fh}, format_address $host, $service); |
797 |
} |
798 |
|
799 |
$len ||= 128; |
800 |
|
801 |
listen $state{fh}, $len |
802 |
or Carp::croak "listen: $!"; |
803 |
|
804 |
$state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub { |
805 |
# this closure keeps $state alive |
806 |
while (my $peer = accept my $fh, $state{fh}) { |
807 |
fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not |
808 |
|
809 |
my ($service, $host) = unpack_sockaddr $peer; |
810 |
$accept->($fh, format_address $host, $service); |
811 |
} |
812 |
}); |
813 |
|
814 |
defined wantarray |
815 |
? guard { %state = () } # clear fh and watcher, which breaks the circular dependency |
816 |
: () |
817 |
} |
818 |
|
819 |
1; |
820 |
|
821 |
=back |
822 |
|
823 |
=head1 SECURITY CONSIDERATIONS |
824 |
|
825 |
This module is quite powerful, with with power comes the ability to abuse |
826 |
as well: If you accept "hostnames" and ports from untrusted sources, |
827 |
then note that this can be abused to delete files (host=C<unix/>). This |
828 |
is not really a problem with this module, however, as blindly accepting |
829 |
any address and protocol and trying to bind a server or connect to it is |
830 |
harmful in general. |
831 |
|
832 |
=head1 AUTHOR |
833 |
|
834 |
Marc Lehmann <schmorp@schmorp.de> |
835 |
http://home.schmorp.de/ |
836 |
|
837 |
=cut |
838 |
|