[ViewVC] Diff of: cvs/AnyEvent/lib/AnyEvent/Socket.pm

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.17 by root, Sat May 24 02:50:45 2008 UTC vs.
Revision 1.133 by root, Sat Aug 13 16:32:31 2011 UTC

…		…
2		2
3	AnyEvent::Socket - useful IPv4 and IPv6 stuff.	3	AnyEvent::Socket - useful IPv4 and IPv6 stuff.
4		4
5	=head1 SYNOPSIS	5	=head1 SYNOPSIS
6		6
7	use AnyEvent::Socket;	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	};
8		22
9	=head1 DESCRIPTION	23	=head1 DESCRIPTION
10		24
11	This module implements various utility functions for handling internet	25	This module implements various utility functions for handling internet
12	protocol addresses and sockets, in an as transparent and simple way as	26	protocol addresses and sockets, in an as transparent and simple way as
…		…
19		33
20	=cut	34	=cut
21		35
22	package AnyEvent::Socket;	36	package AnyEvent::Socket;
23		37
24	no warnings;
25	use strict;
26
27	use Carp ();	38	use Carp ();
28	use Errno ();	39	use Errno ();
29	use Socket ();	40	use Socket qw(AF_INET AF_UNIX SOCK_STREAM SOCK_DGRAM SOL_SOCKET SO_REUSEADDR);
30		41
31	use AnyEvent ();	42	use AnyEvent (); BEGIN { AnyEvent::common_sense }
32	use AnyEvent::Util qw(guard fh_nonblocking);	43	use AnyEvent::Util qw(guard fh_nonblocking AF_INET6);
33	use AnyEvent::DNS ();	44	use AnyEvent::DNS ();
34		45
35	use base 'Exporter';	46	use base 'Exporter';
36		47
37	BEGIN {	48	our @EXPORT = qw(
38	*socket_inet_aton = \&Socket::inet_aton; # take a copy, in case Coro::LWP overrides it	49	getprotobyname
39	}	50	parse_hostport format_hostport
		51	parse_ipv4 parse_ipv6
		52	parse_ip parse_address
		53	format_ipv4 format_ipv6
		54	format_ip format_address
		55	address_family
		56	inet_aton
		57	tcp_server
		58	tcp_connect
		59	);
