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
         }
      });
   }
}

# check for broken platforms with extra field in sockaddr structure
# kind of a rfc vs. bsd issue, as usual (ok, normally it's a
# unix vs. bsd issue, a iso C vs. bsd issue or simply a
# correctness vs. bsd issue.
my $pack_family = 0x55 == Socket::sockaddr_family "\x55\x55"
                  ? "xC" : "S";

=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 "$pack_family nL 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 = Socket::sockaddr_family $_[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.32
Committed:	Mon May 26 17:45:05 2008 UTC (16 years, 1 month ago) by root
Branch:	MAIN
CVS Tags:	rel-4_05
Changes since 1.31:	+8 -1 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	# check for broken platforms with extra field in sockaddr structure
211	# kind of a rfc vs. bsd issue, as usual (ok, normally it's a
212	# unix vs. bsd issue, a iso C vs. bsd issue or simply a
213	# correctness vs. bsd issue.
214	my $pack_family = 0x55 == Socket::sockaddr_family "\x55\x55"
215	? "xC" : "S";
216
217	=item $sa = AnyEvent::Socket::pack_sockaddr $port, $host
218
219	Pack the given port/host combination into a binary sockaddr structure. Handles
220	both IPv4 and IPv6 host addresses.
221
222	=cut
223
224	sub pack_sockaddr($$) {
225	if (4 == length $_[1]) {
226	Socket::pack_sockaddr_in $_[0], $_[1]
227	} elsif (16 == length $_[1]) {
228	pack "$pack_family nL a16 L",
229	AF_INET6,
230	$_[0], # port
231	0, # flowinfo
232	$_[1], # addr
233	0 # scope id
234	} else {
235	Carp::croak "pack_sockaddr: invalid host";
236	}
237	}
238
239	=item ($port, $host) = AnyEvent::Socket::unpack_sockaddr $sa
240
241	Unpack the given binary sockaddr structure (as used by bind, getpeername
242	etc.) into a C<$port, $host> combination.
243
244	Handles both IPv4 and IPv6 sockaddr structures.
245
246	=cut
247
248	sub unpack_sockaddr($) {
249	my $af = Socket::sockaddr_family $_[0];
250
251	if ($af == AF_INET) {
252	Socket::unpack_sockaddr_in $_[0]
253	} elsif ($af == AF_INET6) {
254	unpack "x2 n x4 a16", $_[0]
255	} else {
256	Carp::croak "unpack_sockaddr: unsupported protocol family $af";
257	}
258	}
259
260	sub _tcp_port($) {
261	$_[0] =~ /^(\d)$/ and return $11;
262
263	(getservbyname $_[0], "tcp")[2]
264	or Carp::croak "$_[0]: service unknown"
265	}
266
267	=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]
268
269	This is a convenience function that creates a TCP socket and makes a 100%
270	non-blocking connect to the given C<$host> (which can be a hostname or a
271	textual IP address) and C<$service> (which can be a numeric port number or
272	a service name, or a C<servicename=portnumber> string).
273
274	If both C<$host> and C<$port> are names, then this function will use SRV
275	records to locate the real target(s).
276
277	In either case, it will create a list of target hosts (e.g. for multihomed
278	hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to
279	each in turn.
280
281	If the connect is successful, then the C<$connect_cb> will be invoked with
282	the socket file handle (in non-blocking mode) as first and the peer host
283	(as a textual IP address) and peer port as second and third arguments,
284	respectively. The fourth argument is a code reference that you can call
285	if, for some reason, you don't like this connection, which will cause
286	C<tcp_connect> to try the next one (or call your callback without any
287	arguments if there are no more connections). In most cases, you can simply
288	ignore this argument.
289
290	$cb->($filehandle, $host, $port, $retry)
291
292	If the connect is unsuccessful, then the C<$connect_cb> will be invoked
293	without any arguments and C<$!> will be set appropriately (with C<ENXIO>
294	indicating a DNS resolution failure).
295
296	The file handle is perfect for being plugged into L<AnyEvent::Handle>, but
297	can be used as a normal perl file handle as well.
298
299	Unless called in void context, C<tcp_connect> returns a guard object that
300	will automatically abort connecting when it gets destroyed (it does not do
301	anything to the socket after the connect was successful).
302
303	Sometimes you need to "prepare" the socket before connecting, for example,
304	to C<bind> it to some port, or you want a specific connect timeout that
305	is lower than your kernel's default timeout. In this case you can specify
306	a second callback, C<$prepare_cb>. It will be called with the file handle
307	in not-yet-connected state as only argument and must return the connection
308	timeout value (or C<0>, C<undef> or the empty list to indicate the default
309	timeout is to be used).
310
311	Note that the socket could be either a IPv4 TCP socket or an IPv6 TCP
312	socket (although only IPv4 is currently supported by this module).
313
314	Note to the poor Microsoft Windows users: Windows (of course) doesn't
315	correctly signal connection errors, so unless your event library works
316	around this, failed connections will simply hang. The only event libraries
317	that handle this condition correctly are L<EV> and L<Glib>. Additionally,
318	AnyEvent works around this bug with L<Event> and in its pure-perl
319	backend. All other libraries cannot correctly handle this condition. To
320	lessen the impact of this windows bug, a default timeout of 30 seconds
321	will be imposed on windows. Cygwin is not affected.
322
323	Simple Example: connect to localhost on port 22.
324
325	tcp_connect localhost => 22, sub {
326	my $fh = shift
327	or die "unable to connect: $!";
328	# do something
329	};
330
331	Complex Example: connect to www.google.com on port 80 and make a simple
332	GET request without much error handling. Also limit the connection timeout
333	to 15 seconds.
334
335	tcp_connect "www.google.com", "http",
336	sub {
337	my ($fh) = @_
338	or die "unable to connect: $!";
339
340	my $handle; # avoid direct assignment so on_eof has it in scope.
341	$handle = new AnyEvent::Handle
342	fh => $fh,
343	on_eof => sub {
344	undef $handle; # keep it alive till eof
345	warn "done.\n";
346	};
347
348	$handle->push_write ("GET / HTTP/1.0\015\012\015\012");
349
350	$handle->push_read_line ("\015\012\015\012", sub {
351	my ($handle, $line) = @_;
352
353	# print response header
354	print "HEADER\n$line\n\nBODY\n";
355
356	$handle->on_read (sub {
357	# print response body
358	print $_[0]->rbuf;
359	$_[0]->rbuf = "";
360	});
361	});
362	}, sub {
363	my ($fh) = @_;
364	# could call $fh->bind etc. here
365
366	15
367	};
368
369	=cut
370
371	sub tcp_connect($$$;$) {
372	my ($host, $port, $connect, $prepare) = @_;
373
374	# see http://cr.yp.to/docs/connect.html for some background
375
376	my %state = ( fh => undef );
377
378	# name resolution
379	AnyEvent::DNS::addr $host, $port, 0, 0, 0, sub {
380	my @target = @_;
381
382	$state{next} = sub {
383	return unless exists $state{fh};
384
385	my $target = shift @target
386	or do {
387	%state = ();
388	return $connect->();
389	};
390
391	my ($domain, $type, $proto, $sockaddr) = @$target;
392
393	# socket creation
394	socket $state{fh}, $domain, $type, $proto
395	or return $state{next}();
396
397	fh_nonblocking $state{fh}, 1;
398
399	my $timeout = $prepare && $prepare->($state{fh});
400
401	$timeout \|\|= 30 if AnyEvent::WIN32;
402
403	$state{to} = AnyEvent->timer (after => $timeout, cb => sub {
404	$! = &Errno::ETIMEDOUT;
405	$state{next}();
406	}) if $timeout;
407
408	# called when the connect was successful, which,
409	# in theory, could be the case immediately (but never is in practise)
410	my $connected = sub {
411	delete $state{ww};
412	delete $state{to};
413
414	# we are connected, or maybe there was an error
415	if (my $sin = getpeername $state{fh}) {
416	my ($port, $host) = unpack_sockaddr $sin;
417
418	my $guard = guard {
419	%state = ();
420	};
421
422	$connect->($state{fh}, format_ip $host, $port, sub {
423	$guard->cancel;
424	$state{next}();
425	});
426	} else {
427	# dummy read to fetch real error code
428	sysread $state{fh}, my $buf, 1 if $! == &Errno::ENOTCONN;
429	$state{next}();
430	}
431	};
432
433	# now connect
434	if (connect $state{fh}, $sockaddr) {
435	$connected->();
436	} elsif ($! == &Errno::EINPROGRESS \|\| $! == &Errno::EWOULDBLOCK) { # EINPROGRESS is POSIX
437	$state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $connected);
438	} else {
439	$state{next}();
440	}
441	};
442
443	$! = &Errno::ENXIO;
444	$state{next}();
445	};
446
447	defined wantarray && guard { %state = () }
448	}
449
450	=item $guard = tcp_server $host, $port, $accept_cb[, $prepare_cb]
451
452	Create and bind a TCP socket to the given host, and port, set the
453	SO_REUSEADDR flag and call C<listen>.
454
455	C<$host> must be an IPv4 or IPv6 address (or C<undef>, in which case it
456	binds either to C<0> or to C<::>, depending on whether IPv4 or IPv6 is the
457	preferred protocol).
458
459	To bind to the IPv4 wildcard address, use C<0>, to bind to the IPv6
460	wildcard address, use C<::>.
461
462	The port is specified by C<$port>, which must be either a service name or
463	a numeric port number (or C<0> or C<undef>, in which case an ephemeral
464	port will be used).
465
466	For each new connection that could be C<accept>ed, call the C<<
467	$accept_cb->($fh, $host, $port) >> with the file handle (in non-blocking
468	mode) as first and the peer host and port as second and third arguments
469	(see C<tcp_connect> for details).
470
471	Croaks on any errors it can detect before the listen.
472
473	If called in non-void context, then this function returns a guard object
474	whose lifetime it tied to the TCP server: If the object gets destroyed,
475	the server will be stopped (but existing accepted connections will
476	continue).
477
478	If you need more control over the listening socket, you can provide a
479	C<< $prepare_cb->($fh, $host, $port) >>, which is called just before the
480	C<listen ()> call, with the listen file handle as first argument, and IP
481	address and port number of the local socket endpoint as second and third
482	arguments.
483
484	It should return the length of the listen queue (or C<0> for the default).
485
486	Example: bind on some TCP port on the local machine and tell each client
487	to go away.
488
489	tcp_server undef, undef, sub {
490	my ($fh, $host, $port) = @_;
491
492	syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";
493	}, sub {
494	my ($fh, $thishost, $thisport) = @_;
495	warn "bound to $thishost, port $thisport\n";
496	};
497
498	=cut
499
500	sub tcp_server($$$;$) {
501	my ($host, $port, $accept, $prepare) = @_;
502
503	$host = $AnyEvent::PROTOCOL{ipv4} < $AnyEvent::PROTOCOL{ipv6} && AF_INET6
504	? "::" : "0"
505	unless defined $host;
506
507	my $ipn = parse_ip $host
508	or Carp::croak "AnyEvent::Socket::tcp_server: cannot parse '$host' as IPv4 or IPv6 address";
509
510	my $domain = 4 == length $ipn ? AF_INET : AF_INET6;
511
512	my %state;
513
514	socket $state{fh}, $domain, SOCK_STREAM, 0
515	or Carp::croak "socket: $!";
516
517	setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1
518	or Carp::croak "so_reuseaddr: $!";
519
520	bind $state{fh}, pack_sockaddr _tcp_port $port, $ipn
521	or Carp::croak "bind: $!";
522
523	fh_nonblocking $state{fh}, 1;
524
525	my $len;
526
527	if ($prepare) {
528	my ($port, $host) = unpack_sockaddr getsockname $state{fh};
529	$len = $prepare && $prepare->($state{fh}, format_ip $host, $port);
530	}
531
532	$len \|\|= 128;
533
534	listen $state{fh}, $len
535	or Carp::croak "listen: $!";
536
537	$state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {
538	# this closure keeps $state alive
539	while (my $peer = accept my $fh, $state{fh}) {
540	fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not
541	my ($port, $host) = unpack_sockaddr $peer;
542	$accept->($fh, format_ip $host, $port);
543	}
544	});
545
546	defined wantarray
547	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency
548	: ()
549	}
550
551	1;
552
553	=back
554
555	=head1 AUTHOR
556
557	Marc Lehmann <schmorp@schmorp.de>
558	http://home.schmorp.de/
559
560	=cut
561