lib/AnyEvent/Socket.pm

=head1 NAME

AnyEvent::Socket - useful IPv4 and IPv6 stuff.

=head1 SYNOPSIS

 use AnyEvent::Socket;

=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 ();

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

use base 'Exporter';

BEGIN {
   *socket_inet_aton = \&Socket::inet_aton; # take a copy, in case Coro::LWP overrides it
}

our @EXPORT = qw(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_ipv4 $dotted_quad

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
formst supported by parse_ipv4).

=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 four 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.

=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:)*/::/
            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
         }
      });
   }
}

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

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

=item $guard = tcp_connect $host, $port, $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<$port> (which can be a numeric port number or a
service name).

If both C<$host> and C<$port> are names, then this function will use SRV
records to locate the real target in a future version.

Unless called in void context, it 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).

If the connect is successful, then the C<$connect_cb> will be invoked with
the socket filehandle (in non-blocking mode) as first and the peer host
(as a textual IP address) and peer port as second and third arguments,
respectively.

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 filehandle is suitable to be plugged into L<AnyEvent::Handle>, but can
be used as a normal perl file handle as well.

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
   inet_aton $host, sub {
      return unless exists $state{fh};

      my $ipn = shift;

      4 == length $ipn
         or do {
            %state = ();
            $! = &Errno::ENXIO;
            return $connect->();
         };

      # socket creation
      socket $state{fh}, &Socket::AF_INET, &Socket::SOCK_STREAM, 0
         or do {
            %state = ();
            return $connect->();
         };

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

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

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

         # we are connected, or maybe there was an error
         if (my $sin = getpeername $fh) {
            my ($port, $host) = Socket::unpack_sockaddr_in $sin;
            $connect->($fh, (Socket::inet_ntoa $host), $port);
         } else {
            # dummy read to fetch real error code
            sysread $fh, my $buf, 1 if $! == &Errno::ENOTCONN;
            $connect->();
         }
      };

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

   defined wantarray
      ? guard { %state = () } # break any circular dependencies and unregister watchers
      : ()
}

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

Create and bind a tcp socket to the given host (any IPv4 host if undef,
otherwise it must be an IPv4 or IPv6 address) and port (service name or
numeric port number, or an ephemeral port if given as zero or undef), set
the SO_REUSEADDR flag and call C<listen>.