40		60
41	BEGIN {	61	our $VERSION = $AnyEvent::VERSION;
42	my $af_inet6 = eval { &Socket::AF_INET6 };
43	eval "sub AF_INET6() { $af_inet6 }"; die if $@;
44
45	delete $AnyEvent::PROTOCOL{ipv6} unless $af_inet6;
46	}
47
48	our @EXPORT = qw(parse_ipv4 parse_ipv6 parse_ip format_ip inet_aton tcp_server tcp_connect);
49
50	our $VERSION = '1.0';
51		62
52	=item $ipn = parse_ipv4 $dotted_quad	63	=item $ipn = parse_ipv4 $dotted_quad
53		64
54	Tries to parse the given dotted quad IPv4 address and return it in	65	Tries to parse the given dotted quad IPv4 address and return it in
55	octet form (or undef when it isn't in a parsable format). Supports all	66	octet form (or undef when it isn't in a parsable format). Supports all
…		…
67		78
68	# check leading parts against range	79	# check leading parts against range
69	return undef if grep $_ >= 256, @_[0 .. @_ - 2];	80	return undef if grep $_ >= 256, @_[0 .. @_ - 2];
70		81
71	# check trailing part against range	82	# check trailing part against range
72	return undef if $_[-1] >= 1 << (8 * (4 - $#_));	83	return undef if $_[-1] >= 2 ** (8 * (4 - $#_));
73		84
74	pack "N", (pop)	85	pack "N", (pop)
75	+ ($_[0] << 24)	86	+ ($_[0] << 24)
76	+ ($_[1] << 16)	87	+ ($_[1] << 16)
77	+ ($_[2] << 8);	88	+ ($_[2] << 8);
…		…
81		92
82	Tries to parse the given IPv6 address and return it in	93	Tries to parse the given IPv6 address and return it in
83	octet form (or undef when it isn't in a parsable format).	94	octet form (or undef when it isn't in a parsable format).
84		95
85	Should support all forms specified by RFC 2373 (and additionally all IPv4	96	Should support all forms specified by RFC 2373 (and additionally all IPv4
86	forms supported by parse_ipv4).	97	forms supported by parse_ipv4). Note that scope-id's are not supported
		98	(and will not parse).
87		99
88	This function works similarly to C<inet_pton AF_INET6, ...>.	100	This function works similarly to C<inet_pton AF_INET6, ...>.
		101
		102	Example:
		103
		104	print unpack "H*", parse_ipv6 "2002:5345::10.0.0.1";
		105	# => 2002534500000000000000000a000001
89		106
90	=cut	107	=cut
91		108
92	sub parse_ipv6($) {	109	sub parse_ipv6($) {
93	# quick test to avoid longer processing	110	# quick test to avoid longer processing
…		…
124		141
125	# and done	142	# and done
126	pack "n*", map hex, @h, @t	143	pack "n*", map hex, @h, @t
127	}	144	}
128		145
129	=item $ipn = parse_ip $text	146	sub parse_unix($) {
		147	$_[0] eq "unix/"
		148	? pack "S", AF_UNIX
		149	: undef
130		150
		151	}
		152
		153	=item $ipn = parse_address $ip
		154
131	Combines C<parse_ipv4> and C<parse_ipv6> in one function.	155	Combines C<parse_ipv4> and C<parse_ipv6> in one function. The address
		156	here refers to the host address (not socket address) in network form
		157	(binary).
132		158
133	=cut	159	If the C<$text> is C<unix/>, then this function returns a special token
		160	recognised by the other functions in this module to mean "UNIX domain
		161	socket".
134		162
		163	If the C<$text> to parse is a mapped IPv4 in IPv6 address (:ffff::<ipv4>),
		164	then it will be treated as an IPv4 address. If you don't want that, you
		165	have to call C<parse_ipv4> and/or C<parse_ipv6> manually.
		166
		167	Example:
		168
		169	print unpack "H*", parse_address "10.1.2.3";
		170	# => 0a010203
		171
		172	=item $ipn = AnyEvent::Socket::aton $ip
		173
		174	Same as C<parse_address>, but not exported (think C<Socket::inet_aton> but
		175	I<without> name resolution).
		176
		177	=cut
		178
135	sub parse_ip($) {	179	sub parse_address($) {
136	&parse_ipv4 \|\| &parse_ipv6	180	for (&parse_ipv6) {
		181	if ($_) {
		182	s/^\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff//;
		183	return $_;
		184	} else {
		185	return &parse_ipv4 \|\| &parse_unix
		186	}
		187	}
137	}	188	}
138		189
		190	*aton = \&parse_address;
		191
		192	=item ($name, $aliases, $proto) = getprotobyname $name
		193
		194	Works like the builtin function of the same name, except it tries hard to
		195	work even on broken platforms (well, that's windows), where getprotobyname
		196	is traditionally very unreliable.
		197
		198	Example: get the protocol number for TCP (usually 6)
		199
		200	my $proto = getprotobyname "tcp";
		201
		202	=cut
		203
		204	# microsoft can't even get getprotobyname working (the etc/protocols file
		205	# gets lost fairly often on windows), so we have to hardcode some common
		206	# protocol numbers ourselves.
		207	our %PROTO_BYNAME;
		208
		209	$PROTO_BYNAME{tcp} = Socket::IPPROTO_TCP () if defined &Socket::IPPROTO_TCP;
		210	$PROTO_BYNAME{udp} = Socket::IPPROTO_UDP () if defined &Socket::IPPROTO_UDP;
		211	$PROTO_BYNAME{icmp} = Socket::IPPROTO_ICMP() if defined &Socket::IPPROTO_ICMP;
		212
		213	sub getprotobyname($) {
		214	my $name = lc shift;
		215
		216	defined (my $proton = $PROTO_BYNAME{$name} \|\| (getprotobyname $name)[2])
		217	or return;
		218
		219	($name, uc $name, $proton)
		220	}
		221
		222	=item ($host, $service) = parse_hostport $string[, $default_service]
		223
		224	Splitting a string of the form C<hostname:port> is a common
		225	problem. Unfortunately, just splitting on the colon makes it hard to
		226	specify IPv6 addresses and doesn't support the less common but well
		227	standardised C<[ip literal]> syntax.
		228
		229	This function tries to do this job in a better way, it supports the
		230	following formats, where C<port> can be a numerical port number of a
		231	service name, or a C<name=port> string, and the C< port> and C<:port>
		232	parts are optional. Also, everywhere where an IP address is supported
		233	a hostname or unix domain socket address is also supported (see
		234	C<parse_unix>).
		235
		236	hostname:port e.g. "www.linux.org", "www.x.de:443", "www.x.de:https=443"
		237	ipv4:port e.g. "198.182.196.56", "127.1:22"
		238	ipv6 e.g. "::1", "affe::1"
		239	[ipv4or6]:port e.g. "[::1]", "[10.0.1]:80"
		240	[ipv4or6] port e.g. "[127.0.0.1]", "[www.x.org] 17"
		241	ipv4or6 port e.g. "::1 443", "10.0.0.1 smtp"
		242
		243	It also supports defaulting the service name in a simple way by using
		244	C<$default_service> if no service was detected. If neither a service was
		245	detected nor a default was specified, then this function returns the
		246	empty list. The same happens when a parse error was detected, such as a
		247	hostname with a colon in it (the function is rather conservative, though).
		248
		249	Example:
		250
		251	print join ",", parse_hostport "localhost:443";
		252	# => "localhost,443"
		253
		254	print join ",", parse_hostport "localhost", "https";
		255	# => "localhost,https"
		256
		257	print join ",", parse_hostport "[::1]";
		258	# => "," (empty list)
		259
		260	=cut
		261
		262	sub parse_hostport($;$) {
		263	my ($host, $port);
		264
		265	for ("$_[0]") { # work on a copy, just in case, and also reset pos
		266
		267	# parse host, special cases: "ipv6" or "ipv6 port"
		268	unless (
		269	($host) = /^\s* ([0-9a-fA-F:]:[0-9a-fA-F:]:[0-9a-fA-F\.:]*)/xgc
		270	and parse_ipv6 $host
		271	) {
		272	/^\s*/xgc;
		273
		274	if (/^ \[ ([^\[\]]+) \]/xgc) {
		275	$host = $1;
		276	} elsif (/^ ([^\[\]:\ ]+) /xgc) {
		277	$host = $1;
		278	} else {
		279	return;
		280	}
		281	}
		282
		283	# parse port
		284	if (/\G (?:\s+\|:) ([^:[:space:]]+) \s*$/xgc) {
		285	$port = $1;
		286	} elsif (/\G\s*$/gc && length $_[1]) {
		287	$port = $_[1];
		288	} else {
		289	return;
		290	}
		291	}
		292
		293	# hostnames must not contain :'s
		294	return if $host =~ /:/ && !parse_ipv6 $host;
		295
		296	($host, $port)
		297	}
		298
		299	=item $string = format_hostport $host, $port
		300
		301	Takes a host (in textual form) and a port and formats in unambigiously in
		302	a way that C<parse_hostport> can parse it again. C<$port> can be C<undef>.
		303
		304	=cut
		305
		306	sub format_hostport($;$) {
		307	my ($host, $port) = @_;
		308
		309	$port = ":$port" if length $port;
		310	$host = "[$host]" if $host =~ /:/;
		311
		312	"$host$port"
		313	}
		314
		315	=item $sa_family = address_family $ipn
		316
		317	Returns the address family/protocol-family (AF_xxx/PF_xxx, in one value :)
		318	of the given host address in network format.
		319
		320	=cut
		321
		322	sub address_family($) {
		323	4 == length $_[0]
		324	? AF_INET
		325	: 16 == length $_[0]
		326	? AF_INET6
		327	: unpack "S", $_[0]
		328	}
		329
139	=item $text = format_ip $ipn	330	=item $text = format_ipv4 $ipn
140		331
141	Takes either an IPv4 address (4 octets) or and IPv6 address (16 octets)	332	Expects a four octet string representing a binary IPv4 address and returns
		333	its textual format. Rarely used, see C<format_address> for a nicer
		334	interface.
		335
		336	=item $text = format_ipv6 $ipn
		337
		338	Expects a sixteen octet string representing a binary IPv6 address and
		339	returns its textual format. Rarely used, see C<format_address> for a
		340	nicer interface.
		341
		342	=item $text = format_address $ipn
		343
		344	Covnvert a host address in network format (e.g. 4 octets for IPv4 or 16
142	and converts it into textual form.	345	octets for IPv6) and convert it into textual form.
		346
		347	Returns C<unix/> for UNIX domain sockets.
143		348
144	This function works similarly to C<inet_ntop AF_INET \|\| AF_INET6, ...>,	349	This function works similarly to C<inet_ntop AF_INET \|\| AF_INET6, ...>,
145	except it automatically detects the address type.	350	except it automatically detects the address type.
146		351
147	=cut	352	Returns C<undef> if it cannot detect the type.
148		353
149	sub format_ip;	354	If the C<$ipn> is a mapped IPv4 in IPv6 address (:ffff::<ipv4>), then just
		355	the contained IPv4 address will be returned. If you do not want that, you
		356	have to call C<format_ipv6> manually.
		357
		358	Example:
		359
		360	print format_address "\x01\x02\x03\x05";
		361	=> 1.2.3.5
		362
		363	=item $text = AnyEvent::Socket::ntoa $ipn
		364
		365	Same as format_address, but not exported (think C<inet_ntoa>).
		366
		367	=cut
		368
150	sub format_ip($) {	369	sub format_ipv4($) {
		370	join ".", unpack "C4", $_[0]
		371	}
		372
		373	sub format_ipv6($) {
		374	if ($_[0] =~ /^\x00\x00\x00\x00\x00\x00\x00\x00/) {
		375	if (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0 eq $_[0]) {
		376	return "::";
		377	} elsif (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1 eq $_[0]) {
		378	return "::1";
		379	} elsif (v0.0.0.0.0.0.0.0.0.0.0.0 eq substr $_[0], 0, 12) {
		380	# v4compatible
		381	return "::" . format_ipv4 substr $_[0], 12;
		382	} elsif (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) {
		383	# v4mapped
		384	return "::ffff:" . format_ipv4 substr $_[0], 12;
		385	} elsif (v0.0.0.0.0.0.0.0.255.255.0.0 eq substr $_[0], 0, 12) {
		386	# v4translated
		387	return "::ffff:0:" . format_ipv4 substr $_[0], 12;
		388	}
		389	}
		390
		391	my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];
		392
		393	# this is admittedly rather sucky
		394	$ip =~ s/(?:^\|:) 0:0:0:0:0:0:0 (?:$\|:)/::/x
		395	or $ip =~ s/(?:^\|:) 0:0:0:0:0:0 (?:$\|:)/::/x
		396	or $ip =~ s/(?:^\|:) 0:0:0:0:0 (?:$\|:)/::/x
		397	or $ip =~ s/(?:^\|:) 0:0:0:0 (?:$\|:)/::/x
		398	or $ip =~ s/(?:^\|:) 0:0:0 (?:$\|:)/::/x
		399	or $ip =~ s/(?:^\|:) 0:0 (?:$\|:)/::/x
		400	or $ip =~ s/(?:^\|:) 0 (?:$\|:)/::/x;
		401
		402	$ip
		403	}
		404
		405	sub format_address($) {
151	if (4 == length $_[0]) {	406	if (4 == length $_[0]) {
152	return join ".", unpack "C4", $_[0]	407	return &format_ipv4;
153	} elsif (16 == length $_[0]) {	408	} elsif (16 == length $_[0]) {
154	if (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) {	409	return $_[0] =~ /^\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff(....)$/s
155	# v4mapped	410	? format_ipv4 $1
156	return "::ffff:" . format_ip substr $_[0], 12;	411	: &format_ipv6;
157	} else {	412	} elsif (AF_UNIX == address_family $_[0]) {
158	my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];	413	return "unix/"
159
160	$ip =~ s/^0:(?:0:)*/::/
161	or $ip =~ s/(:0)+$/::/
162	or $ip =~ s/(:0)+/:/;
163	return $ip
164	}
165	} else {	414	} else {
166	return undef	415	return undef
167	}	416	}
168	}	417	}
169		418
		419	*ntoa = \&format_address;
		420
170	=item inet_aton $name_or_address, $cb->(@addresses)	421	=item inet_aton $name_or_address, $cb->(@addresses)
171		422
172	Works similarly to its Socket counterpart, except that it uses a	423	Works similarly to its Socket counterpart, except that it uses a
173	callback. Also, if a host has only an IPv6 address, this might be passed	424	callback. Use the length to distinguish between ipv4 and ipv6 (4 octets
174	to the callback instead (use the length to detect this - 4 for IPv4, 16	425	for IPv4, 16 for IPv6), or use C<format_address> to convert it to a more
175	for IPv6).	426	readable format.
176		427
177	Unlike the L<Socket> function of the same name, you can get multiple IPv4	428	Note that C<resolve_sockaddr>, while initially a more complex interface,
178	and IPv6 addresses as result.	429	resolves host addresses, IDNs, service names and SRV records and gives you
		430	an ordered list of socket addresses to try and should be preferred over
		431	C<inet_aton>.
		432
		433	Example.
		434
		435	inet_aton "www.google.com", my $cv = AE::cv;
		436	say unpack "H*", $_
		437	for $cv->recv;
		438	# => d155e363
		439	# => d155e367 etc.
		440
		441	inet_aton "ipv6.google.com", my $cv = AE::cv;
		442	say unpack "H*", $_
		443	for $cv->recv;
		444	# => 20014860a00300000000000000000068
179		445
180	=cut	446	=cut
181		447
182	sub inet_aton {	448	sub inet_aton {
183	my ($name, $cb) = @_;	449	my ($name, $cb) = @_;
…		…
189	} elsif ($name eq "localhost") { # rfc2606 et al.	455	} elsif ($name eq "localhost") { # rfc2606 et al.
190	$cb->(v127.0.0.1, v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1);	456	$cb->(v127.0.0.1, v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1);
191	} else {	457	} else {
192	require AnyEvent::DNS;	458	require AnyEvent::DNS;
193		459
194	# simple, bad suboptimal algorithm	460	my $ipv4 = $AnyEvent::PROTOCOL{ipv4};
		461	my $ipv6 = $AnyEvent::PROTOCOL{ipv6};
		462
		463	my @res;
		464
		465	my $cv = AE::cv {
		466	$cb->(map @$_, reverse @res);
		467	};
		468
		469	$cv->begin;
		470
		471	if ($ipv4) {
		472	$cv->begin;
195	AnyEvent::DNS::a ($name, sub {	473	AnyEvent::DNS::a ($name, sub {
196	if (@_) {	474	$res[$ipv4] = [map &parse_ipv4, @_];
197	$cb->(map +(parse_ipv4 $_), @_);
198	} else {
199	$cb->();	475	$cv->end;
200	#AnyEvent::DNS::aaaa ($name, $cb); need inet_pton
201	}	476	});
202	});	477	};
203	}
204	}
205		478
		479	if ($ipv6) {
		480	$cv->begin;
		481	AnyEvent::DNS::aaaa ($name, sub {
		482	$res[$ipv6] = [map &parse_ipv6, @_];
		483	$cv->end;
		484	});
		485	};
		486
		487	$cv->end;
		488	}
		489	}
		490
		491	BEGIN {
		492	*sockaddr_family = $Socket::VERSION >= 1.75
		493	? \&Socket::sockaddr_family
		494	: # for 5.6.x, we need to do something much more horrible
		495	(Socket::pack_sockaddr_in 0x5555, "\x55\x55\x55\x55"
		496	\| eval { Socket::pack_sockaddr_un "U" }) =~ /^\x00/
		497	? sub { unpack "xC", $_[0] }
		498	: sub { unpack "S" , $_[0] };
		499	}
		500
		501	# check for broken platforms with an extra field in sockaddr structure
		502	# kind of a rfc vs. bsd issue, as usual (ok, normally it's a
		503	# unix vs. bsd issue, a iso C vs. bsd issue or simply a
		504	# correctness vs. bsd issue.)
		505	my $pack_family = 0x55 == sockaddr_family ("\x55\x55")
		506	? "xC" : "S";
		507
