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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.41 by root, Thu May 29 08:26:46 2008 UTC vs.
Revision 1.143 by root, Thu Mar 1 19:52:15 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
9	tcp_connect "gameserver.deliantra.net", 13327, sub {	9	tcp_connect "gameserver.deliantra.net", 13327, sub {
10	my ($fh) = @_	10	my ($fh) = @_
11	or die "gameserver.deliantra.net connect failed: $!";	11	or die "gameserver.deliantra.net connect failed: $!";
12		12
13	# enjoy your filehandle	13	# enjoy your filehandle
14	};	14	};
15		15
16	# a simple tcp server	16	# a simple tcp server
17	tcp_server undef, 8888, sub {	17	tcp_server undef, 8888, sub {
18	my ($fh, $host, $port) = @_;	18	my ($fh, $host, $port) = @_;
19		19
20	syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";	20	syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";
21	};	21	};
22		22
23	=head1 DESCRIPTION	23	=head1 DESCRIPTION
24		24
25	This module implements various utility functions for handling internet	25	This module implements various utility functions for handling internet
26	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
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(
		49	getprotobyname
		50	parse_hostport format_hostport
52	parse_ipv4 parse_ipv6	51	parse_ipv4 parse_ipv6
53	parse_ip parse_address	52	parse_ip parse_address
		53	format_ipv4 format_ipv6
54	format_ip format_address	54	format_ip format_address
55	address_family	55	address_family
56	inet_aton	56	inet_aton
57	tcp_server	57	tcp_server
58	tcp_connect	58	tcp_connect
59	);	59	);
60		60
61	our $VERSION = '1.0';	61	our $VERSION = $AnyEvent::VERSION;
62		62
63	=item $ipn = parse_ipv4 $dotted_quad	63	=item $ipn = parse_ipv4 $dotted_quad
64		64
65	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
66	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
…		…
78		78
79	# check leading parts against range	79	# check leading parts against range
80	return undef if grep $_ >= 256, @_[0 .. @_ - 2];	80	return undef if grep $_ >= 256, @_[0 .. @_ - 2];
81		81
82	# check trailing part against range	82	# check trailing part against range
83	return undef if $_[-1] >= 1 << (8 * (4 - $#_));	83	return undef if $_[-1] >= 2 ** (8 * (4 - $#_));
84		84
85	pack "N", (pop)	85	pack "N", (pop)
86	+ ($_[0] << 24)	86	+ ($_[0] << 24)
87	+ ($_[1] << 16)	87	+ ($_[1] << 16)
88	+ ($_[2] << 8);	88	+ ($_[2] << 8);
…		…
97	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
98	(and will not parse).	98	(and will not parse).
99		99
100	This function works similarly to C<inet_pton AF_INET6, ...>.	100	This function works similarly to C<inet_pton AF_INET6, ...>.
101		101
		102	Example:
		103
		104	print unpack "H*", parse_ipv6 "2002:5345::10.0.0.1";
		105	# => 2002534500000000000000000a000001
		106
102	=cut	107	=cut
103		108
104	sub parse_ipv6($) {	109	sub parse_ipv6($) {
105	# quick test to avoid longer processing	110	# quick test to avoid longer processing
106	my $n = $_[0] =~ y/://;	111	my $n = $_[0] =~ y/://;
…		…
136		141
137	# and done	142	# and done
138	pack "n*", map hex, @h, @t	143	pack "n*", map hex, @h, @t
139	}	144	}
140		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
141	sub parse_unix($) {	157	sub parse_unix($) {
142	$_[0] eq "unix/"	158	$_[0] eq "unix/"
143	? pack "S", AF_UNIX	159	? pack "S", AF_UNIX
144	: undef	160	: undef
145		161
146	}	162	}
147		163
148	=item $ipn = parse_address $text	164	=item $ipn = parse_address $ip
149		165
150	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
151	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
152	(binary).	168	(binary).
153		169
154	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
155	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
156	socket".	172	socket".
157		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
		183	=item $ipn = AnyEvent::Socket::aton $ip
		184
		185	Same as C<parse_address>, but not exported (think C<Socket::inet_aton> but
		186	I<without> name resolution).
		187
158	=cut	188	=cut
159		189
160	sub parse_address($) {	190	sub parse_address($) {
161	&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	}
162	}	199	}
163		200
164	*parse_ip =\&parse_address; #d#	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	}
		232
		233	=item ($host, $service) = parse_hostport $string[, $default_service]
		234
		235	Splitting a string of the form C<hostname:port> is a common
		236	problem. Unfortunately, just splitting on the colon makes it hard to
		237	specify IPv6 addresses and doesn't support the less common but well
		238	standardised C<[ip literal]> syntax.
		239
		240	This function tries to do this job in a better way, it supports the
		241	following formats, where C<port> can be a numerical port number of a
		242	service name, or a C<name=port> string, and the C< port> and C<:port>
		243	parts are optional. Also, everywhere where an IP address is supported
		244	a hostname or unix domain socket address is also supported (see
		245	C<parse_unix>), and strings starting with C</> will also be interpreted as
		246	unix domain sockets.
		247
		248	hostname:port e.g. "www.linux.org", "www.x.de:443", "www.x.de:https=443",
		249	ipv4:port e.g. "198.182.196.56", "127.1:22"
		250	ipv6 e.g. "::1", "affe::1"
		251	[ipv4or6]:port e.g. "[::1]", "[10.0.1]:80"
		252	[ipv4or6] port e.g. "[127.0.0.1]", "[www.x.org] 17"
		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"
		256
		257	It also supports defaulting the service name in a simple way by using
		258	C<$default_service> if no service was detected. If neither a service was
		259	detected nor a default was specified, then this function returns the
		260	empty list. The same happens when a parse error was detected, such as a
		261	hostname with a colon in it (the function is rather conservative, though).
		262
		263	Example:
		264
		265	print join ",", parse_hostport "localhost:443";
		266	# => "localhost,443"
		267
		268	print join ",", parse_hostport "localhost", "https";
		269	# => "localhost,https"
		270
		271	print join ",", parse_hostport "[::1]";
		272	# => "," (empty list)
		273
		274	print join ",", parse_host_port "/tmp/debug.sock";
		275	# => "unix/", "/tmp/debug.sock"
		276
		277	=cut
		278
		279	sub parse_hostport($;$) {
		280	my ($host, $port);
		281
		282	for ("$_[0]") { # work on a copy, just in case, and also reset pos
		283
		284	# shortcut for /path
		285	return ("unix/", $_)
		286	if m%^/%;
		287
		288	# parse host, special cases: "ipv6" or "ipv6 port"
		289	unless (
		290	($host) = /^\s* ([0-9a-fA-F:]:[0-9a-fA-F:]:[0-9a-fA-F\.:]*)/xgc
		291	and parse_ipv6 $host
		292	) {
		293	/^\s*/xgc;
		294
		295	if (/^ \[ ([^\[\]]+) \]/xgc) {
		296	$host = $1;
		297	} elsif (/^ ([^\[\]:\ ]+) /xgc) {
		298	$host = $1;
		299	} else {
		300	return;
		301	}
		302	}
		303
		304	# parse port
		305	if (/\G (?:\s+\|:) ([^:[:space:]]+) \s*$/xgc) {
		306	$port = $1;
		307	} elsif (/\G\s*$/gc && length $_[1]) {
		308	$port = $_[1];
		309	} else {
		310	return;
		311	}
		312
		313	}
		314
		315	# hostnames must not contain :'s
		316	return if $host =~ /:/ && !parse_ipv6 $host;
		317
		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"
		335	}
165		336
166	=item $sa_family = address_family $ipn	337	=item $sa_family = address_family $ipn
167		338
168	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 :)
169	of the given host address in network format.	340	of the given host address in network format.
…		…
176	: 16 == length $_[0]	347	: 16 == length $_[0]
177	? AF_INET6	348	? AF_INET6
178	: unpack "S", $_[0]	349	: unpack "S", $_[0]
179	}	350	}
180		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
181	=item $text = format_address $ipn	364	=item $text = format_address $ipn
182		365
183	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
184	octets for IPv6) and convert it into textual form.	367	octets for IPv6) and convert it into textual form.
185		368
…		…
188	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, ...>,
189	except it automatically detects the address type.	372	except it automatically detects the address type.
190		373
191	Returns C<undef> if it cannot detect the type.	374	Returns C<undef> if it cannot detect the type.
192		375
193	=cut	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.
194		379
195	sub format_address;	380	Example:
196	sub format_address($) {	381
197	my $af = address_family $_[0];	382	print format_address "\x01\x02\x03\x05";
198	if ($af == AF_INET) {	383	=> 1.2.3.5
		384
		385	=item $text = AnyEvent::Socket::ntoa $ipn
		386
		387	Same as format_address, but not exported (think C<inet_ntoa>).
		388
		389	=cut
		390
		391	sub format_ipv4($) {
199	return join ".", unpack "C4", $_[0]	392	join ".", unpack "C4", $_[0]
200	} elsif ($af == AF_INET6) {	393	}
		394
		395	sub format_ipv6($) {
		396	if ($_[0] =~ /^\x00\x00\x00\x00\x00\x00\x00\x00/) {
201	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]) {
202	return "::";	398	return "::";
203	} 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]) {
204	return "::1";	400	return "::1";
205	} 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) {
206	# v4compatible	402	# v4compatible
207	return "::" . format_address substr $_[0], 12;	403	return "::" . format_ipv4 substr $_[0], 12;
208	} 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) {
209	# v4mapped	405	# v4mapped
210	return "::ffff:" . format_address substr $_[0], 12;	406	return "::ffff:" . format_ipv4 substr $_[0], 12;
211	} 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) {
212	# v4translated	408	# v4translated
213	return "::ffff:0:" . format_address substr $_[0], 12;	409	return "::ffff:0:" . format_ipv4 substr $_[0], 12;
214	} else {
215	my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];
216
217	# this is rather sucky, I admit
218	$ip =~ s/^0:(?:0:)*(0$)?/::/
219	or $ip =~ s/(:0){7}$/::/ or $ip =~ s/(:0){7}/:/
220	or $ip =~ s/(:0){6}$/::/ or $ip =~ s/(:0){6}/:/
221	or $ip =~ s/(:0){5}$/::/ or $ip =~ s/(:0){5}/:/
222	or $ip =~ s/(:0){4}$/::/ or $ip =~ s/(:0){4}/:/
223	or $ip =~ s/(:0){3}$/::/ or $ip =~ s/(:0){3}/:/
224	or $ip =~ s/(:0){2}$/::/ or $ip =~ s/(:0){2}/:/
225	or $ip =~ s/(:0){1}$/::/ or $ip =~ s/(:0){1}/:/;
226	return $ip
227	}	410	}
228	} 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]) {
229	return "unix/"	435	return "unix/"
230	} else {	436	} else {
231	return undef	437	return undef
232	}	438	}
233	}	439	}
234		440
235	*format_ip = \&format_address;	441	*ntoa = \&format_address;
236		442
237	=item inet_aton $name_or_address, $cb->(@addresses)	443	=item inet_aton $name_or_address, $cb->(@addresses)
238		444
239	Works similarly to its Socket counterpart, except that it uses a	445	Works similarly to its Socket counterpart, except that it uses a
240	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
241	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
242	for IPv6).	448	readable format.
243		449
244	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,
245	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
246		467
247	=cut	468	=cut
248		469
249	sub inet_aton {	470	sub inet_aton {
250	my ($name, $cb) = @_;	471	my ($name, $cb) = @_;
…		…
254	} elsif (my $ipn = &parse_ipv6) {	475	} elsif (my $ipn = &parse_ipv6) {
255	$cb->($ipn);	476	$cb->($ipn);
256	} elsif ($name eq "localhost") { # rfc2606 et al.	477	} elsif ($name eq "localhost") { # rfc2606 et al.
257	$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);
258	} else {	479	} else {
259	require AnyEvent::DNS;	480	require AnyEvent::DNS unless $AnyEvent::DNS::VERSION;
260		481
261	# 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;
262	AnyEvent::DNS::a ($name, sub {	495	AnyEvent::DNS::a ($name, sub {
263	if (@_) {	496	$res[$ipv4] = [map &parse_ipv4, @_];
264	$cb->(map +(parse_ipv4 $_), @_);
265	} else {
266	$cb->();	497	$cv->end;
267	#AnyEvent::DNS::aaaa ($name, $cb); need inet_pton
268	}	498	});
269	});	499	};
270	}
271	}
272		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
273	# check for broken platforms with extra field in sockaddr structure	523	# check for broken platforms with an extra field in sockaddr structure
274	# 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
275	# 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
276	# correctness vs. bsd issue.	526	# correctness vs. bsd issue.)
277	my $pack_family = (0x55 == Socket::sockaddr_family "\x55\x55")	527	my $pack_family = 0x55 == sockaddr_family ("\x55\x55")
278	? "xC" : "S";	528	? "xC" : "S";
279		529
280	=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host	530	=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host
281		531
282	Pack the given port/host combination into a binary sockaddr	532	Pack the given port/host combination into a binary sockaddr
283	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
284	domain sockets (C<$host> == C<unix/> and C<$service> == absolute	534	domain sockets (C<$host> == C<unix/> and C<$service> == absolute
285	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: $!";
286		542
287	=cut	543	=cut
288		544
289	sub pack_sockaddr($$) {	545	sub pack_sockaddr($$) {
290	my $af = address_family $_[1];	546	my $af = address_family $_[1];
…		…
317	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
318	module (C<format_address> converts it to C<unix/>).	574	module (C<format_address> converts it to C<unix/>).
319		575
320	=cut	576	=cut
321		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
322	sub unpack_sockaddr($) {	584	sub unpack_sockaddr($) {
323	my $af = Socket::sockaddr_family $_[0];	585	my $af = sockaddr_family $_[0];
324		586
325	if ($af == AF_INET) {	587	if ($af == AF_INET) {
326	Socket::unpack_sockaddr_in $_[0]	588	Socket::unpack_sockaddr_in $_[0]
327	} elsif ($af == AF_INET6) {	589	} elsif ($af == AF_INET6) {
328	unpack "x2 n x4 a16", $_[0]	590	unpack "x2 n x4 a16", $_[0]
329	} elsif ($af == AF_UNIX) {	591	} elsif ($af == AF_UNIX) {
330	((Socket::unpack_sockaddr_un $_[0]), pack "S", AF_UNIX)	592	((Socket::unpack_sockaddr_un $_[0] ^ $sa_un_zero), pack "S", AF_UNIX)
331	} else {	593	} else {
332	Carp::croak "unpack_sockaddr: unsupported protocol family $af";	594	Carp::croak "unpack_sockaddr: unsupported protocol family $af";
333	}	595	}
334	}	596	}
335		597
…		…
338	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
339	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
340	protocol-independent way. It works remotely similar to the getaddrinfo	602	protocol-independent way. It works remotely similar to the getaddrinfo
341	posix function.	603	posix function.
342		604
343	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
344	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
345	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
346	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
347	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
348	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
349	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.
350		619
351	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
352	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,
353	C<$proto> will be ignored.	622	C<$proto> will be ignored.
354		623
…		…
356	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
357	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
358	type and any SRV records it might find.	627	type and any SRV records it might find.
359		628
360	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
361	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
362	C<$ENV{PERL_ANYEVENT_PROTOCOLS}>.	631	C<$ENV{PERL_ANYEVENT_PROTOCOLS}>.
363		632
364	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
365	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>).
366		636
367	The callback will receive zero or more array references that contain	637	The callback will receive zero or more array references that contain
368	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
369	C<$sockaddr> for use in C<connect> (or C<bind>).	639	C<$sockaddr> for use in C<connect> (or C<bind>).
370		640
…		…
374		644
375	resolve_sockaddr "google.com", "http", 0, undef, undef, sub { ... };	645	resolve_sockaddr "google.com", "http", 0, undef, undef, sub { ... };
376		646
377	=cut	647	=cut
378		648
		649	our %HOSTS;
		650	our $HOSTS;
		651
		652	if (
		653	open my $fh, "<",
		654	length $ENV{PERL_ANYEVENT_HOSTS} ? $ENV{PERL_ANYEVENT_HOSTS}
		655	: AnyEvent::WIN32 ? "$ENV{SystemRoot}/system32/drivers/etc/hosts"
		656	: "/etc/hosts"
		657	) {
		658	local $/;
		659	binmode $fh;
		660	$HOSTS = <$fh>;
		661	} else {
		662	$HOSTS = "";
		663	}
		664
		665	sub _parse_hosts() {
		666	#%HOSTS = ();
		667
		668	for (split /\n/, $HOSTS) {
		669	s/#.*$//;
		670	s/^[ \t]+//;
		671	y/A-Z/a-z/;
		672
		673	my ($addr, @aliases) = split /[ \t]+/;
		674	next unless @aliases;
		675
		676	if (my $ip = parse_ipv4 $addr) {
		677	push @{ $HOSTS{$_}[0] }, $ip
		678	for @aliases;
		679	} elsif (my $ip = parse_ipv6 $addr) {
		680	push @{ $HOSTS{$_}[1] }, $ip
		681	for @aliases;
		682	}
		683	}
		684
		685	undef $HOSTS;
		686	}
		687
379	sub resolve_sockaddr($$$$$$) {	688	sub resolve_sockaddr($$$$$$) {
380	my ($node, $service, $proto, $family, $type, $cb) = @_;	689	my ($node, $service, $proto, $family, $type, $cb) = @_;
381		690
382	if ($node eq "unix/") {	691	if ($node eq "unix/") {
383	return $cb->() if $family \|\| !/^\//; # no can do	692	return $cb->() if $family \|\| $service !~ /^\//; # no can do
384		693
385	return $cb->([AF_UNIX, $type, 0, Socket::pack_sockaddr_un $service]);	694	return $cb->([AF_UNIX, defined $type ? $type : SOCK_STREAM, 0, Socket::pack_sockaddr_un $service]);
386	}	695	}
387		696
388	unless (AF_INET6) {	697	unless (AF_INET6) {
389	$family != 6	698	$family != 6
390	or return $cb->();	699	or return $cb->();
…		…
399	$family \|\|= 6 unless $AnyEvent::PROTOCOL{ipv4};	708	$family \|\|= 6 unless $AnyEvent::PROTOCOL{ipv4};
400		709
401	$proto \|\|= "tcp";	710	$proto \|\|= "tcp";
402	$type \|\|= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;	711	$type \|\|= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;
403		712
404	my $proton = (getprotobyname $proto)[2]	713	my $proton = AnyEvent::Socket::getprotobyname $proto
405	or Carp::croak "$proto: protocol unknown";	714	or Carp::croak "$proto: protocol unknown";
406		715
407	my $port;	716	my $port;
408		717
409	if ($service =~ /^(\S+)=(\d+)$/) {	718	if ($service =~ /^(\S+)=(\d+)$/) {
…		…
413	} else {	722	} else {
414	$port = (getservbyname $service, $proto)[2]	723	$port = (getservbyname $service, $proto)[2]
415	or Carp::croak "$service/$proto: service unknown";	724	or Carp::croak "$service/$proto: service unknown";
416	}	725	}
417		726
418	my @target = [$node, $port];
419
420	# resolve a records / provide sockaddr structures	727	# resolve a records / provide sockaddr structures
421	my $resolve = sub {	728	my $resolve = sub {
		729	my @target = @_;
		730
422	my @res;	731	my @res;
423	my $cv = AnyEvent->condvar (cb => sub {	732	my $cv = AE::cv {
424	$cb->(	733	$cb->(
425	map $_->[2],	734	map $_->[2],
426	sort {	735	sort {
427	$AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]}	736	$AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]}
428	or $a->[0] <=> $b->[0]	737	or $a->[0] <=> $b->[0]
429	}	738	}
430	@res	739	@res
431	)	740	)
432	});	741	};
433		742
434	$cv->begin;	743	$cv->begin;
435	for my $idx (0 .. $#target) {	744	for my $idx (0 .. $#target) {
436	my ($node, $port) = @{ $target[$idx] };	745	my ($node, $port) = @{ $target[$idx] };
437		746
…		…
446	if ($af == AF_INET6 && $family != 4) {	755	if ($af == AF_INET6 && $family != 4) {
447	push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,	756	push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,
448	pack_sockaddr $port, $noden]]	757	pack_sockaddr $port, $noden]]
449	}	758	}
450	} else {	759	} else {
451	# ipv4	760	$node =~ y/A-Z/a-z/;
		761
		762	my $hosts = $HOSTS{$node};
		763
		764	# a records
452	if ($family != 6) {	765	if ($family != 6) {
453	$cv->begin;	766	$cv->begin;
454	AnyEvent::DNS::a $node, sub {	767	AnyEvent::DNS::a $node, sub {
455	push @res, [$idx, "ipv4", [AF_INET, $type, $proton,	768	push @res, [$idx, "ipv4", [AF_INET , $type, $proton, pack_sockaddr $port, parse_ipv4 $_]]
456	pack_sockaddr $port, parse_ipv4 $_]]
457	for @_;	769	for @_;
		770
		771	# dns takes precedence over hosts
		772	push @res,
		773	map [$idx, "ipv4", [AF_INET , $type, $proton, pack_sockaddr $port, $_]],
		774	@{ $hosts->[0] }
		775	unless @_;
		776
458	$cv->end;	777	$cv->end;
459	};	778	};
460	}	779	}
461		780
462	# ipv6	781	# aaaa records
463	if ($family != 4) {	782	if ($family != 4) {
464	$cv->begin;	783	$cv->begin;
465	AnyEvent::DNS::aaaa $node, sub {	784	AnyEvent::DNS::aaaa $node, sub {
466	push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,	785	push @res, [$idx, "ipv6", [AF_INET6, $type, $proton, pack_sockaddr $port, parse_ipv6 $_]]
467	pack_sockaddr $port, parse_ipv6 $_]]
468	for @_;	786	for @_;
		787
		788	push @res,
		789	map [$idx + 0.5, "ipv6", [AF_INET6, $type, $proton, pack_sockaddr $port, $_]],
		790	@{ $hosts->[1] }
		791	unless @_;
		792
469	$cv->end;	793	$cv->end;
470	};	794	};
471	}	795	}
472	}	796	}
473	}	797	}
474	$cv->end;	798	$cv->end;
475	};	799	};
476		800
		801	$node = AnyEvent::Util::idn_to_ascii $node
		802	if $node =~ /[^\x00-\x7f]/;
		803
		804	# parse hosts
		805	if (defined $HOSTS) {
		806	_parse_hosts;
		807	undef &_parse_hosts;
		808	}
		809