For each new connection that could be C<accept>ed, call the C<$accept_cb>
with the filehandle (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.

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>, which is called just before the C<listen ()> call, with
the listen file handle as first argument.

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

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

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

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

=cut

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

   my %state;

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

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

   bind $state{fh}, Socket::pack_sockaddr_in _tcp_port $port, socket_inet_aton ($host || "0.0.0.0")
      or Carp::croak "bind: $!";

   fh_nonblocking $state{fh}, 1;

   my $len = ($prepare && $prepare->($state{fh})) || 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) = Socket::unpack_sockaddr_in $peer;
         $accept->($fh, (Socket::inet_ntoa $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.11
Committed:	Fri May 23 20:09:56 2008 UTC (16 years, 1 month ago) by root
Branch:	MAIN
Changes since 1.10:	+40 -5 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	=head1 DESCRIPTION
10
11	This module implements various utility functions for handling internet
12	protocol addresses and sockets, in an as transparent and simple way as
13	possible.
14
15	All functions documented without C<AnyEvent::Socket::> prefix are exported
16	by default.
17
18	=over 4
19
20	=cut
21
22	package AnyEvent::Socket;
23
24	no warnings;
25	use strict;
26
27	use Carp ();
28	use Errno ();
29	use Socket ();
30
31	use AnyEvent ();
32	use AnyEvent::Util qw(guard fh_nonblocking);
33
34	use base 'Exporter';
35
36	BEGIN {
37	*socket_inet_aton = \&Socket::inet_aton; # take a copy, in case Coro::LWP overrides it
38	}
39
40	our @EXPORT = qw(inet_aton tcp_server tcp_connect);
41
42	our $VERSION = '1.0';
43
44	=item $ipn = parse_ipv4 $dotted_quad
45
46	Tries to parse the given dotted quad IPv4 address and return it in
47	octet form (or undef when it isn't in a parsable format). Supports all
48	forms specified by POSIX (e.g. C<10.0.0.1>, C<10.1>, C<10.0x020304>,
49	C<0x12345678> or C<0377.0377.0377.0377>).
50
51	=cut
52
53	sub parse_ipv4($) {
54	$_[0] =~ /^ (?: 0x[0-9a-fA-F]+ \| 0[0-7]* \| [1-9][0-9]* )
55	(?:\. (?: 0x[0-9a-fA-F]+ \| 0[0-7]* \| [1-9][0-9]* ) ){0,3}$/x
56	or return undef;
57
58	@_ = map /^0/ ? oct : $_, split /\./, $_[0];
59
60	# check leading parts against range
61	return undef if grep $_ >= 256, @_[0 .. @_ - 2];
62
63	# check trailing part against range
64	return undef if $_[-1] >= 1 << (8 * (4 - $#_));
65
66	pack "N", (pop)
67	+ ($_[0] << 24)
68	+ ($_[1] << 16)
69	+ ($_[2] << 8);
70	}
71
72	=item $ipn = parse_ipv4 $dotted_quad
73
74	Tries to parse the given IPv6 address and return it in
75	octet form (or undef when it isn't in a parsable format).
76
77	Should support all forms specified by RFC 2373 (and additionally all IPv4
78	formst supported by parse_ipv4).
79
80	=cut
81
82	sub parse_ipv6($) {
83	# quick test to avoid longer processing
84	my $n = $_[0] =~ y/://;
85	return undef if $n < 2 \|\| $n > 8;
86
87	my ($h, $t) = split /::/, $_[0], 2;
88
89	unless (defined $t) {
90	($h, $t) = (undef, $h);
91	}
92
93	my @h = split /:/, $h;
94	my @t = split /:/, $t;
95
96	# check four ipv4 tail
97	if (@t && $t[-1]=~ /\./) {
98	return undef if $n > 6;
99
100	my $ipn = parse_ipv4 pop @t
101	or return undef;
102
103	push @t, map +(sprintf "%x", $_), unpack "nn", $ipn;
104	}
105
106	# no :: then we need to have exactly 8 components
107	return undef unless @h + @t == 8 \|\| $_[0] =~ /::/;
108
109	# now check all parts for validity
110	return undef if grep !/^[0-9a-fA-F]{1,4}$/, @h, @t;
111
112	# now pad...
113	push @h, 0 while @h + @t < 8;
114
115	# and done
116	pack "n*", map hex, @h, @t
117	}
118
119	=item $ipn = parse_ip $text
120
121	Combines C<parse_ipv4> and C<parse_ipv6> in one function.
122
123	=cut
124
125	sub parse_ip($) {
126	&parse_ipv4 \|\| &parse_ipv6
127	}
128
129	=item $text = format_ip $ipn
130
131	Takes either an IPv4 address (4 octets) or and IPv6 address (16 octets)
132	and converts it into textual form.
133
134	=cut
135
136	sub format_ip;
137	sub format_ip($) {
138	if (4 == length $_[0]) {
139	return join ".", unpack "C4", $_[0]
140	} elsif (16 == length $_[0]) {
141	if (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) {
142	# v4mapped
143	return "::ffff:" . format_ip substr $_[0], 12;
144	} else {
145	my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];
146
147	$ip =~ s/^0:(?:0:)*/::/
148	or $ip =~ s/(:0)+$/::/
149	or $ip =~ s/(:0)+/:/;
150	return $ip
151	}
152	} else {
153	return undef
154	}
155	}
156
157	=item inet_aton $name_or_address, $cb->(@addresses)
158
159	Works similarly to its Socket counterpart, except that it uses a
160	callback. Also, if a host has only an IPv6 address, this might be passed
161	to the callback instead (use the length to detect this - 4 for IPv4, 16
162	for IPv6).
163
164	Unlike the L<Socket> function of the same name, you can get multiple IPv4
165	and IPv6 addresses as result.
166
167	=cut
168
169	sub inet_aton {
170	my ($name, $cb) = @_;
171
172	if (my $ipn = &parse_ipv4) {
173	$cb->($ipn);
174	} elsif (my $ipn = &parse_ipv6) {
175	$cb->($ipn);
176	} elsif ($name eq "localhost") { # rfc2606 et al.
177	$cb->(v127.0.0.1, v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1);
178	} else {
179	require AnyEvent::DNS;
180
181	# simple, bad suboptimal algorithm
182	AnyEvent::DNS::a ($name, sub {
183	if (@_) {
184	$cb->(map +(parse_ipv4 $_), @_);
185	} else {
186	$cb->();
187	#AnyEvent::DNS::aaaa ($name, $cb); need inet_pton
188	}
189	});
190	}
191	}
192
193	sub _tcp_port($) {
194	$_[0] =~ /^(\d)$/ and return $11;
195
196	(getservbyname $_[0], "tcp")[2]
197	or Carp::croak "$_[0]: service unknown"
198	}
199
200	=item $guard = tcp_connect $host, $port, $connect_cb[, $prepare_cb]
201
202	This is a convenience function that creates a tcp socket and makes a 100%
203	non-blocking connect to the given C<$host> (which can be a hostname or a
204	textual IP address) and C<$port> (which can be a numeric port number or a
205	service name).
206
207	If both C<$host> and C<$port> are names, then this function will use SRV
208	records to locate the real target in a future version.
209
210	Unless called in void context, it returns a guard object that will
211	automatically abort connecting when it gets destroyed (it does not do
212	anything to the socket after the connect was successful).
213
214	If the connect is successful, then the C<$connect_cb> will be invoked with
215	the socket filehandle (in non-blocking mode) as first and the peer host
216	(as a textual IP address) and peer port as second and third arguments,
217	respectively.
218
219	If the connect is unsuccessful, then the C<$connect_cb> will be invoked
220	without any arguments and C<$!> will be set appropriately (with C<ENXIO>
221	indicating a dns resolution failure).
222
223	The filehandle is suitable to be plugged into L<AnyEvent::Handle>, but can
224	be used as a normal perl file handle as well.
225
226	Sometimes you need to "prepare" the socket before connecting, for example,
227	to C<bind> it to some port, or you want a specific connect timeout that
228	is lower than your kernel's default timeout. In this case you can specify
229	a second callback, C<$prepare_cb>. It will be called with the file handle
230	in not-yet-connected state as only argument and must return the connection
231	timeout value (or C<0>, C<undef> or the empty list to indicate the default
232	timeout is to be used).
233
234	Note that the socket could be either a IPv4 TCP socket or an IPv6 tcp
235	socket (although only IPv4 is currently supported by this module).
236
237	Simple Example: connect to localhost on port 22.
238
239	tcp_connect localhost => 22, sub {
240	my $fh = shift
241	or die "unable to connect: $!";
242	# do something
243	};
244
245	Complex Example: connect to www.google.com on port 80 and make a simple
246	GET request without much error handling. Also limit the connection timeout
247	to 15 seconds.
248
249	tcp_connect "www.google.com", "http",
250	sub {
251	my ($fh) = @_
252	or die "unable to connect: $!";
253
254	my $handle; # avoid direct assignment so on_eof has it in scope.
255	$handle = new AnyEvent::Handle
256	fh => $fh,
257	on_eof => sub {
258	undef $handle; # keep it alive till eof
259	warn "done.\n";
260	};
261
262	$handle->push_write ("GET / HTTP/1.0\015\012\015\012");
263
264	$handle->push_read_line ("\015\012\015\012", sub {
265	my ($handle, $line) = @_;
266
267	# print response header
268	print "HEADER\n$line\n\nBODY\n";
269
270	$handle->on_read (sub {
271	# print response body
272	print $_[0]->rbuf;
273	$_[0]->rbuf = "";
274	});
275	});
276	}, sub {
277	my ($fh) = @_;
278	# could call $fh->bind etc. here
279
280	15
281	};
282
283	=cut
284
285	sub tcp_connect($$$;$) {
286	my ($host, $port, $connect, $prepare) = @_;
287
288	# see http://cr.yp.to/docs/connect.html for some background
289
290	my %state = ( fh => undef );
291
292	# name resolution
293	inet_aton $host, sub {
294	return unless exists $state{fh};
295
296	my $ipn = shift;
297
298	4 == length $ipn
299	or do {
300	%state = ();
301	$! = &Errno::ENXIO;
302	return $connect->();
303	};
304
305	# socket creation
306	socket $state{fh}, &Socket::AF_INET, &Socket::SOCK_STREAM, 0
307	or do {
308	%state = ();
309	return $connect->();
310	};
311
312	fh_nonblocking $state{fh}, 1;
313
314	# prepare and optional timeout
315	if ($prepare) {
316	my $timeout = $prepare->($state{fh});
317
318	$state{to} = AnyEvent->timer (after => $timeout, cb => sub {
319	%state = ();
320	$! = &Errno::ETIMEDOUT;
321	$connect->();
322	}) if $timeout;
323	}
324
325	# called when the connect was successful, which,
326	# in theory, could be the case immediately (but never is in practise)
327	my $connected = sub {
328	my $fh = delete $state{fh};
329	%state = ();
330
331	# we are connected, or maybe there was an error
332	if (my $sin = getpeername $fh) {
333	my ($port, $host) = Socket::unpack_sockaddr_in $sin;
334	$connect->($fh, (Socket::inet_ntoa $host), $port);
335	} else {
336	# dummy read to fetch real error code
337	sysread $fh, my $buf, 1 if $! == &Errno::ENOTCONN;
338	$connect->();
339	}
340	};
341
342	# now connect
343	if (connect $state{fh}, Socket::pack_sockaddr_in _tcp_port $port, $ipn) {
344	$connected->();
345	} elsif ($! == &Errno::EINPROGRESS \|\| $! == &Errno::EWOULDBLOCK) { # EINPROGRESS is POSIX
346	$state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $connected);
347	} else {
348	%state = ();
349	$connect->();
350	}
351	};
352
353	defined wantarray
354	? guard { %state = () } # break any circular dependencies and unregister watchers
355	: ()
356	}
357
358	=item $guard = tcp_server $host, $port, $accept_cb[, $prepare_cb]
359
360	Create and bind a tcp socket to the given host (any IPv4 host if undef,
361	otherwise it must be an IPv4 or IPv6 address) and port (service name or
362	numeric port number, or an ephemeral port if given as zero or undef), set
363	the SO_REUSEADDR flag and call C<listen>.
364
365	For each new connection that could be C<accept>ed, call the C<$accept_cb>
366	with the filehandle (in non-blocking mode) as first and the peer host and
367	port as second and third arguments (see C<tcp_connect> for details).
368
369	Croaks on any errors.
370
371	If called in non-void context, then this function returns a guard object
372	whose lifetime it tied to the tcp server: If the object gets destroyed,
373	the server will be stopped (but existing accepted connections will
374	continue).
375
376	If you need more control over the listening socket, you can provide a
377	C<$prepare_cb>, which is called just before the C<listen ()> call, with
378	the listen file handle as first argument.
379
380	It should return the length of the listen queue (or C<0> for the default).
381
382	Example: bind on tcp port 8888 on the local machine and tell each client
383	to go away.
384
385	tcp_server undef, 8888, sub {
386	my ($fh, $host, $port) = @_;
387
388	syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";
389	};
390
391	=cut
392
393	sub tcp_server($$$;$) {
394	my ($host, $port, $accept, $prepare) = @_;
395
396	my %state;
397
398	socket $state{fh}, &Socket::AF_INET, &Socket::SOCK_STREAM, 0
399	or Carp::croak "socket: $!";
400
401	setsockopt $state{fh}, &Socket::SOL_SOCKET, &Socket::SO_REUSEADDR, 1
402	or Carp::croak "so_reuseaddr: $!";
403
404	bind $state{fh}, Socket::pack_sockaddr_in _tcp_port $port, socket_inet_aton ($host \|\| "0.0.0.0")
405	or Carp::croak "bind: $!";
406
407	fh_nonblocking $state{fh}, 1;
408
409	my $len = ($prepare && $prepare->($state{fh})) \|\| 128;
410
411	listen $state{fh}, $len
412	or Carp::croak "listen: $!";
413
414	$state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {
415	# this closure keeps $state alive
416	while (my $peer = accept my $fh, $state{fh}) {
417	fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not
418	my ($port, $host) = Socket::unpack_sockaddr_in $peer;
419	$accept->($fh, (Socket::inet_ntoa $host), $port);
420	}
421	});
422
423	defined wantarray
424	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency
425	: ()
426	}
427
428	1;
429
430	=back
431
432	=head1 AUTHOR
433
434	Marc Lehmann <schmorp@schmorp.de>
435	http://home.schmorp.de/
436
437	=cut
438