206	=item $sa = AnyEvent::Socket::pack_sockaddr $port, $host	508	=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host
207		509
208	Pack the given port/host combination into a binary sockaddr structure. Handles	510	Pack the given port/host combination into a binary sockaddr
209	both IPv4 and IPv6 host addresses.	511	structure. Handles both IPv4 and IPv6 host addresses, as well as UNIX
		512	domain sockets (C<$host> == C<unix/> and C<$service> == absolute
		513	pathname).
		514
		515	Example:
		516
		517	my $bind = AnyEvent::Socket::pack_sockaddr 43, v195.234.53.120;
		518	bind $socket, $bind
		519	or die "bind: $!";
210		520
211	=cut	521	=cut
212		522
213	sub pack_sockaddr($$) {	523	sub pack_sockaddr($$) {
214	if (4 == length $_[1]) {	524	my $af = address_family $_[1];
		525
		526	if ($af == AF_INET) {
215	Socket::pack_sockaddr_in $_[0], $_[1]	527	Socket::pack_sockaddr_in $_[0], $_[1]
216	} elsif (16 == length $_[1]) {	528	} elsif ($af == AF_INET6) {
217	pack "SnL a16 L",	529	pack "$pack_family nL a16 L",
218	Socket::AF_INET6,	530	AF_INET6,
219	$_[0], # port	531	$_[0], # port
220	0, # flowinfo	532	0, # flowinfo
221	$_[1], # addr	533	$_[1], # addr
222	0 # scope id	534	0 # scope id
		535	} elsif ($af == AF_UNIX) {
		536	Socket::pack_sockaddr_un $_[0]
223	} else {	537	} else {
224	Carp::croak "pack_sockaddr: invalid host";	538	Carp::croak "pack_sockaddr: invalid host";
225	}	539	}
226	}	540	}
227		541
228	=item ($port, $host) = AnyEvent::Socket::unpack_sockaddr $sa	542	=item ($service, $host) = AnyEvent::Socket::unpack_sockaddr $sa
229		543
230	Unpack the given binary sockaddr structure (as used by bind, getpeername	544	Unpack the given binary sockaddr structure (as used by bind, getpeername
231	etc.) into a C<$port, $host> combination.	545	etc.) into a C<$service, $host> combination.
232		546
233	Handles both IPv4 and IPv6 sockaddr structures.	547	For IPv4 and IPv6, C<$service> is the port number and C<$host> the host
		548	address in network format (binary).