477	# try srv records, if applicable	810	# try srv records, if applicable
478	if ($node eq "localhost") {	811	if ($node eq "localhost") {
479	@target = (["127.0.0.1", $port], ["::1", $port]);	812	$resolve->(["127.0.0.1", $port], ["::1", $port]);
480	&$resolve;
481	} elsif (defined $service && !parse_address $node) {	813	} elsif (defined $service && !parse_address $node) {
482	AnyEvent::DNS::srv $service, $proto, $node, sub {	814	AnyEvent::DNS::srv $service, $proto, $node, sub {
483	my (@srv) = @_;	815	my (@srv) = @_;
484		816
		817	if (@srv) {
		818	# the only srv record has "." ("" here) => abort
		819	$srv[0][2] ne "" \|\| $#srv
		820	or return $cb->();
		821
		822	# use srv records then
		823	$resolve->(
		824	map ["$_->[3].", $_->[2]],
		825	grep $_->[3] ne ".",
		826	@srv
		827	);
		828	} else {
485	# no srv records, continue traditionally	829	# no srv records, continue traditionally
		830	$resolve->([$node, $port]);
486	@srv	831	}
487	or return &$resolve;
488
489	# only srv record has "." => abort
490	$srv[0][2] ne "." \|\| $#srv
491	or return $cb->();
492
493	# use srv records then
494	@target = map ["$_->[3].", $_->[2]],
495	grep $_->[3] ne ".",
496	@srv;
497
498	&$resolve;
499	};	832	};
500	} else {	833	} else {
501	&$resolve;	834	# most common case
		835	$resolve->([$node, $port]);
502	}	836	}
503	}	837	}
504		838
505	=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]	839	=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]
506		840
507	This is a convenience function that creates a TCP socket and makes a 100%	841	This is a convenience function that creates a TCP socket and makes a
508	non-blocking connect to the given C<$host> (which can be a hostname or	842	100% non-blocking connect to the given C<$host> (which can be a DNS/IDN
509	a textual IP address, or the string C<unix/> for UNIX domain sockets)	843	hostname or a textual IP address, or the string C<unix/> for UNIX domain
510	and C<$service> (which can be a numeric port number or a service name,	844	sockets) and C<$service> (which can be a numeric port number or a service
511	or a C<servicename=portnumber> string, or the pathname to a UNIX domain	845	name, or a C<servicename=portnumber> string, or the pathname to a UNIX
512	socket).	846	domain socket).
513		847
514	If both C<$host> and C<$port> are names, then this function will use SRV	848	If both C<$host> and C<$port> are names, then this function will use SRV
515	records to locate the real target(s).	849	records to locate the real target(s).
516		850
517	In either case, it will create a list of target hosts (e.g. for multihomed	851	In either case, it will create a list of target hosts (e.g. for multihomed
518	hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to	852	hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to
519	each in turn.	853	each in turn.
520		854
521	If the connect is successful, then the C<$connect_cb> will be invoked with	855	After the connection is established, then the C<$connect_cb> will be
522	the socket file handle (in non-blocking mode) as first and the peer host	856	invoked with the socket file handle (in non-blocking mode) as first, and
523	(as a textual IP address) and peer port as second and third arguments,	857	the peer host (as a textual IP address) and peer port as second and third
524	respectively. The fourth argument is a code reference that you can call	858	arguments, respectively. The fourth argument is a code reference that you
525	if, for some reason, you don't like this connection, which will cause	859	can call if, for some reason, you don't like this connection, which will
526	C<tcp_connect> to try the next one (or call your callback without any	860	cause C<tcp_connect> to try the next one (or call your callback without
527	arguments if there are no more connections). In most cases, you can simply	861	any arguments if there are no more connections). In most cases, you can
528	ignore this argument.	862	simply ignore this argument.
529		863
530	$cb->($filehandle, $host, $port, $retry)	864	$cb->($filehandle, $host, $port, $retry)
531		865
532	If the connect is unsuccessful, then the C<$connect_cb> will be invoked	866	If the connect is unsuccessful, then the C<$connect_cb> will be invoked
533	without any arguments and C<$!> will be set appropriately (with C<ENXIO>	867	without any arguments and C<$!> will be set appropriately (with C<ENXIO>
534	indicating a DNS resolution failure).	868	indicating a DNS resolution failure).
535		869
		870	The callback will I<never> be invoked before C<tcp_connect> returns, even
		871	if C<tcp_connect> was able to connect immediately (e.g. on unix domain
		872	sockets).
		873
536	The file handle is perfect for being plugged into L<AnyEvent::Handle>, but	874	The file handle is perfect for being plugged into L<AnyEvent::Handle>, but
537	can be used as a normal perl file handle as well.	875	can be used as a normal perl file handle as well.
538		876
539	Unless called in void context, C<tcp_connect> returns a guard object that	877	Unless called in void context, C<tcp_connect> returns a guard object that
540	will automatically abort connecting when it gets destroyed (it does not do	878	will automatically cancel the connection attempt when it gets destroyed
		879	- in which case the callback will not be invoked. Destroying it does not
541	anything to the socket after the connect was successful).	880	do anything to the socket after the connect was successful - you cannot
		881	"uncall" a callback that has been invoked already.
542		882
543	Sometimes you need to "prepare" the socket before connecting, for example,	883	Sometimes you need to "prepare" the socket before connecting, for example,
544	to C<bind> it to some port, or you want a specific connect timeout that	884	to C<bind> it to some port, or you want a specific connect timeout that
545	is lower than your kernel's default timeout. In this case you can specify	885	is lower than your kernel's default timeout. In this case you can specify
546	a second callback, C<$prepare_cb>. It will be called with the file handle	886	a second callback, C<$prepare_cb>. It will be called with the file handle
…		…
560	lessen the impact of this windows bug, a default timeout of 30 seconds	900	lessen the impact of this windows bug, a default timeout of 30 seconds
561	will be imposed on windows. Cygwin is not affected.	901	will be imposed on windows. Cygwin is not affected.
562		902
563	Simple Example: connect to localhost on port 22.	903	Simple Example: connect to localhost on port 22.
564		904
565	tcp_connect localhost => 22, sub {	905	tcp_connect localhost => 22, sub {
566	my $fh = shift	906	my $fh = shift
567	or die "unable to connect: $!";	907	or die "unable to connect: $!";
568	# do something	908	# do something
569	};	909	};
570		910
571	Complex Example: connect to www.google.com on port 80 and make a simple	911	Complex Example: connect to www.google.com on port 80 and make a simple
572	GET request without much error handling. Also limit the connection timeout	912	GET request without much error handling. Also limit the connection timeout
573	to 15 seconds.	913	to 15 seconds.
574		914
…		…
578	or die "unable to connect: $!";	918	or die "unable to connect: $!";
579		919
580	my $handle; # avoid direct assignment so on_eof has it in scope.	920	my $handle; # avoid direct assignment so on_eof has it in scope.
581	$handle = new AnyEvent::Handle	921	$handle = new AnyEvent::Handle
582	fh => $fh,	922	fh => $fh,
		923	on_error => sub {
		924	AE::log error => "error $_[2]";
		925	$_[0]->destroy;
		926	},
583	on_eof => sub {	927	on_eof => sub {
584	undef $handle; # keep it alive till eof	928	$handle->destroy; # destroy handle
585	warn "done.\n";	929	AE::log info => "done.";
586	};	930	};
587		931
588	$handle->push_write ("GET / HTTP/1.0\015\012\015\012");	932	$handle->push_write ("GET / HTTP/1.0\015\012\015\012");
589		933
590	$handle->push_read_line ("\015\012\015\012", sub {	934	$handle->push_read (line => "\015\012\015\012", sub {
591	my ($handle, $line) = @_;	935	my ($handle, $line) = @_;
592		936
593	# print response header	937	# print response header
594	print "HEADER\n$line\n\nBODY\n";	938	print "HEADER\n$line\n\nBODY\n";
595		939
…		…
615	=cut	959	=cut
616		960
617	sub tcp_connect($$$;$) {	961	sub tcp_connect($$$;$) {
618	my ($host, $port, $connect, $prepare) = @_;	962	my ($host, $port, $connect, $prepare) = @_;
619		963
620	# see http://cr.yp.to/docs/connect.html for some background	964	# see http://cr.yp.to/docs/connect.html for some tricky aspects
621	# also http://advogato.org/article/672.html	965	# also http://advogato.org/article/672.html
622		966
623	my %state = ( fh => undef );	967	my %state = ( fh => undef );
624		968
625	# name/service to type/sockaddr resolution	969	# name/service to type/sockaddr resolution
626	resolve_sockaddr $host, $port, 0, 0, 0, sub {	970	resolve_sockaddr $host, $port, 0, 0, undef, sub {
627	my @target = @_;	971	my @target = @_;
628		972
629	$state{next} = sub {	973	$state{next} = sub {
630	return unless exists $state{fh};	974	return unless exists $state{fh};
631		975
		976	my $errno = $!;
632	my $target = shift @target	977	my $target = shift @target
633	or do {	978	or return AE::postpone {
		979	return unless exists $state{fh};
634	%state = ();	980	%state = ();
		981	$! = $errno;
635	return $connect->();	982	$connect->();
636	};	983	};
637		984
638	my ($domain, $type, $proto, $sockaddr) = @$target;	985	my ($domain, $type, $proto, $sockaddr) = @$target;
639		986
640	# socket creation	987	# socket creation
…		…
645		992
646	my $timeout = $prepare && $prepare->($state{fh});	993	my $timeout = $prepare && $prepare->($state{fh});
647		994
648	$timeout \|\|= 30 if AnyEvent::WIN32;	995	$timeout \|\|= 30 if AnyEvent::WIN32;
649		996
650	$state{to} = AnyEvent->timer (after => $timeout, cb => sub {	997	$state{to} = AE::timer $timeout, 0, sub {
651	$! = &Errno::ETIMEDOUT;	998	$! = Errno::ETIMEDOUT;
652	$state{next}();	999	$state{next}();
653	}) if $timeout;	1000	} if $timeout;
654		1001
655	# called when the connect was successful, which,	1002	# now connect
656	# in theory, could be the case immediately (but never is in practise)	1003	if (
657	my $connected = sub {	1004	(connect $state{fh}, $sockaddr)
658	delete $state{ww};	1005	\|\| ($! == Errno::EINPROGRESS # POSIX
659	delete $state{to};	1006	\|\| $! == Errno::EWOULDBLOCK
660		1007	# WSAEINPROGRESS intentionally not checked - it means something else entirely
		1008	\|\| $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt
		1009	\|\| $! == AnyEvent::Util::WSAEWOULDBLOCK)
		1010	) {
		1011	$state{ww} = AE::io $state{fh}, 1, sub {
661	# we are connected, or maybe there was an error	1012	# we are connected, or maybe there was an error
662	if (my $sin = getpeername $state{fh}) {	1013	if (my $sin = getpeername $state{fh}) {
663	my ($port, $host) = unpack_sockaddr $sin;	1014	my ($port, $host) = unpack_sockaddr $sin;
664		1015
		1016	delete $state{ww}; delete $state{to};
		1017
665	my $guard = guard {	1018	my $guard = guard { %state = () };
666	%state = ();
667	};
668		1019
669	$connect->($state{fh}, format_address $host, $port, sub {	1020	$connect->(delete $state{fh}, format_address $host, $port, sub {
670	$guard->cancel;	1021	$guard->cancel;
		1022	$state{next}();
		1023	});
		1024	} else {
		1025	if ($! == Errno::ENOTCONN) {
		1026	# dummy read to fetch real error code if !cygwin
		1027	sysread $state{fh}, my $buf, 1;
		1028
		1029	# cygwin 1.5 continously reports "ready' but never delivers
		1030	# an error with getpeername or sysread.
		1031	# cygwin 1.7 only reports readyness once, but is otherwise
		1032	# the same, which is actually more broken.
		1033	# Work around both by using unportable SO_ERROR for cygwin.
		1034	$! = (unpack "l", getsockopt $state{fh}, Socket::SOL_SOCKET(), Socket::SO_ERROR()) \|\| Errno::EAGAIN
		1035	if AnyEvent::CYGWIN && $! == Errno::EAGAIN;
		1036	}
		1037
		1038	return if $! == Errno::EAGAIN; # skip spurious wake-ups
		1039
		1040	delete $state{ww}; delete $state{to};
		1041
671	$state{next}();	1042	$state{next}();
672	});	1043	}
673	} else {
674	# dummy read to fetch real error code
675	sysread $state{fh}, my $buf, 1 if $! == &Errno::ENOTCONN;
676	$state{next}();
677	}	1044	};
678	};
679
680	# now connect
681	if (connect $state{fh}, $sockaddr) {
682	$connected->();
683	} elsif ($! == &Errno::EINPROGRESS # POSIX
684	\|\| $! == &Errno::EWOULDBLOCK
685	# WSAEINPROGRESS intentionally not checked - it means something else entirely
686	\|\| $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt
687	\|\| $! == AnyEvent::Util::WSAEWOULDBLOCK) {
688	$state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $connected);
689	} else {	1045	} else {
690	$state{next}();	1046	$state{next}();
691	}	1047	}
692	};	1048	};
693		1049
694	$! = &Errno::ENXIO;	1050	$! = Errno::ENXIO;
695	$state{next}();	1051	$state{next}();
696	};	1052	};
697		1053
698	defined wantarray && guard { %state = () }	1054	defined wantarray && guard { %state = () }
699	}	1055	}
700		1056
701	=item $guard = tcp_server $host, $service, $accept_cb[, $prepare_cb]	1057	=item $guard = tcp_server $host, $service, $accept_cb[, $prepare_cb]
702		1058
703	Create and bind a stream socket to the given host, and port, set the	1059	Create and bind a stream socket to the given host address and port, set
704	SO_REUSEADDR flag (if applicable) and call C<listen>. Unlike the name	1060	the SO_REUSEADDR flag (if applicable) and call C<listen>. Unlike the name
705	implies, this function can also bind on UNIX domain sockets.	1061	implies, this function can also bind on UNIX domain sockets.
706		1062
707	For internet sockets, C<$host> must be an IPv4 or IPv6 address (or	1063	For internet sockets, C<$host> must be an IPv4 or IPv6 address (or
708	C<undef>, in which case it binds either to C<0> or to C<::>, depending	1064	C<undef>, in which case it binds either to C<0> or to C<::>, depending
709	on whether IPv4 or IPv6 is the preferred protocol, and maybe to both in	1065	on whether IPv4 or IPv6 is the preferred protocol, and maybe to both in
710	future versions, as applicable).	1066	future versions, as applicable).
711		1067
712	To bind to the IPv4 wildcard address, use C<0>, to bind to the IPv6	1068	To bind to the IPv4 wildcard address, use C<0>, to bind to the IPv6
713	wildcard address, use C<::>.	1069	wildcard address, use C<::>.
714		1070
715	The port is specified by C<$service>, which must be either a service name or	1071	The port is specified by C<$service>, which must be either a service name
716	a numeric port number (or C<0> or C<undef>, in which case an ephemeral	1072	or a numeric port number (or C<0> or C<undef>, in which case an ephemeral
717	port will be used).	1073	port will be used).
718		1074
719	For UNIX domain sockets, C<$host> must be C<unix/> and C<$service> must be	1075	For UNIX domain sockets, C<$host> must be C<unix/> and C<$service> must be
720	the absolute pathname of the socket. This function will try to C<unlink>	1076	the absolute pathname of the socket. This function will try to C<unlink>
721	the socket before it tries to bind to it. See SECURITY CONSIDERATIONS,	1077	the socket before it tries to bind to it, and will try to unlink it after
722	below.	1078	it stops using it. See SECURITY CONSIDERATIONS, below.
723		1079
724	For each new connection that could be C<accept>ed, call the C<<	1080	For each new connection that could be C<accept>ed, call the C<<
725	$accept_cb->($fh, $host, $port) >> with the file handle (in non-blocking	1081	$accept_cb->($fh, $host, $port) >> with the file handle (in non-blocking
726	mode) as first and the peer host and port as second and third arguments	1082	mode) as first, and the peer host and port as second and third arguments
727	(see C<tcp_connect> for details).	1083	(see C<tcp_connect> for details).
728		1084
729	Croaks on any errors it can detect before the listen.	1085	Croaks on any errors it can detect before the listen.
730		1086
731	If called in non-void context, then this function returns a guard object	1087	If called in non-void context, then this function returns a guard object
732	whose lifetime it tied to the TCP server: If the object gets destroyed,	1088	whose lifetime it tied to the TCP server: If the object gets destroyed,
733	the server will be stopped (but existing accepted connections will	1089	the server will be stopped (but existing accepted connections will
734	continue).	1090	not be affected).
		1091
		1092	Regardless, when the function returns to the caller, the socket is bound
		1093	and in listening state.
735		1094
736	If you need more control over the listening socket, you can provide a	1095	If you need more control over the listening socket, you can provide a
737	C<< $prepare_cb->($fh, $host, $port) >>, which is called just before the	1096	C<< $prepare_cb->($fh, $host, $port) >>, which is called just before the
738	C<listen ()> call, with the listen file handle as first argument, and IP	1097	C<listen ()> call, with the listen file handle as first argument, and IP
739	address and port number of the local socket endpoint as second and third	1098	address and port number of the local socket endpoint as second and third
…		…
755	my ($fh, $host, $port) = @_;	1114	my ($fh, $host, $port) = @_;
756		1115
757	syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";	1116	syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";
758	}, sub {	1117	}, sub {
759	my ($fh, $thishost, $thisport) = @_;	1118	my ($fh, $thishost, $thisport) = @_;
760	warn "bound to $thishost, port $thisport\n";	1119	AE::log info => "bound to $thishost, port $thisport";
		1120	};
		1121
		1122	Example: bind a server on a unix domain socket.
		1123
		1124	tcp_server "unix/", "/tmp/mydir/mysocket", sub {
		1125	my ($fh) = @_;
761	};	1126	};
762		1127
763	=cut	1128	=cut
764		1129
765	sub tcp_server($$$;$) {	1130	sub tcp_server($$$;$) {
…		…
797	}	1162	}
798		1163
799	bind $state{fh}, pack_sockaddr $service, $ipn	1164	bind $state{fh}, pack_sockaddr $service, $ipn
800	or Carp::croak "bind: $!";	1165	or Carp::croak "bind: $!";
801		1166
		1167	if ($af == AF_UNIX) {
		1168	my $fh = $state{fh};
		1169	my $ino = (stat $fh)[1];
		1170	$state{unlink} = guard {
		1171	# this is racy, but is not designed to be foolproof, just best-effort
		1172	unlink $service
		1173	if $ino == (stat $fh)[1];
		1174	};
		1175	}
		1176
802	fh_nonblocking $state{fh}, 1;	1177	fh_nonblocking $state{fh}, 1;
803		1178
804	my $len;	1179	my $len;
805		1180
806	if ($prepare) {	1181	if ($prepare) {
…		…
811	$len \|\|= 128;	1186	$len \|\|= 128;
812		1187
813	listen $state{fh}, $len	1188	listen $state{fh}, $len
814	or Carp::croak "listen: $!";	1189	or Carp::croak "listen: $!";
815		1190
816	$state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {	1191	$state{aw} = AE::io $state{fh}, 0, sub {
817	# this closure keeps $state alive	1192	# this closure keeps $state alive
818	while (my $peer = accept my $fh, $state{fh}) {	1193	while ($state{fh} && (my $peer = accept my $fh, $state{fh})) {
819	fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not	1194	fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not
820		1195
821	my ($service, $host) = unpack_sockaddr $peer;	1196	my ($service, $host) = unpack_sockaddr $peer;
822	$accept->($fh, format_address $host, $service);	1197	$accept->($fh, format_address $host, $service);
823	}	1198	}
824	});	1199	};
825		1200
826	defined wantarray	1201	defined wantarray
827	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency	1202	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency
828	: ()	1203	: ()
		1204	}
		1205
		1206	=item tcp_nodelay $fh, $enable
		1207
		1208	Enables (or disables) the C<TCP_NODELAY> socket option (also known as
		1209	Nagle's algorithm). Returns false on error, true otherwise.
		1210
		1211	=cut
		1212
		1213	sub tcp_nodelay($$) {
		1214	my $onoff = int ! ! $_[1];
		1215
		1216	setsockopt $_[0], Socket::IPPROTO_TCP (), Socket::TCP_NODELAY (), $onoff
		1217	}
		1218
		1219	=item tcp_congestion $fh, $algorithm
		1220
		1221	Sets the tcp congestion avoidance algorithm (via the C<TCP_CONGESTION>
		1222	socket option). The default is OS-specific, but is usually
		1223	C<reno>. Typical other available choices include C<cubic>, C<lp>, C<bic>,
		1224	C<highspeed>, C<htcp>, C<hybla>, C<illinois>, C<scalable>, C<vegas>,
		1225	C<veno>, C<westwood> and C<yeah>.
		1226
		1227	=cut
		1228
		1229	sub tcp_congestion($$) {
		1230	defined TCP_CONGESTION
		1231	? setsockopt $_[0], Socket::IPPROTO_TCP (), TCP_CONGESTION, "$_[1]"
		1232	: undef
829	}	1233	}
830		1234
831	1;	1235	1;
832		1236
833	=back	1237	=back

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents): Revision 1.41 by root, Thu May 29 08:26:46 2008 UTC vs. Revision 1.143 by root, Thu Mar 1 19:52:15 2012 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.41 by root, Thu May 29 08:26:46 2008 UTC vs.
Revision 1.143 by root, Thu Mar 1 19:52:15 2012 UTC