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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.61 by root, Thu Aug 21 23:48:35 2008 UTC vs.
Revision 1.159 by root, Thu Nov 15 01:17:29 2012 UTC

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

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents): Revision 1.61 by root, Thu Aug 21 23:48:35 2008 UTC vs. Revision 1.159 by root, Thu Nov 15 01:17:29 2012 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.61 by root, Thu Aug 21 23:48:35 2008 UTC vs.
Revision 1.159 by root, Thu Nov 15 01:17:29 2012 UTC