234		549
		550	For UNIX domain sockets, C<$service> is the absolute pathname and C<$host>
		551	is a special token that is understood by the other functions in this
		552	module (C<format_address> converts it to C<unix/>).
		553
235	=cut	554	=cut
		555
		556	# perl contains a bug (imho) where it requires that the kernel always returns
		557	# sockaddr_un structures of maximum length (which is not, AFAICS, required
		558	# by any standard). try to 0-pad structures for the benefit of those platforms.
		559
		560	my $sa_un_zero = eval { Socket::pack_sockaddr_un "" }; $sa_un_zero ^= $sa_un_zero;
236		561
237	sub unpack_sockaddr($) {	562	sub unpack_sockaddr($) {
238	my $af = unpack "S", $_[0];	563	my $af = sockaddr_family $_[0];
239		564
240	if ($af == &Socket::AF_INET) {	565	if ($af == AF_INET) {
241	Socket::unpack_sockaddr_in $_[0]	566	Socket::unpack_sockaddr_in $_[0]
242	} elsif ($af == AF_INET6) {	567	} elsif ($af == AF_INET6) {
243	(unpack "SnL a16 L")[1, 3]	568	unpack "x2 n x4 a16", $_[0]
		569	} elsif ($af == AF_UNIX) {
		570	((Socket::unpack_sockaddr_un $_[0] ^ $sa_un_zero), pack "S", AF_UNIX)
244	} else {	571	} else {
245	Carp::croak "unpack_sockaddr: unsupported protocol family $af";	572	Carp::croak "unpack_sockaddr: unsupported protocol family $af";
246	}	573	}
247	}	574	}
248		575
249	sub _tcp_port($) {	576	=item resolve_sockaddr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...)
250	$_[0] =~ /^(\d)$/ and return $11;
251		577
252	(getservbyname $_[0], "tcp")[2]	578	Tries to resolve the given nodename and service name into protocol families
		579	and sockaddr structures usable to connect to this node and service in a
		580	protocol-independent way. It works remotely similar to the getaddrinfo
		581	posix function.
		582
		583	For internet addresses, C<$node> is either an IPv4 or IPv6 address, an
		584	internet hostname (DNS domain name or IDN), and C<$service> is either
		585	a service name (port name from F</etc/services>) or a numerical port
		586	number. If both C<$node> and C<$service> are names, then SRV records
		587	will be consulted to find the real service, otherwise they will be
		588	used as-is. If you know that the service name is not in your services
		589	database, then you can specify the service in the format C<name=port>
		590	(e.g. C<http=80>).
		591
		592	For UNIX domain sockets, C<$node> must be the string C<unix/> and
		593	C<$service> must be the absolute pathname of the socket. In this case,
		594	C<$proto> will be ignored.
		595
		596	C<$proto> must be a protocol name, currently C<tcp>, C<udp> or
		597	C<sctp>. The default is currently C<tcp>, but in the future, this function
		598	might try to use other protocols such as C<sctp>, depending on the socket
		599	type and any SRV records it might find.
		600
		601	C<$family> must be either C<0> (meaning any protocol is OK), C<4> (use
		602	only IPv4) or C<6> (use only IPv6). The default is influenced by
		603	C<$ENV{PERL_ANYEVENT_PROTOCOLS}>.
		604
		605	C<$type> must be C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_SEQPACKET> (or
		606	C<undef> in which case it gets automatically chosen to be C<SOCK_STREAM>
		607	unless C<$proto> is C<udp>).
		608
		609	The callback will receive zero or more array references that contain
		610	C<$family, $type, $proto> for use in C<socket> and a binary
		611	C<$sockaddr> for use in C<connect> (or C<bind>).
		612
		613	The application should try these in the order given.
		614
		615	Example:
		616
		617	resolve_sockaddr "google.com", "http", 0, undef, undef, sub { ... };
		618
		619	=cut
		620
		621	sub resolve_sockaddr($$$$$$) {
		622	my ($node, $service, $proto, $family, $type, $cb) = @_;
		623
		624	if ($node eq "unix/") {
		625	return $cb->() if $family \|\| $service !~ /^\//; # no can do
		626
		627	return $cb->([AF_UNIX, defined $type ? $type : SOCK_STREAM, 0, Socket::pack_sockaddr_un $service]);
		628	}
		629
		630	unless (AF_INET6) {
		631	$family != 6
		632	or return $cb->();
		633
		634	$family = 4;
		635	}
		636
		637	$cb->() if $family == 4 && !$AnyEvent::PROTOCOL{ipv4};
		638	$cb->() if $family == 6 && !$AnyEvent::PROTOCOL{ipv6};
		639
		640	$family \|\|= 4 unless $AnyEvent::PROTOCOL{ipv6};
		641	$family \|\|= 6 unless $AnyEvent::PROTOCOL{ipv4};
		642
		643	$proto \|\|= "tcp";
		644	$type \|\|= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;
		645
		646	my $proton = AnyEvent::Socket::getprotobyname $proto
253	or Carp::croak "$_[0]: service unknown"	647	or Carp::croak "$proto: protocol unknown";
		648
		649	my $port;
		650
		651	if ($service =~ /^(\S+)=(\d+)$/) {
		652	($service, $port) = ($1, $2);
		653	} elsif ($service =~ /^\d+$/) {
		654	($service, $port) = (undef, $service);
		655	} else {
		656	$port = (getservbyname $service, $proto)[2]
		657	or Carp::croak "$service/$proto: service unknown";
		658	}
		659
		660	# resolve a records / provide sockaddr structures
		661	my $resolve = sub {
		662	my @target = @_;
		663
		664	my @res;
		665	my $cv = AE::cv {
		666	$cb->(
		667	map $_->[2],
		668	sort {
		669	$AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]}
		670	or $a->[0] <=> $b->[0]
		671	}
		672	@res
		673	)
		674	};
		675
		676	$cv->begin;
		677	for my $idx (0 .. $#target) {
		678	my ($node, $port) = @{ $target[$idx] };
		679
		680	if (my $noden = parse_address $node) {
		681	my $af = address_family $noden;
		682
		683	if ($af == AF_INET && $family != 6) {
		684	push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
		685	pack_sockaddr $port, $noden]]
		686	}
		687
		688	if ($af == AF_INET6 && $family != 4) {
		689	push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,
		690	pack_sockaddr $port, $noden]]
		691	}
		692	} else {
		693	# ipv4
		694	if ($family != 6) {
		695	$cv->begin;
		696	AnyEvent::DNS::a $node, sub {
		697	push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
		698	pack_sockaddr $port, parse_ipv4 $_]]
		699	for @_;
		700	$cv->end;
		701	};
		702	}
		703
		704	# ipv6
		705	if ($family != 4) {
		706	$cv->begin;
		707	AnyEvent::DNS::aaaa $node, sub {
		708	push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,
		709	pack_sockaddr $port, parse_ipv6 $_]]
		710	for @_;
		711	$cv->end;
		712	};
		713	}
		714	}
		715	}
		716	$cv->end;
		717	};
		718
		719	$node = AnyEvent::Util::idn_to_ascii $node
		720	if $node =~ /[^\x00-\x7f]/;
		721
		722	# try srv records, if applicable
		723	if ($node eq "localhost") {
		724	$resolve->(["127.0.0.1", $port], ["::1", $port]);
		725	} elsif (defined $service && !parse_address $node) {
		726	AnyEvent::DNS::srv $service, $proto, $node, sub {
		727	my (@srv) = @_;
		728
		729	if (@srv) {
		730	# the only srv record has "." ("" here) => abort
		731	$srv[0][2] ne "" \|\| $#srv
		732	or return $cb->();
		733
		734	# use srv records then
		735	$resolve->(
		736	map ["$_->[3].", $_->[2]],
		737	grep $_->[3] ne ".",
		738	@srv
		739	);
		740	} else {
		741	# no srv records, continue traditionally
		742	$resolve->([$node, $port]);
		743	}
		744	};
		745	} else {
		746	# most common case
		747	$resolve->([$node, $port]);
		748	}
