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