lib/AnyEvent/Socket.pm

=head1 NAME

AnyEvent::Socket - useful IPv4 and IPv6 stuff.

=head1 SYNOPSIS

 use AnyEvent::Socket;

 tcp_connect "gameserver.deliantra.net", 13327, sub {
    my ($fh) = @_
       or die "gameserver.deliantra.net connect failed: $!";

    # enjoy your filehandle
 };

 # a simple tcp server
 tcp_server undef, 8888, sub {
    my ($fh, $host, $port) = @_;

    syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";
 };

=head1 DESCRIPTION

This module implements various utility functions for handling internet
protocol addresses and sockets, in an as transparent and simple way as
possible.

All functions documented without C<AnyEvent::Socket::> prefix are exported
by default.

=over 4

=cut

package AnyEvent::Socket;

no warnings;
use strict;

use Carp ();
use Errno ();
use Socket qw(AF_INET SOCK_STREAM SOCK_DGRAM SOL_SOCKET SO_REUSEADDR);

use AnyEvent ();
use AnyEvent::Util qw(guard fh_nonblocking AF_INET6);
use AnyEvent::DNS ();

use base 'Exporter';

our @EXPORT = qw(parse_ipv4 parse_ipv6 parse_ip format_ip inet_aton tcp_server tcp_connect);

our $VERSION = '1.0';

=item $ipn = parse_ipv4 $dotted_quad

