ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/AnyEvent/lib/AnyEvent/Socket.pm
Revision: 1.35
Committed: Wed May 28 21:23:41 2008 UTC (16 years, 1 month ago) by root
Branch: MAIN
Changes since 1.34: +36 -27 lines
Log Message:
*** empty log message ***

File Contents

# User Rev Content
1 root 1.7 =head1 NAME
2 elmex 1.1
3 root 1.7 AnyEvent::Socket - useful IPv4 and IPv6 stuff.
4 elmex 1.1
5 root 1.7 =head1 SYNOPSIS
6 elmex 1.1
7 root 1.7 use AnyEvent::Socket;
8 elmex 1.1
9 root 1.18 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 root 1.19 # 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 root 1.7 =head1 DESCRIPTION
24 elmex 1.1
25 root 1.7 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 elmex 1.1
29 root 1.7 All functions documented without C<AnyEvent::Socket::> prefix are exported
30     by default.
31 elmex 1.1
32 root 1.7 =over 4
33 elmex 1.1
34 root 1.7 =cut
35 elmex 1.1
36 root 1.7 package AnyEvent::Socket;
37 elmex 1.1
38 root 1.7 no warnings;
39     use strict;
40 elmex 1.1
41 root 1.7 use Carp ();
42     use Errno ();
43 root 1.34 use Socket qw(AF_INET AF_UNIX SOCK_STREAM SOCK_DGRAM SOL_SOCKET SO_REUSEADDR);
44 elmex 1.1
45 root 1.30 use AnyEvent ();
46 root 1.21 use AnyEvent::Util qw(guard fh_nonblocking AF_INET6);
47 root 1.17 use AnyEvent::DNS ();
48 elmex 1.1
49 root 1.7 use base 'Exporter';
50 elmex 1.2
51 root 1.34 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 elmex 1.2
61 root 1.7 our $VERSION = '1.0';
62 elmex 1.1
63 root 1.9 =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 root 1.14 =item $ipn = parse_ipv6 $textual_ipv6_address
92 root 1.9
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 root 1.26 forms supported by parse_ipv4). Note that scope-id's are not supported
98     (and will not parse).
99 root 1.12
100     This function works similarly to C<inet_pton AF_INET6, ...>.
101 root 1.9
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 root 1.11 unless (defined $t) {
112 root 1.9 ($h, $t) = (undef, $h);
113     }
114    
115     my @h = split /:/, $h;
116     my @t = split /:/, $t;
117    
118 root 1.14 # check for ipv4 tail
119 root 1.9 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 root 1.11 return undef unless @h + @t == 8 || $_[0] =~ /::/;
130 root 1.9
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 root 1.7 }
140 elmex 1.1
141 root 1.34 sub parse_unix($) {
142     $_[0] eq "unix/"
143     ? pack "S", AF_UNIX
144     : undef
145 root 1.11
146 root 1.34 }
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 root 1.11
158     =cut
159    
160 root 1.34 sub parse_address($) {
161     &parse_ipv4 || &parse_ipv6 || &parse_unix
162 root 1.11 }
163    
164 root 1.34 *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 root 1.11
181 root 1.34 =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 root 1.11
188 root 1.12 This function works similarly to C<inet_ntop AF_INET || AF_INET6, ...>,
189     except it automatically detects the address type.
190    
191 root 1.34 Returns C<undef> if it cannot detect the type.
192    
193 root 1.11 =cut
194    
195 root 1.34 sub format_address;
196     sub format_address($) {
197     my $af = address_family $_[0];
198     if ($af == AF_INET) {
199 root 1.11 return join ".", unpack "C4", $_[0]
200 root 1.34 } 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 root 1.11 # v4mapped
206 root 1.34 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 root 1.11 } else {
211     my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];
212    
213 root 1.21 $ip =~ s/^0:(?:0:)*(0$)?/::/
214 root 1.11 or $ip =~ s/(:0)+$/::/
215     or $ip =~ s/(:0)+/:/;
216     return $ip
217     }
218 root 1.34 } elsif ($af == AF_UNIX) {
219     return "unix/"
220 root 1.11 } else {
221     return undef
222     }
223     }
224    
225 root 1.34 *format_ip = \&format_address;
226    
227 root 1.7 =item inet_aton $name_or_address, $cb->(@addresses)
228 elmex 1.1
229 root 1.7 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 elmex 1.2
234 root 1.7 Unlike the L<Socket> function of the same name, you can get multiple IPv4
235 root 1.34 and IPv6 addresses as result (and maybe even other adrdess types).
236 elmex 1.2
237 root 1.7 =cut
238 elmex 1.2
239 root 1.7 sub inet_aton {
240     my ($name, $cb) = @_;
241 elmex 1.2
242 root 1.9 if (my $ipn = &parse_ipv4) {
243     $cb->($ipn);
244     } elsif (my $ipn = &parse_ipv6) {
245     $cb->($ipn);
246 root 1.7 } elsif ($name eq "localhost") { # rfc2606 et al.
247 root 1.9 $cb->(v127.0.0.1, v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1);
248 root 1.7 } else {
249     require AnyEvent::DNS;
250 elmex 1.2
251 root 1.7 # simple, bad suboptimal algorithm
252     AnyEvent::DNS::a ($name, sub {
253     if (@_) {
254 root 1.9 $cb->(map +(parse_ipv4 $_), @_);
255 root 1.7 } else {
256 root 1.8 $cb->();
257     #AnyEvent::DNS::aaaa ($name, $cb); need inet_pton
258 root 1.7 }
259     });
260     }
261     }
262 elmex 1.2
263 root 1.32 # 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 root 1.34 =item $sa = AnyEvent::Socket::pack_sockaddr $service, $host
271 root 1.15
272 root 1.34 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 root 1.15
277     =cut
278    
279     sub pack_sockaddr($$) {
280 root 1.34 my $af = address_family $_[1];
281    
282     if ($af == AF_INET) {
283 root 1.15 Socket::pack_sockaddr_in $_[0], $_[1]
284 root 1.34 } elsif ($af == AF_INET6) {
285 root 1.32 pack "$pack_family nL a16 L",
286 root 1.21 AF_INET6,
287 root 1.15 $_[0], # port
288     0, # flowinfo
289     $_[1], # addr
290     0 # scope id
291 root 1.34 } elsif ($af == AF_UNIX) {
292     Socket::pack_sockaddr_un $_[0]
293 root 1.15 } else {
294     Carp::croak "pack_sockaddr: invalid host";
295     }
296     }
297    
298 root 1.34 =item ($service, $host) = AnyEvent::Socket::unpack_sockaddr $sa
299 root 1.15
300     Unpack the given binary sockaddr structure (as used by bind, getpeername
301 root 1.34 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 root 1.15
306 root 1.34 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 root 1.15
310     =cut
311    
312     sub unpack_sockaddr($) {
313 root 1.31 my $af = Socket::sockaddr_family $_[0];
314 root 1.15
315 root 1.23 if ($af == AF_INET) {
316 root 1.15 Socket::unpack_sockaddr_in $_[0]
317 root 1.21 } elsif ($af == AF_INET6) {
318     unpack "x2 n x4 a16", $_[0]
319 root 1.34 } elsif ($af == AF_UNIX) {
320 root 1.35 ((Socket::unpack_sockaddr_un $_[0]), pack "S", AF_UNIX)
321 root 1.15 } else {
322     Carp::croak "unpack_sockaddr: unsupported protocol family $af";
323     }
324     }
325    
326 root 1.34 =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 root 1.35 or Carp::croak "$service/$proto: service unknown";
406 root 1.34 }
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     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     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     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 root 1.15 =item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]
494 elmex 1.1
495 root 1.15 This is a convenience function that creates a TCP socket and makes a 100%
496 root 1.34 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 root 1.7
502 root 1.8 If both C<$host> and C<$port> are names, then this function will use SRV
503 root 1.15 records to locate the real target(s).
504 root 1.8
505 root 1.15 In either case, it will create a list of target hosts (e.g. for multihomed
506 root 1.17 hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to
507 root 1.15 each in turn.
508 root 1.7
509     If the connect is successful, then the C<$connect_cb> will be invoked with
510 root 1.17 the socket file handle (in non-blocking mode) as first and the peer host
511 root 1.7 (as a textual IP address) and peer port as second and third arguments,
512 root 1.15 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 root 1.7
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 root 1.17 indicating a DNS resolution failure).
523 root 1.7
524 root 1.17 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 root 1.7
527 root 1.15 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 root 1.7 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 root 1.17 Note that the socket could be either a IPv4 TCP socket or an IPv6 TCP
540 root 1.7 socket (although only IPv4 is currently supported by this module).
541    
542 root 1.28 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 root 1.27
551 root 1.7 Simple Example: connect to localhost on port 22.
552    
553 root 1.8 tcp_connect localhost => 22, sub {
554 root 1.7 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 elmex 1.2
594 root 1.7 15
595     };
596 elmex 1.2
597 root 1.34 Example: connect to a UNIX domain socket.
598    
599     tcp_connect "unix/", "/tmp/.X11-unix/X0", sub {
600     ...
601     }
602    
603 root 1.7 =cut
604 elmex 1.2
605 root 1.7 sub tcp_connect($$$;$) {
606     my ($host, $port, $connect, $prepare) = @_;
607 elmex 1.2
608 root 1.7 # see http://cr.yp.to/docs/connect.html for some background
609 root 1.33 # also http://advogato.org/article/672.html
610 elmex 1.2
611 root 1.7 my %state = ( fh => undef );
612 elmex 1.2
613 root 1.33 # name/service to type/sockaddr resolution
614 root 1.34 resolve_sockaddr $host, $port, 0, 0, 0, sub {
615 root 1.15 my @target = @_;
616 root 1.7
617 root 1.15 $state{next} = sub {
618     return unless exists $state{fh};
619 root 1.7
620 root 1.15 my $target = shift @target
621     or do {
622     %state = ();
623     return $connect->();
624     };
625 root 1.7
626 root 1.15 my ($domain, $type, $proto, $sockaddr) = @$target;
627 root 1.7
628 root 1.15 # socket creation
629     socket $state{fh}, $domain, $type, $proto
630     or return $state{next}();
631    
632     fh_nonblocking $state{fh}, 1;
633    
634 root 1.27 my $timeout = $prepare && $prepare->($state{fh});
635    
636 root 1.30 $timeout ||= 30 if AnyEvent::WIN32;
637 root 1.15
638 root 1.27 $state{to} = AnyEvent->timer (after => $timeout, cb => sub {
639     $! = &Errno::ETIMEDOUT;
640     $state{next}();
641     }) if $timeout;
642 root 1.7
643 root 1.15 # 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 root 1.34 $connect->($state{fh}, format_address $host, $port, sub {
658 root 1.15 $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 elmex 1.1
668 root 1.15 # now connect
669     if (connect $state{fh}, $sockaddr) {
670     $connected->();
671 root 1.33 } 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 root 1.15 $state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $connected);
677 root 1.7 } else {
678 root 1.29 $state{next}();
679 root 1.7 }
680     };
681 elmex 1.1
682 root 1.15 $! = &Errno::ENXIO;
683     $state{next}();
684 root 1.7 };
685 elmex 1.1
686 root 1.15 defined wantarray && guard { %state = () }
687 elmex 1.1 }
688    
689 root 1.35 =item $guard = tcp_server $host, $service, $accept_cb[, $prepare_cb]
690 elmex 1.1
691 root 1.35 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 on
697     whether IPv4 or IPv6 is the preferred protocol).
698 root 1.21
699     To bind to the IPv4 wildcard address, use C<0>, to bind to the IPv6
700     wildcard address, use C<::>.
701    
702 root 1.35 The port is specified by C<$service>, which must be either a service name or
703 root 1.21 a numeric port number (or C<0> or C<undef>, in which case an ephemeral
704     port will be used).
705    
706 root 1.35 For UNIX domain sockets, C<$host> must be C<unix/> and C<$service> must be
707     the absolute pathname of the socket. This function will try to C<unlink>
708     the socket before it tries to bind to it. See SECURITY CONSIDERATIONS,
709     below.
710    
711 root 1.21 For each new connection that could be C<accept>ed, call the C<<
712     $accept_cb->($fh, $host, $port) >> with the file handle (in non-blocking
713     mode) as first and the peer host and port as second and third arguments
714     (see C<tcp_connect> for details).
715    
716     Croaks on any errors it can detect before the listen.
717 elmex 1.1
718 root 1.7 If called in non-void context, then this function returns a guard object
719 root 1.17 whose lifetime it tied to the TCP server: If the object gets destroyed,
720 root 1.7 the server will be stopped (but existing accepted connections will
721     continue).
722 elmex 1.1
723 root 1.7 If you need more control over the listening socket, you can provide a
724 root 1.21 C<< $prepare_cb->($fh, $host, $port) >>, which is called just before the
725     C<listen ()> call, with the listen file handle as first argument, and IP
726     address and port number of the local socket endpoint as second and third
727     arguments.
728 elmex 1.2
729 root 1.7 It should return the length of the listen queue (or C<0> for the default).
730 elmex 1.2
731 root 1.24 Example: bind on some TCP port on the local machine and tell each client
732 root 1.7 to go away.
733 elmex 1.2
734 root 1.24 tcp_server undef, undef, sub {
735 root 1.7 my ($fh, $host, $port) = @_;
736 elmex 1.1
737 root 1.7 syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";
738 root 1.24 }, sub {
739     my ($fh, $thishost, $thisport) = @_;
740     warn "bound to $thishost, port $thisport\n";
741 root 1.7 };
742 elmex 1.1
743 root 1.7 =cut
744 elmex 1.1
745 root 1.7 sub tcp_server($$$;$) {
746 root 1.35 my ($host, $service, $accept, $prepare) = @_;
747 elmex 1.1
748 root 1.25 $host = $AnyEvent::PROTOCOL{ipv4} < $AnyEvent::PROTOCOL{ipv6} && AF_INET6
749 root 1.22 ? "::" : "0"
750 root 1.21 unless defined $host;
751    
752 root 1.34 my $ipn = parse_address $host
753     or Carp::croak "AnyEvent::Socket::tcp_server: cannot parse '$host' as host address";
754 root 1.21
755 root 1.35 my $af = address_family $ipn;
756 root 1.21
757 root 1.7 my %state;
758 elmex 1.1
759 root 1.35 socket $state{fh}, $af, SOCK_STREAM, 0
760 root 1.7 or Carp::croak "socket: $!";
761 elmex 1.1
762 root 1.35 if ($af == AF_INET || $af == AF_INET6) {
763     setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1
764     or Carp::croak "so_reuseaddr: $!"
765     unless !AnyEvent::WIN32; # work around windows bug
766    
767     unless ($service =~ /^\d*$/) {
768     $service = (getservbyname $service, "tcp")[2]
769     or Carp::croak "$service: service unknown"
770     }
771     } elsif ($af == AF_UNIX) {
772     unlink $service;
773     }
774 elmex 1.1
775 root 1.35 bind $state{fh}, pack_sockaddr $service, $ipn
776 root 1.7 or Carp::croak "bind: $!";
777 elmex 1.1
778 root 1.7 fh_nonblocking $state{fh}, 1;
779 elmex 1.1
780 root 1.21 my $len;
781    
782     if ($prepare) {
783 root 1.35 my ($service, $host) = unpack_sockaddr getsockname $state{fh};
784     $len = $prepare && $prepare->($state{fh}, format_address $host, $service);
785 root 1.21 }
786    
787     $len ||= 128;
788 elmex 1.1
789 root 1.7 listen $state{fh}, $len
790     or Carp::croak "listen: $!";
791 elmex 1.1
792 root 1.7 $state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {
793     # this closure keeps $state alive
794     while (my $peer = accept my $fh, $state{fh}) {
795     fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not
796 root 1.35 my ($service, $host) = unpack_sockaddr $peer;
797     $accept->($fh, format_address $host, $service);
798 root 1.7 }
799     });
800 elmex 1.1
801 root 1.7 defined wantarray
802     ? guard { %state = () } # clear fh and watcher, which breaks the circular dependency
803     : ()
804 elmex 1.1 }
805    
806 root 1.7 1;
807    
808 elmex 1.1 =back
809    
810     =head1 AUTHOR
811    
812 root 1.7 Marc Lehmann <schmorp@schmorp.de>
813     http://home.schmorp.de/
814 elmex 1.1
815     =cut
816