254	}	749	}
255		750
256	=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]	751	=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]
257		752
258	This is a convenience function that creates a TCP socket and makes a 100%	753	This is a convenience function that creates a TCP socket and makes a
259	non-blocking connect to the given C<$host> (which can be a hostname or a	754	100% non-blocking connect to the given C<$host> (which can be a DNS/IDN
		755	hostname or a textual IP address, or the string C<unix/> for UNIX domain
260	textual IP address) and C<$service> (which can be a numeric port number or	756	sockets) and C<$service> (which can be a numeric port number or a service
261	a service name, or a C<servicename=portnumber> string).	757	name, or a C<servicename=portnumber> string, or the pathname to a UNIX
		758	domain socket).
262		759
263	If both C<$host> and C<$port> are names, then this function will use SRV	760	If both C<$host> and C<$port> are names, then this function will use SRV
264	records to locate the real target(s).	761	records to locate the real target(s).
265		762
266	In either case, it will create a list of target hosts (e.g. for multihomed	763	In either case, it will create a list of target hosts (e.g. for multihomed
267	hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to	764	hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to
268	each in turn.	765	each in turn.
269		766
270	If the connect is successful, then the C<$connect_cb> will be invoked with	767	After the connection is established, then the C<$connect_cb> will be
271	the socket file handle (in non-blocking mode) as first and the peer host	768	invoked with the socket file handle (in non-blocking mode) as first, and
272	(as a textual IP address) and peer port as second and third arguments,	769	the peer host (as a textual IP address) and peer port as second and third
273	respectively. The fourth argument is a code reference that you can call	770	arguments, respectively. The fourth argument is a code reference that you
274	if, for some reason, you don't like this connection, which will cause	771	can call if, for some reason, you don't like this connection, which will
275	C<tcp_connect> to try the next one (or call your callback without any	772	cause C<tcp_connect> to try the next one (or call your callback without
276	arguments if there are no more connections). In most cases, you can simply	773	any arguments if there are no more connections). In most cases, you can
277	ignore this argument.	774	simply ignore this argument.
278		775
279	$cb->($filehandle, $host, $port, $retry)	776	$cb->($filehandle, $host, $port, $retry)
280		777
281	If the connect is unsuccessful, then the C<$connect_cb> will be invoked	778	If the connect is unsuccessful, then the C<$connect_cb> will be invoked
282	without any arguments and C<$!> will be set appropriately (with C<ENXIO>	779	without any arguments and C<$!> will be set appropriately (with C<ENXIO>
283	indicating a DNS resolution failure).	780	indicating a DNS resolution failure).
284		781
		782	The callback will I<never> be invoked before C<tcp_connect> returns, even
		783	if C<tcp_connect> was able to connect immediately (e.g. on unix domain
		784	sockets).
		785
285	The file handle is perfect for being plugged into L<AnyEvent::Handle>, but	786	The file handle is perfect for being plugged into L<AnyEvent::Handle>, but
286	can be used as a normal perl file handle as well.	787	can be used as a normal perl file handle as well.
287		788
288	Unless called in void context, C<tcp_connect> returns a guard object that	789	Unless called in void context, C<tcp_connect> returns a guard object that
289	will automatically abort connecting when it gets destroyed (it does not do	790	will automatically cancel the connection attempt when it gets destroyed
		791	- in which case the callback will not be invoked. Destroying it does not
290	anything to the socket after the connect was successful).	792	do anything to the socket after the connect was successful - you cannot
		793	"uncall" a callback that has been invoked already.
291		794
292	Sometimes you need to "prepare" the socket before connecting, for example,	795	Sometimes you need to "prepare" the socket before connecting, for example,
293	to C<bind> it to some port, or you want a specific connect timeout that	796	to C<bind> it to some port, or you want a specific connect timeout that
294	is lower than your kernel's default timeout. In this case you can specify	797	is lower than your kernel's default timeout. In this case you can specify
295	a second callback, C<$prepare_cb>. It will be called with the file handle	798	a second callback, C<$prepare_cb>. It will be called with the file handle
…		…
298	timeout is to be used).	801	timeout is to be used).
299		802
300	Note that the socket could be either a IPv4 TCP socket or an IPv6 TCP	803	Note that the socket could be either a IPv4 TCP socket or an IPv6 TCP
301	socket (although only IPv4 is currently supported by this module).	804	socket (although only IPv4 is currently supported by this module).
302		805
		806	Note to the poor Microsoft Windows users: Windows (of course) doesn't
		807	correctly signal connection errors, so unless your event library works
		808	around this, failed connections will simply hang. The only event libraries
		809	that handle this condition correctly are L<EV> and L<Glib>. Additionally,
		810	AnyEvent works around this bug with L<Event> and in its pure-perl
		811	backend. All other libraries cannot correctly handle this condition. To
		812	lessen the impact of this windows bug, a default timeout of 30 seconds
		813	will be imposed on windows. Cygwin is not affected.
		814
