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). Note that scope-id's are not supported
(and will not parse).

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).

Note to the poor Microsoft Windows users: Windows (of course) doesn't
correctly signal connection errors, so unless your event library works
around this, failed connections will simply hang. The only event libraries
that handle this condition correctly are L<EV> and L<Glib>. Additionally,
AnyEvent works around this bug with L<Event> and in its pure-perl
backend. All other libraries cannot correctly handle this condition. To
lessen the impact of this windows bug, a default timeout of 30 seconds
will be imposed on windows. Cygwin is not affected.

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;
         
         my $timeout = $prepare && $prepare->($state{fh});

         $timeout ||= 30 if AnyEvent::WIN32;

         $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{next}();
         }
      };

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