Tries to parse the given dotted quad IPv4 address and return it in
octet form (or undef when it isn't in a parsable format). Supports all
forms specified by POSIX (e.g. C<10.0.0.1>, C<10.1>, C<10.0x020304>,
C<0x12345678> or C<0377.0377.0377.0377>).

=cut

sub parse_ipv4($) {
   $_[0] =~ /^      (?: 0x[0-9a-fA-F]+ | 0[0-7]* | [1-9][0-9]* )
              (?:\. (?: 0x[0-9a-fA-F]+ | 0[0-7]* | [1-9][0-9]* ) ){0,3}$/x
      or return undef;

   @_ = map /^0/ ? oct : $_, split /\./, $_[0];

   # check leading parts against range
   return undef if grep $_ >= 256, @_[0 .. @_ - 2];

   # check trailing part against range
   return undef if $_[-1] >= 1 << (8 * (4 - $#_));

   pack "N", (pop)
             + ($_[0] << 24)
             + ($_[1] << 16)
             + ($_[2] <<  8);
}

=item $ipn = parse_ipv6 $textual_ipv6_address

Tries to parse the given IPv6 address and return it in
octet form (or undef when it isn't in a parsable format).

Should support all forms specified by RFC 2373 (and additionally all IPv4
forms supported by parse_ipv4).

This function works similarly to C<inet_pton AF_INET6, ...>.

=cut

sub parse_ipv6($) {
   # quick test to avoid longer processing
   my $n = $_[0] =~ y/://;
   return undef if $n < 2 || $n > 8;

   my ($h, $t) = split /::/, $_[0], 2;

   unless (defined $t) {
      ($h, $t) = (undef, $h);
   }

   my @h = split /:/, $h;
   my @t = split /:/, $t;

   # check for ipv4 tail
   if (@t && $t[-1]=~ /\./) {
      return undef if $n > 6;

      my $ipn = parse_ipv4 pop @t
         or return undef;

      push @t, map +(sprintf "%x", $_), unpack "nn", $ipn;
   }

   # no :: then we need to have exactly 8 components
   return undef unless @h + @t == 8 || $_[0] =~ /::/;

   # now check all parts for validity
   return undef if grep !/^[0-9a-fA-F]{1,4}$/, @h, @t;

   # now pad...
   push @h, 0 while @h + @t < 8;

   # and done
   pack "n*", map hex, @h, @t
}

=item $ipn = parse_ip $text

Combines C<parse_ipv4> and C<parse_ipv6> in one function.

=cut

sub parse_ip($) {
   &parse_ipv4 || &parse_ipv6
}

=item $text = format_ip $ipn

Takes either an IPv4 address (4 octets) or and IPv6 address (16 octets)
and converts it into textual form.

This function works similarly to C<inet_ntop AF_INET || AF_INET6, ...>,
except it automatically detects the address type.

=cut

sub format_ip;
sub format_ip($) {
   if (4 == length $_[0]) {
      return join ".", unpack "C4", $_[0]
   } elsif (16 == length $_[0]) {
      if (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) {
         # v4mapped
         return "::ffff:" . format_ip substr $_[0], 12;
      } else {
         my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];

         $ip =~ s/^0:(?:0:)*(0$)?/::/
            or $ip =~ s/(:0)+$/::/
            or $ip =~ s/(:0)+/:/;
         return $ip
      }
   } else {
      return undef
   }
}

=item inet_aton $name_or_address, $cb->(@addresses)

Works similarly to its Socket counterpart, except that it uses a
callback. Also, if a host has only an IPv6 address, this might be passed
to the callback instead (use the length to detect this - 4 for IPv4, 16
for IPv6).

Unlike the L<Socket> function of the same name, you can get multiple IPv4
and IPv6 addresses as result.

=cut

sub inet_aton {
   my ($name, $cb) = @_;

   if (my $ipn = &parse_ipv4) {
      $cb->($ipn);
   } elsif (my $ipn = &parse_ipv6) {
      $cb->($ipn);
   } elsif ($name eq "localhost") { # rfc2606 et al.
      $cb->(v127.0.0.1, v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1);
   } else {
      require AnyEvent::DNS;

      # simple, bad suboptimal algorithm
      AnyEvent::DNS::a ($name, sub {
         if (@_) {
            $cb->(map +(parse_ipv4 $_), @_);
         } else {
            $cb->();
            #AnyEvent::DNS::aaaa ($name, $cb); need inet_pton
         }
      });
   }
}

=item $sa = AnyEvent::Socket::pack_sockaddr $port, $host

Pack the given port/host combination into a binary sockaddr structure. Handles
both IPv4 and IPv6 host addresses.

=cut

sub pack_sockaddr($$) {
   if (4 == length $_[1]) {
      Socket::pack_sockaddr_in $_[0], $_[1]
   } elsif (16 == length $_[1]) {
      pack "SnL a16 L",
         AF_INET6,
         $_[0], # port
         0,     # flowinfo
         $_[1], # addr
         0      # scope id
   } else {
      Carp::croak "pack_sockaddr: invalid host";
   }
}

=item ($port, $host) = AnyEvent::Socket::unpack_sockaddr $sa

Unpack the given binary sockaddr structure (as used by bind, getpeername
etc.) into a C<$port, $host> combination.

Handles both IPv4 and IPv6 sockaddr structures.

=cut

sub unpack_sockaddr($) {
   my $af = unpack "S", $_[0];

   if ($af == AF_INET) {
      Socket::unpack_sockaddr_in $_[0]
   } elsif ($af == AF_INET6) {
      unpack "x2 n x4 a16", $_[0]
   } else {
      Carp::croak "unpack_sockaddr: unsupported protocol family $af";
   }
}

sub _tcp_port($) {
   $_[0] =~ /^(\d*)$/ and return $1*1;

   (getservbyname $_[0], "tcp")[2]
      or Carp::croak "$_[0]: service unknown"
}

=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]

This is a convenience function that creates a TCP socket and makes a 100%
non-blocking connect to the given C<$host> (which can be a hostname or a
textual IP address) and C<$service> (which can be a numeric port number or
a service name, or a C<servicename=portnumber> string).

If both C<$host> and C<$port> are names, then this function will use SRV
records to locate the real target(s).

In either case, it will create a list of target hosts (e.g. for multihomed
hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to
each in turn.

If the connect is successful, then the C<$connect_cb> will be invoked with
the socket file handle (in non-blocking mode) as first and the peer host
(as a textual IP address) and peer port as second and third arguments,
respectively. The fourth argument is a code reference that you can call
if, for some reason, you don't like this connection, which will cause
C<tcp_connect> to try the next one (or call your callback without any
arguments if there are no more connections). In most cases, you can simply
ignore this argument.

   $cb->($filehandle, $host, $port, $retry)

If the connect is unsuccessful, then the C<$connect_cb> will be invoked
without any arguments and C<$!> will be set appropriately (with C<ENXIO>
indicating a DNS resolution failure).

The file handle is perfect for being plugged into L<AnyEvent::Handle>, but
can be used as a normal perl file handle as well.

Unless called in void context, C<tcp_connect> returns a guard object that
will automatically abort connecting when it gets destroyed (it does not do
anything to the socket after the connect was successful).

Sometimes you need to "prepare" the socket before connecting, for example,
to C<bind> it to some port, or you want a specific connect timeout that
is lower than your kernel's default timeout. In this case you can specify
a second callback, C<$prepare_cb>. It will be called with the file handle
in not-yet-connected state as only argument and must return the connection
timeout value (or C<0>, C<undef> or the empty list to indicate the default
timeout is to be used).

Note that the socket could be either a IPv4 TCP socket or an IPv6 TCP
socket (although only IPv4 is currently supported by this module).

Simple Example: connect to localhost on port 22.

  tcp_connect localhost => 22, sub {
     my $fh = shift
        or die "unable to connect: $!";
     # do something
  };

Complex Example: connect to www.google.com on port 80 and make a simple
GET request without much error handling. Also limit the connection timeout
to 15 seconds.

   tcp_connect "www.google.com", "http",
      sub {
         my ($fh) = @_
            or die "unable to connect: $!";

         my $handle; # avoid direct assignment so on_eof has it in scope.
         $handle = new AnyEvent::Handle
            fh     => $fh,
            on_eof => sub {
               undef $handle; # keep it alive till eof
               warn "done.\n";
            };

         $handle->push_write ("GET / HTTP/1.0\015\012\015\012");

         $handle->push_read_line ("\015\012\015\012", sub {
            my ($handle, $line) = @_;

            # print response header
            print "HEADER\n$line\n\nBODY\n";

            $handle->on_read (sub {
               # print response body
               print $_[0]->rbuf;
               $_[0]->rbuf = "";
            });
         });
      }, sub {
         my ($fh) = @_;
         # could call $fh->bind etc. here

         15
      };

=cut

sub tcp_connect($$$;$) {
   my ($host, $port, $connect, $prepare) = @_;

   # see http://cr.yp.to/docs/connect.html for some background

   my %state = ( fh => undef );

   # name resolution
   AnyEvent::DNS::addr $host, $port, 0, 0, 0, sub {
      my @target = @_;

      $state{next} = sub {
         return unless exists $state{fh};

         my $target = shift @target
            or do {
               %state = ();
               return $connect->();
            };

         my ($domain, $type, $proto, $sockaddr) = @$target;

         # socket creation
         socket $state{fh}, $domain, $type, $proto
            or return $state{next}();

         fh_nonblocking $state{fh}, 1;
         
         # prepare and optional timeout
         if ($prepare) {
            my $timeout = $prepare->($state{fh});

            $state{to} = AnyEvent->timer (after => $timeout, cb => sub {
               $! = &Errno::ETIMEDOUT;
               $state{next}();
            }) if $timeout;
         }

         # called when the connect was successful, which,
         # in theory, could be the case immediately (but never is in practise)
         my $connected = sub {
            delete $state{ww};
            delete $state{to};

            # we are connected, or maybe there was an error
            if (my $sin = getpeername $state{fh}) {
               my ($port, $host) = unpack_sockaddr $sin;

               my $guard = guard {
                  %state = ();
               };

               $connect->($state{fh}, format_ip $host, $port, sub {
                  $guard->cancel;
                  $state{next}();
               });
            } else {
               # dummy read to fetch real error code
               sysread $state{fh}, my $buf, 1 if $! == &Errno::ENOTCONN;
               $state{next}();
            }
         };

         # now connect       
         if (connect $state{fh}, $sockaddr) {
            $connected->();
         } elsif ($! == &Errno::EINPROGRESS || $! == &Errno::EWOULDBLOCK) { # EINPROGRESS is POSIX
            $state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $connected);
         } else {
            %state = ();
            $connect->();
         }
      };

      $! = &Errno::ENXIO;
      $state{next}();
   };

   defined wantarray && guard { %state = () }
}

=item $guard = tcp_server $host, $port, $accept_cb[, $prepare_cb]

Create and bind a TCP socket to the given host, and port, set the
SO_REUSEADDR flag and call C<listen>.

C<$host> must be an IPv4 or IPv6 address (or C<undef>, in which case it
binds either to C<0> or to C<::>, depending on whether IPv4 or IPv6 is the
preferred protocol).

To bind to the IPv4 wildcard address, use C<0>, to bind to the IPv6
wildcard address, use C<::>.

The port is specified by C<$port>, which must be either a service name or
a numeric port number (or C<0> or C<undef>, in which case an ephemeral
port will be used).

For each new connection that could be C<accept>ed, call the C<<
$accept_cb->($fh, $host, $port) >> with the file handle (in non-blocking
mode) as first and the peer host and port as second and third arguments
(see C<tcp_connect> for details).

Croaks on any errors it can detect before the listen.

If called in non-void context, then this function returns a guard object
whose lifetime it tied to the TCP server: If the object gets destroyed,
the server will be stopped (but existing accepted connections will
continue).

If you need more control over the listening socket, you can provide a
C<< $prepare_cb->($fh, $host, $port) >>, which is called just before the
C<listen ()> call, with the listen file handle as first argument, and IP
address and port number of the local socket endpoint as second and third
arguments.

It should return the length of the listen queue (or C<0> for the default).

Example: bind on some TCP port on the local machine and tell each client
to go away.

   tcp_server undef, undef, sub {
      my ($fh, $host, $port) = @_;

      syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";
   }, sub {
      my ($fh, $thishost, $thisport) = @_;
      warn "bound to $thishost, port $thisport\n";
   };

=cut

sub tcp_server($$$;$) {
   my ($host, $port, $accept, $prepare) = @_;

   $host = $AnyEvent::PROTOCOL{ipv4} > $AnyEvent::PROTOCOL{ipv6} && AF_INET6
           ? "::" : "0"
      unless defined $host;

   my $ipn = parse_ip $host
      or Carp::croak "AnyEvent::Socket::tcp_server: cannot parse '$host' as IPv4 or IPv6 address";

   my $domain = 4 == length $ipn ? AF_INET : AF_INET6;

   my %state;

   socket $state{fh}, $domain, SOCK_STREAM, 0
      or Carp::croak "socket: $!";

   setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1
      or Carp::croak "so_reuseaddr: $!";

   bind $state{fh}, pack_sockaddr _tcp_port $port, $ipn
      or Carp::croak "bind: $!";

   fh_nonblocking $state{fh}, 1;

   my $len;

   if ($prepare) {
      my ($port, $host) = unpack_sockaddr getsockname $state{fh};
      $len = $prepare && $prepare->($state{fh}, format_ip $host, $port);
   }
   
   $len ||= 128;

   listen $state{fh}, $len
      or Carp::croak "listen: $!";

   $state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {
      # this closure keeps $state alive
      while (my $peer = accept my $fh, $state{fh}) {
         fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not
         my ($port, $host) = unpack_sockaddr $peer;
         $accept->($fh, format_ip $host, $port);
      }
   });

   defined wantarray
      ? guard { %state = () } # clear fh and watcher, which breaks the circular dependency
      : ()
}

1;

=back

=head1 AUTHOR

 Marc Lehmann <schmorp@schmorp.de>
 http://home.schmorp.de/

=cut

Revision:	1.24
Committed:	Sun May 25 03:44:03 2008 UTC (16 years, 1 month ago) by root
Branch:	MAIN
Changes since 1.23:	+5 -2 lines
Log Message:	* empty log message *
#	Content
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 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(parse_ipv4 parse_ipv6 parse_ip format_ip inet_aton tcp_server tcp_connect);
52
53	our $VERSION = '1.0';
54
55	=item $ipn = parse_ipv4 $dotted_quad
56
57	Tries to parse the given dotted quad IPv4 address and return it in
58	octet form (or undef when it isn't in a parsable format). Supports all
59	forms specified by POSIX (e.g. C<10.0.0.1>, C<10.1>, C<10.0x020304>,
60	C<0x12345678> or C<0377.0377.0377.0377>).
61
62	=cut
63
64	sub parse_ipv4($) {
65	$_[0] =~ /^ (?: 0x[0-9a-fA-F]+ \| 0[0-7]* \| [1-9][0-9]* )
66	(?:\. (?: 0x[0-9a-fA-F]+ \| 0[0-7]* \| [1-9][0-9]* ) ){0,3}$/x
67	or return undef;
68
69	@_ = map /^0/ ? oct : $_, split /\./, $_[0];
70
71	# check leading parts against range
72	return undef if grep $_ >= 256, @_[0 .. @_ - 2];
73
74	# check trailing part against range
75	return undef if $_[-1] >= 1 << (8 * (4 - $#_));
76
77	pack "N", (pop)
78	+ ($_[0] << 24)
79	+ ($_[1] << 16)
80	+ ($_[2] << 8);
81	}
82
83	=item $ipn = parse_ipv6 $textual_ipv6_address
84
85	Tries to parse the given IPv6 address and return it in
86	octet form (or undef when it isn't in a parsable format).
87
88	Should support all forms specified by RFC 2373 (and additionally all IPv4
89	forms supported by parse_ipv4).
90
91	This function works similarly to C<inet_pton AF_INET6, ...>.
92
93	=cut
94
95	sub parse_ipv6($) {
96	# quick test to avoid longer processing
97	my $n = $_[0] =~ y/://;
98	return undef if $n < 2 \|\| $n > 8;
99
100	my ($h, $t) = split /::/, $_[0], 2;
101
102	unless (defined $t) {
103	($h, $t) = (undef, $h);
104	}
105
106	my @h = split /:/, $h;
107	my @t = split /:/, $t;
108
109	# check for ipv4 tail
110	if (@t && $t[-1]=~ /\./) {
111	return undef if $n > 6;
112
113	my $ipn = parse_ipv4 pop @t
114	or return undef;
115
116	push @t, map +(sprintf "%x", $_), unpack "nn", $ipn;
117	}
118
119	# no :: then we need to have exactly 8 components
120	return undef unless @h + @t == 8 \|\| $_[0] =~ /::/;
121
122	# now check all parts for validity
123	return undef if grep !/^[0-9a-fA-F]{1,4}$/, @h, @t;
124
125	# now pad...
126	push @h, 0 while @h + @t < 8;
127
128	# and done
129	pack "n*", map hex, @h, @t
130	}
131
132	=item $ipn = parse_ip $text
133
134	Combines C<parse_ipv4> and C<parse_ipv6> in one function.
135
136	=cut
137
138	sub parse_ip($) {
139	&parse_ipv4 \|\| &parse_ipv6
140	}
141
142	=item $text = format_ip $ipn
143
144	Takes either an IPv4 address (4 octets) or and IPv6 address (16 octets)
145	and converts it into textual form.
146
147	This function works similarly to C<inet_ntop AF_INET \|\| AF_INET6, ...>,
148	except it automatically detects the address type.
149
150	=cut
151
152	sub format_ip;
153	sub format_ip($) {
154	if (4 == length $_[0]) {
155	return join ".", unpack "C4", $_[0]
156	} elsif (16 == length $_[0]) {
157	if (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) {
158	# v4mapped
159	return "::ffff:" . format_ip substr $_[0], 12;
160	} else {
161	my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];
162
163	$ip =~ s/^0:(?:0:)*(0$)?/::/
164	or $ip =~ s/(:0)+$/::/
165	or $ip =~ s/(:0)+/:/;
166	return $ip
167	}
168	} else {
169	return undef
170	}
171	}
172
173	=item inet_aton $name_or_address, $cb->(@addresses)
174
175	Works similarly to its Socket counterpart, except that it uses a
176	callback. Also, if a host has only an IPv6 address, this might be passed
177	to the callback instead (use the length to detect this - 4 for IPv4, 16
178	for IPv6).
179
180	Unlike the L<Socket> function of the same name, you can get multiple IPv4
181	and IPv6 addresses as result.
182
183	=cut
184
185	sub inet_aton {
186	my ($name, $cb) = @_;
187
188	if (my $ipn = &parse_ipv4) {
189	$cb->($ipn);
190	} elsif (my $ipn = &parse_ipv6) {
191	$cb->($ipn);
192	} elsif ($name eq "localhost") { # rfc2606 et al.
193	$cb->(v127.0.0.1, v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1);
194	} else {
195	require AnyEvent::DNS;
196
197	# simple, bad suboptimal algorithm
198	AnyEvent::DNS::a ($name, sub {
199	if (@_) {
200	$cb->(map +(parse_ipv4 $_), @_);
201	} else {
202	$cb->();
203	#AnyEvent::DNS::aaaa ($name, $cb); need inet_pton
204	}
205	});
206	}
207	}
208
209	=item $sa = AnyEvent::Socket::pack_sockaddr $port, $host
210
211	Pack the given port/host combination into a binary sockaddr structure. Handles
212	both IPv4 and IPv6 host addresses.
213
214	=cut
215
216	sub pack_sockaddr($$) {
217	if (4 == length $_[1]) {
218	Socket::pack_sockaddr_in $_[0], $_[1]
219	} elsif (16 == length $_[1]) {
220	pack "SnL a16 L",
221	AF_INET6,
222	$_[0], # port
223	0, # flowinfo
224	$_[1], # addr
225	0 # scope id
226	} else {
227	Carp::croak "pack_sockaddr: invalid host";
228	}
229	}
230
231	=item ($port, $host) = AnyEvent::Socket::unpack_sockaddr $sa
232
233	Unpack the given binary sockaddr structure (as used by bind, getpeername
234	etc.) into a C<$port, $host> combination.
235
236	Handles both IPv4 and IPv6 sockaddr structures.
237
238	=cut
239
240	sub unpack_sockaddr($) {
241	my $af = unpack "S", $_[0];
242
243	if ($af == AF_INET) {
244	Socket::unpack_sockaddr_in $_[0]
245	} elsif ($af == AF_INET6) {
246	unpack "x2 n x4 a16", $_[0]
247	} else {
248	Carp::croak "unpack_sockaddr: unsupported protocol family $af";
249	}
250	}
251
252	sub _tcp_port($) {
253	$_[0] =~ /^(\d)$/ and return $11;
254
255	(getservbyname $_[0], "tcp")[2]
256	or Carp::croak "$_[0]: service unknown"
257	}
258
259	=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]
260
261	This is a convenience function that creates a TCP socket and makes a 100%
262	non-blocking connect to the given C<$host> (which can be a hostname or a
263	textual IP address) and C<$service> (which can be a numeric port number or
264	a service name, or a C<servicename=portnumber> string).
265
266	If both C<$host> and C<$port> are names, then this function will use SRV
267	records to locate the real target(s).
268
269	In either case, it will create a list of target hosts (e.g. for multihomed
270	hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to
271	each in turn.
272
273	If the connect is successful, then the C<$connect_cb> will be invoked with
274	the socket file handle (in non-blocking mode) as first and the peer host
275	(as a textual IP address) and peer port as second and third arguments,
276	respectively. The fourth argument is a code reference that you can call
277	if, for some reason, you don't like this connection, which will cause
278	C<tcp_connect> to try the next one (or call your callback without any
279	arguments if there are no more connections). In most cases, you can simply
280	ignore this argument.
281
282	$cb->($filehandle, $host, $port, $retry)
283
284	If the connect is unsuccessful, then the C<$connect_cb> will be invoked
285	without any arguments and C<$!> will be set appropriately (with C<ENXIO>
286	indicating a DNS resolution failure).
287
288	The file handle is perfect for being plugged into L<AnyEvent::Handle>, but
289	can be used as a normal perl file handle as well.
290
291	Unless called in void context, C<tcp_connect> returns a guard object that
292	will automatically abort connecting when it gets destroyed (it does not do
293	anything to the socket after the connect was successful).
294
295	Sometimes you need to "prepare" the socket before connecting, for example,
296	to C<bind> it to some port, or you want a specific connect timeout that
297	is lower than your kernel's default timeout. In this case you can specify
298	a second callback, C<$prepare_cb>. It will be called with the file handle
299	in not-yet-connected state as only argument and must return the connection
300	timeout value (or C<0>, C<undef> or the empty list to indicate the default
301	timeout is to be used).
302
303	Note that the socket could be either a IPv4 TCP socket or an IPv6 TCP
304	socket (although only IPv4 is currently supported by this module).
305
306	Simple Example: connect to localhost on port 22.
307
308	tcp_connect localhost => 22, sub {
309	my $fh = shift
310	or die "unable to connect: $!";
311	# do something
312	};
313
314	Complex Example: connect to www.google.com on port 80 and make a simple
315	GET request without much error handling. Also limit the connection timeout
316	to 15 seconds.
317
318	tcp_connect "www.google.com", "http",
319	sub {
320	my ($fh) = @_
321	or die "unable to connect: $!";
322
323	my $handle; # avoid direct assignment so on_eof has it in scope.
324	$handle = new AnyEvent::Handle
325	fh => $fh,
326	on_eof => sub {
327	undef $handle; # keep it alive till eof
328	warn "done.\n";
329	};
330
331	$handle->push_write ("GET / HTTP/1.0\015\012\015\012");
332
333	$handle->push_read_line ("\015\012\015\012", sub {
334	my ($handle, $line) = @_;
335
336	# print response header
337	print "HEADER\n$line\n\nBODY\n";
338
339	$handle->on_read (sub {
340	# print response body
341	print $_[0]->rbuf;
342	$_[0]->rbuf = "";
343	});
344	});
345	}, sub {
346	my ($fh) = @_;
347	# could call $fh->bind etc. here
348
349	15
350	};
351
352	=cut
353
354	sub tcp_connect($$$;$) {
355	my ($host, $port, $connect, $prepare) = @_;
356
357	# see http://cr.yp.to/docs/connect.html for some background
358
359	my %state = ( fh => undef );
360
361	# name resolution
362	AnyEvent::DNS::addr $host, $port, 0, 0, 0, sub {
363	my @target = @_;
364
365	$state{next} = sub {
366	return unless exists $state{fh};
367
368	my $target = shift @target
369	or do {
370	%state = ();
371	return $connect->();
372	};
373
374	my ($domain, $type, $proto, $sockaddr) = @$target;
375
376	# socket creation
377	socket $state{fh}, $domain, $type, $proto
378	or return $state{next}();
379
380	fh_nonblocking $state{fh}, 1;
381
382	# prepare and optional timeout
383	if ($prepare) {
384	my $timeout = $prepare->($state{fh});
385
386	$state{to} = AnyEvent->timer (after => $timeout, cb => sub {
387	$! = &Errno::ETIMEDOUT;
388	$state{next}();
389	}) if $timeout;
390	}
391
392	# called when the connect was successful, which,
393	# in theory, could be the case immediately (but never is in practise)
394	my $connected = sub {
395	delete $state{ww};
396	delete $state{to};
397
398	# we are connected, or maybe there was an error
399	if (my $sin = getpeername $state{fh}) {
400	my ($port, $host) = unpack_sockaddr $sin;
401
402	my $guard = guard {
403	%state = ();
404	};
405
406	$connect->($state{fh}, format_ip $host, $port, sub {
407	$guard->cancel;
408	$state{next}();
409	});
410	} else {
411	# dummy read to fetch real error code
412	sysread $state{fh}, my $buf, 1 if $! == &Errno::ENOTCONN;
413	$state{next}();
414	}
415	};
416
417	# now connect
418	if (connect $state{fh}, $sockaddr) {
419	$connected->();
420	} elsif ($! == &Errno::EINPROGRESS \|\| $! == &Errno::EWOULDBLOCK) { # EINPROGRESS is POSIX
421	$state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $connected);
422	} else {
423	%state = ();
424	$connect->();
425	}
426	};
427
428	$! = &Errno::ENXIO;
429	$state{next}();
430	};
431
432	defined wantarray && guard { %state = () }
433	}
434
435	=item $guard = tcp_server $host, $port, $accept_cb[, $prepare_cb]
436
437	Create and bind a TCP socket to the given host, and port, set the
438	SO_REUSEADDR flag and call C<listen>.
439
440	C<$host> must be an IPv4 or IPv6 address (or C<undef>, in which case it
441	binds either to C<0> or to C<::>, depending on whether IPv4 or IPv6 is the
442	preferred protocol).
443
444	To bind to the IPv4 wildcard address, use C<0>, to bind to the IPv6
445	wildcard address, use C<::>.
446
447	The port is specified by C<$port>, which must be either a service name or
448	a numeric port number (or C<0> or C<undef>, in which case an ephemeral
449	port will be used).
450
451	For each new connection that could be C<accept>ed, call the C<<
452	$accept_cb->($fh, $host, $port) >> with the file handle (in non-blocking
453	mode) as first and the peer host and port as second and third arguments
454	(see C<tcp_connect> for details).
455
456	Croaks on any errors it can detect before the listen.
457
458	If called in non-void context, then this function returns a guard object
459	whose lifetime it tied to the TCP server: If the object gets destroyed,
460	the server will be stopped (but existing accepted connections will
461	continue).
462
463	If you need more control over the listening socket, you can provide a
464	C<< $prepare_cb->($fh, $host, $port) >>, which is called just before the
465	C<listen ()> call, with the listen file handle as first argument, and IP
466	address and port number of the local socket endpoint as second and third
467	arguments.
468
469	It should return the length of the listen queue (or C<0> for the default).
470
471	Example: bind on some TCP port on the local machine and tell each client
472	to go away.
473
474	tcp_server undef, undef, sub {
475	my ($fh, $host, $port) = @_;
476
477	syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";
478	}, sub {
479	my ($fh, $thishost, $thisport) = @_;
480	warn "bound to $thishost, port $thisport\n";
481	};
482
483	=cut
484
485	sub tcp_server($$$;$) {
486	my ($host, $port, $accept, $prepare) = @_;
487
488	$host = $AnyEvent::PROTOCOL{ipv4} > $AnyEvent::PROTOCOL{ipv6} && AF_INET6
489	? "::" : "0"
490	unless defined $host;
491
492	my $ipn = parse_ip $host
493	or Carp::croak "AnyEvent::Socket::tcp_server: cannot parse '$host' as IPv4 or IPv6 address";
494
495	my $domain = 4 == length $ipn ? AF_INET : AF_INET6;
496
497	my %state;
498
499	socket $state{fh}, $domain, SOCK_STREAM, 0
500	or Carp::croak "socket: $!";
501
502	setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1
503	or Carp::croak "so_reuseaddr: $!";
504
505	bind $state{fh}, pack_sockaddr _tcp_port $port, $ipn
506	or Carp::croak "bind: $!";
507
508	fh_nonblocking $state{fh}, 1;
509
510	my $len;
511
512	if ($prepare) {
513	my ($port, $host) = unpack_sockaddr getsockname $state{fh};
514	$len = $prepare && $prepare->($state{fh}, format_ip $host, $port);
515	}
516
517	$len \|\|= 128;
518
519	listen $state{fh}, $len
520	or Carp::croak "listen: $!";
521
522	$state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {
523	# this closure keeps $state alive
524	while (my $peer = accept my $fh, $state{fh}) {
525	fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not
526	my ($port, $host) = unpack_sockaddr $peer;
527	$accept->($fh, format_ip $host, $port);
528	}
529	});
530
531	defined wantarray
532	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency
533	: ()
534	}
535
536	1;
537
538	=back
539
540	=head1 AUTHOR
541
542	Marc Lehmann <schmorp@schmorp.de>
543	http://home.schmorp.de/
544
545	=cut
546