303	Simple Example: connect to localhost on port 22.	815	Simple Example: connect to localhost on port 22.
304		816
305	tcp_connect localhost => 22, sub {	817	tcp_connect localhost => 22, sub {
306	my $fh = shift	818	my $fh = shift
307	or die "unable to connect: $!";	819	or die "unable to connect: $!";
308	# do something	820	# do something
309	};	821	};
310		822
311	Complex Example: connect to www.google.com on port 80 and make a simple	823	Complex Example: connect to www.google.com on port 80 and make a simple
312	GET request without much error handling. Also limit the connection timeout	824	GET request without much error handling. Also limit the connection timeout
313	to 15 seconds.	825	to 15 seconds.
314		826
…		…
318	or die "unable to connect: $!";	830	or die "unable to connect: $!";
319		831
320	my $handle; # avoid direct assignment so on_eof has it in scope.	832	my $handle; # avoid direct assignment so on_eof has it in scope.
321	$handle = new AnyEvent::Handle	833	$handle = new AnyEvent::Handle
322	fh => $fh,	834	fh => $fh,
		835	on_error => sub {
		836	warn "error $_[2]\n";
		837	$_[0]->destroy;
		838	},
323	on_eof => sub {	839	on_eof => sub {
324	undef $handle; # keep it alive till eof	840	$handle->destroy; # destroy handle
325	warn "done.\n";	841	warn "done.\n";
326	};	842	};
327		843
328	$handle->push_write ("GET / HTTP/1.0\015\012\015\012");	844	$handle->push_write ("GET / HTTP/1.0\015\012\015\012");
329		845
330	$handle->push_read_line ("\015\012\015\012", sub {	846	$handle->push_read (line => "\015\012\015\012", sub {
331	my ($handle, $line) = @_;	847	my ($handle, $line) = @_;
332		848
333	# print response header	849	# print response header
334	print "HEADER\n$line\n\nBODY\n";	850	print "HEADER\n$line\n\nBODY\n";
335		851
…		…
344	# could call $fh->bind etc. here	860	# could call $fh->bind etc. here
345		861
346	15	862	15
347	};	863	};
348		864
		865	Example: connect to a UNIX domain socket.
		866
		867	tcp_connect "unix/", "/tmp/.X11-unix/X0", sub {
		868	...
		869	}
		870
349	=cut	871	=cut
350		872
351	sub tcp_connect($$$;$) {	873	sub tcp_connect($$$;$) {
352	my ($host, $port, $connect, $prepare) = @_;	874	my ($host, $port, $connect, $prepare) = @_;
353		875
354	# see http://cr.yp.to/docs/connect.html for some background	876	# see http://cr.yp.to/docs/connect.html for some tricky aspects
		877	# also http://advogato.org/article/672.html
355		878
356	my %state = ( fh => undef );	879	my %state = ( fh => undef );
357		880
358	# name resolution	881	# name/service to type/sockaddr resolution
359	AnyEvent::DNS::addr $host, $port, 0, 0, 0, sub {	882	resolve_sockaddr $host, $port, 0, 0, undef, sub {
360	my @target = @_;	883	my @target = @_;
361		884
362	$state{next} = sub {	885	$state{next} = sub {
363	return unless exists $state{fh};	886	return unless exists $state{fh};
364		887
365	my $target = shift @target	888	my $target = shift @target
366	or do {	889	or return AE::postpone {
		890	return unless exists $state{fh};
367	%state = ();	891	%state = ();
368	return $connect->();	892	$connect->();
369	};	893	};
370		894
371	my ($domain, $type, $proto, $sockaddr) = @$target;	895	my ($domain, $type, $proto, $sockaddr) = @$target;
372		896
373	# socket creation	897	# socket creation
374	socket $state{fh}, $domain, $type, $proto	898	socket $state{fh}, $domain, $type, $proto
375	or return $state{next}();	899	or return $state{next}();
376		900
377	fh_nonblocking $state{fh}, 1;	901	fh_nonblocking $state{fh}, 1;
378		902
379	# prepare and optional timeout
380	if ($prepare) {
381	my $timeout = $prepare->($state{fh});	903	my $timeout = $prepare && $prepare->($state{fh});
382		904
		905	$timeout \|\|= 30 if AnyEvent::WIN32;
		906
383	$state{to} = AnyEvent->timer (after => $timeout, cb => sub {	907	$state{to} = AE::timer $timeout, 0, sub {
384	$! = &Errno::ETIMEDOUT;	908	$! = Errno::ETIMEDOUT;
385	$state{next}();	909	$state{next}();
386	}) if $timeout;	910	} if $timeout;
		911
		912	# now connect
		913	if (
		914	(connect $state{fh}, $sockaddr)
		915	\|\| ($! == Errno::EINPROGRESS # POSIX
		916	\|\| $! == Errno::EWOULDBLOCK
		917	# WSAEINPROGRESS intentionally not checked - it means something else entirely
		918	\|\| $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt
		919	\|\| $! == AnyEvent::Util::WSAEWOULDBLOCK)
387	}	920	) {
388		921	$state{ww} = AE::io $state{fh}, 1, sub {
389	# called when the connect was successful, which,
390	# in theory, could be the case immediately (but never is in practise)
391	my $connected = sub {
392	delete $state{ww};
393	delete $state{to};
394
395	# we are connected, or maybe there was an error	922	# we are connected, or maybe there was an error
396	if (my $sin = getpeername $state{fh}) {	923	if (my $sin = getpeername $state{fh}) {
397	my ($port, $host) = unpack_sockaddr $sin;	924	my ($port, $host) = unpack_sockaddr $sin;
398		925
		926	delete $state{ww}; delete $state{to};
		927
399	my $guard = guard {	928	my $guard = guard { %state = () };
400	%state = ();
401	};
402		929
403	$connect->($state{fh}, format_ip $host, $port, sub {	930	$connect->(delete $state{fh}, format_address $host, $port, sub {
404	$guard->cancel;	931	$guard->cancel;
		932	$state{next}();
		933	});
		934	} else {
		935	if ($! == Errno::ENOTCONN) {
		936	# dummy read to fetch real error code if !cygwin
		937	sysread $state{fh}, my $buf, 1;
		938
		939	# cygwin 1.5 continously reports "ready' but never delivers
		940	# an error with getpeername or sysread.
		941	# cygwin 1.7 only reports readyness once, but is otherwise
		942	# the same, which is actually more broken.
		943	# Work around both by using unportable SO_ERROR for cygwin.
		944	$! = (unpack "l", getsockopt $state{fh}, Socket::SOL_SOCKET(), Socket::SO_ERROR()) \|\| Errno::EAGAIN
		945	if AnyEvent::CYGWIN && $! == Errno::EAGAIN;
		946	}
		947
		948	return if $! == Errno::EAGAIN; # skip spurious wake-ups
		949
		950	delete $state{ww}; delete $state{to};
		951
405	$state{next}();	952	$state{next}();
406	});	953	}
407	} else {
408	# dummy read to fetch real error code
409	sysread $state{fh}, my $buf, 1 if $! == &Errno::ENOTCONN;
410	$state{next}();
411	}	954	};
412	};
413
414	# now connect
415	if (connect $state{fh}, $sockaddr) {
416	$connected->();
417	} elsif ($! == &Errno::EINPROGRESS \|\| $! == &Errno::EWOULDBLOCK) { # EINPROGRESS is POSIX
418	$state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $connected);
419	} else {	955	} else {
420	%state = ();	956	$state{next}();
421	$connect->();
422	}	957	}
423	};	958	};
424		959
425	$! = &Errno::ENXIO;	960	$! = Errno::ENXIO;
426	$state{next}();	961	$state{next}();
427	};	962	};
428		963
429	defined wantarray && guard { %state = () }	964	defined wantarray && guard { %state = () }
430	}	965	}
431		966
432	=item $guard = tcp_server $host, $port, $accept_cb[, $prepare_cb]	967	=item $guard = tcp_server $host, $service, $accept_cb[, $prepare_cb]
433		968
434	Create and bind a TCP socket to the given host (any IPv4 host if undef,	969	Create and bind a stream socket to the given host, and port, set the
435	otherwise it must be an IPv4 or IPv6 address) and port (service name or	970	SO_REUSEADDR flag (if applicable) and call C<listen>. Unlike the name
436	numeric port number, or an ephemeral port if given as zero or undef), set	971	implies, this function can also bind on UNIX domain sockets.
437	the SO_REUSEADDR flag and call C<listen>.
438		972
		973	For internet sockets, C<$host> must be an IPv4 or IPv6 address (or
		974	C<undef>, in which case it binds either to C<0> or to C<::>, depending
		975	on whether IPv4 or IPv6 is the preferred protocol, and maybe to both in
		976	future versions, as applicable).
		977
		978	To bind to the IPv4 wildcard address, use C<0>, to bind to the IPv6
		979	wildcard address, use C<::>.
		980
		981	The port is specified by C<$service>, which must be either a service name or
		982	a numeric port number (or C<0> or C<undef>, in which case an ephemeral
		983	port will be used).
		984
		985	For UNIX domain sockets, C<$host> must be C<unix/> and C<$service> must be
		986	the absolute pathname of the socket. This function will try to C<unlink>
		987	the socket before it tries to bind to it, and will try to unlink it after
		988	it stops using it. See SECURITY CONSIDERATIONS, below.
		989
439	For each new connection that could be C<accept>ed, call the C<$accept_cb>	990	For each new connection that could be C<accept>ed, call the C<<
440	with the file handle (in non-blocking mode) as first and the peer host and	991	$accept_cb->($fh, $host, $port) >> with the file handle (in non-blocking
441	port as second and third arguments (see C<tcp_connect> for details).	992	mode) as first, and the peer host and port as second and third arguments
		993	(see C<tcp_connect> for details).
442		994
443	Croaks on any errors.	995	Croaks on any errors it can detect before the listen.
444		996
445	If called in non-void context, then this function returns a guard object	997	If called in non-void context, then this function returns a guard object
446	whose lifetime it tied to the TCP server: If the object gets destroyed,	998	whose lifetime it tied to the TCP server: If the object gets destroyed,
447	the server will be stopped (but existing accepted connections will	999	the server will be stopped (but existing accepted connections will
448	continue).	1000	not be affected).
449		1001
450	If you need more control over the listening socket, you can provide a	1002	If you need more control over the listening socket, you can provide a
451	C<$prepare_cb>, which is called just before the C<listen ()> call, with	1003	C<< $prepare_cb->($fh, $host, $port) >>, which is called just before the
452	the listen file handle as first argument.	1004	C<listen ()> call, with the listen file handle as first argument, and IP
		1005	address and port number of the local socket endpoint as second and third
		1006	arguments.
453		1007
454	It should return the length of the listen queue (or C<0> for the default).	1008	It should return the length of the listen queue (or C<0> for the default).
455		1009
		1010	Note to IPv6 users: RFC-compliant behaviour for IPv6 sockets listening on
		1011	C<::> is to bind to both IPv6 and IPv4 addresses by default on dual-stack
		1012	hosts. Unfortunately, only GNU/Linux seems to implement this properly, so
		1013	if you want both IPv4 and IPv6 listening sockets you should create the
		1014	IPv6 socket first and then attempt to bind on the IPv4 socket, but ignore
		1015	any C<EADDRINUSE> errors.
		1016
456	Example: bind on TCP port 8888 on the local machine and tell each client	1017	Example: bind on some TCP port on the local machine and tell each client
457	to go away.	1018	to go away.
458		1019
459	tcp_server undef, 8888, sub {	1020	tcp_server undef, undef, sub {
460	my ($fh, $host, $port) = @_;	1021	my ($fh, $host, $port) = @_;
461		1022
462	syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";	1023	syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";
		1024	}, sub {
		1025	my ($fh, $thishost, $thisport) = @_;
		1026	warn "bound to $thishost, port $thisport\n";
463	};	1027	};
464		1028
		1029	Example: bind a server on a unix domain socket.
		1030
		1031	tcp_server "unix/", "/tmp/mydir/mysocket", sub {
		1032	my ($fh) = @_;
		1033	};
		1034
465	=cut	1035	=cut
466		1036
467	sub tcp_server($$$;$) {	1037	sub tcp_server($$$;$) {
468	my ($host, $port, $accept, $prepare) = @_;	1038	my ($host, $service, $accept, $prepare) = @_;
		1039
		1040	$host = $AnyEvent::PROTOCOL{ipv4} < $AnyEvent::PROTOCOL{ipv6} && AF_INET6
		1041	? "::" : "0"
		1042	unless defined $host;
		1043
		1044	my $ipn = parse_address $host
		1045	or Carp::croak "AnyEvent::Socket::tcp_server: cannot parse '$host' as host address";
		1046
		1047	my $af = address_family $ipn;
469		1048
470	my %state;	1049	my %state;
471		1050
472	socket $state{fh}, &Socket::AF_INET, &Socket::SOCK_STREAM, 0	1051	# win32 perl is too stupid to get this right :/
		1052	Carp::croak "tcp_server/socket: address family not supported"
		1053	if AnyEvent::WIN32 && $af == AF_UNIX;
		1054
		1055	socket $state{fh}, $af, SOCK_STREAM, 0
473	or Carp::croak "socket: $!";	1056	or Carp::croak "tcp_server/socket: $!";
474		1057
		1058	if ($af == AF_INET \|\| $af == AF_INET6) {
475	setsockopt $state{fh}, &Socket::SOL_SOCKET, &Socket::SO_REUSEADDR, 1	1059	setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1
476	or Carp::croak "so_reuseaddr: $!";	1060	or Carp::croak "tcp_server/so_reuseaddr: $!"
		1061	unless AnyEvent::WIN32; # work around windows bug
477		1062
478	bind $state{fh}, Socket::pack_sockaddr_in _tcp_port $port, socket_inet_aton ($host \|\| "0.0.0.0")	1063	unless ($service =~ /^\d*$/) {
		1064	$service = (getservbyname $service, "tcp")[2]
		1065	or Carp::croak "$service: service unknown"
		1066	}
		1067	} elsif ($af == AF_UNIX) {
		1068	unlink $service;
		1069	}
		1070
		1071	bind $state{fh}, pack_sockaddr $service, $ipn
479	or Carp::croak "bind: $!";	1072	or Carp::croak "bind: $!";
480		1073
		1074	if ($af == AF_UNIX) {
		1075	my $fh = $state{fh};
		1076	my $ino = (stat $fh)[1];
		1077	$state{unlink} = guard {
		1078	# this is racy, but is not designed to be foolproof, just best-effort
		1079	unlink $service
		1080	if $ino == (stat $fh)[1];
		1081	};
		1082	}
		1083
481	fh_nonblocking $state{fh}, 1;	1084	fh_nonblocking $state{fh}, 1;
482		1085
483	my $len = ($prepare && $prepare->($state{fh})) \|\| 128;	1086	my $len;
		1087
		1088	if ($prepare) {
		1089	my ($service, $host) = unpack_sockaddr getsockname $state{fh};
		1090	$len = $prepare && $prepare->($state{fh}, format_address $host, $service);
		1091	}
		1092
		1093	$len \|\|= 128;
484		1094
485	listen $state{fh}, $len	1095	listen $state{fh}, $len
486	or Carp::croak "listen: $!";	1096	or Carp::croak "listen: $!";
487		1097
488	$state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {	1098	$state{aw} = AE::io $state{fh}, 0, sub {
489	# this closure keeps $state alive	1099	# this closure keeps $state alive
490	while (my $peer = accept my $fh, $state{fh}) {	1100	while ($state{fh} && (my $peer = accept my $fh, $state{fh})) {
491	fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not	1101	fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not
		1102
492	my ($port, $host) = Socket::unpack_sockaddr_in $peer;	1103	my ($service, $host) = unpack_sockaddr $peer;
493	$accept->($fh, (Socket::inet_ntoa $host), $port);	1104	$accept->($fh, format_address $host, $service);
494	}	1105	}
495	});	1106	};
496		1107
497	defined wantarray	1108	defined wantarray
498	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency	1109	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency
499	: ()	1110	: ()
500	}	1111	}
501		1112
		1113	=item tcp_nodelay $fh, $enable
		1114
		1115	Enables (or disables) the C<TCP_NODELAY> socket option (also known as
		1116	Nagle's algorithm). Returns false on error, true otherwise.
		1117
		1118	=cut
		1119
		1120	sub tcp_nodelay($$) {
		1121	my $onoff = int ! ! $_[1];
		1122
		1123	setsockopt $_[0], Socket::IPPROTO_TCP (), Socket::TCP_NODELAY (), $onoff
		1124	}
		1125
		1126	=item tcp_congestion $fh, $algorithm
		1127
		1128	Sets the tcp congestion avoidance algorithm (via the C<TCP_CONGESTION>
		1129	socket option). The default is OS-specific, but is usually
		1130	C<reno>. Typical other available choices include C<cubic>, C<lp>, C<bic>,
		1131	C<highspeed>, C<htcp>, C<hybla>, C<illinois>, C<scalable>, C<vegas>,
		1132	C<veno>, C<westwood> and C<yeah>.
		1133
		1134	=cut
		1135
		1136	sub tcp_congestion($$) {
		1137	defined TCP_CONGESTION
		1138	? setsockopt $_[0], Socket::IPPROTO_TCP (), TCP_CONGESTION, "$_[1]"
		1139	: undef
		1140	}
		1141
502	1;	1142	1;
503		1143
504	=back	1144	=back
		1145
		1146	=head1 SECURITY CONSIDERATIONS
		1147
		1148	This module is quite powerful, with with power comes the ability to abuse
		1149	as well: If you accept "hostnames" and ports from untrusted sources,
		1150	then note that this can be abused to delete files (host=C<unix/>). This
		1151	is not really a problem with this module, however, as blindly accepting
		1152	any address and protocol and trying to bind a server or connect to it is
		1153	harmful in general.
505		1154
506	=head1 AUTHOR	1155	=head1 AUTHOR
507		1156
508	Marc Lehmann <schmorp@schmorp.de>	1157	Marc Lehmann <schmorp@schmorp.de>
509	http://home.schmorp.de/	1158	http://home.schmorp.de/

Diff Legend

-–
+Removed lines
-+
+Added lines
-<
+Changed lines
->
+Changed lines

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents): Revision 1.17 by root, Sat May 24 02:50:45 2008 UTC vs. Revision 1.133 by root, Sat Aug 13 16:32:31 2011 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.17 by root, Sat May 24 02:50:45 2008 UTC vs.
Revision 1.133 by root, Sat Aug 13 16:32:31 2011 UTC