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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.36 by root, Wed May 28 21:29:03 2008 UTC vs.
Revision 1.152 by root, Mon Apr 9 02:25:48 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/) {
		397	if (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0 eq $_[0]) {
		398	return "::";
		399	} elsif (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1 eq $_[0]) {
		400	return "::1";
201	if (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) {
202	# v4compatible	402	# v4compatible
203	return "::" . format_address substr $_[0], 12;	403	return "::" . format_ipv4 substr $_[0], 12;
204	} 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) {
205	# v4mapped	405	# v4mapped
206	return "::ffff:" . format_address substr $_[0], 12;	406	return "::ffff:" . format_ipv4 substr $_[0], 12;
207	} 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) {
208	# v4translated	408	# v4translated
209	return "::ffff:0:" . format_address substr $_[0], 12;	409	return "::ffff:0:" . format_ipv4 substr $_[0], 12;
210	} else {
211	my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];
212
213	$ip =~ s/^0:(?:0:)*(0$)?/::/
214	or $ip =~ s/(:0)+$/::/
215	or $ip =~ s/(:0)+/:/;
216	return $ip
217	}	410	}
218	} 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]) {
219	return "unix/"	435	return "unix/"
220	} else {	436	} else {
221	return undef	437	return undef
222	}	438	}
223	}	439	}
224		440
225	*format_ip = \&format_address;	441	*ntoa = \&format_address;
226		442
227	=item inet_aton $name_or_address, $cb->(@addresses)	443	=item inet_aton $name_or_address, $cb->(@addresses)
228		444
229	Works similarly to its Socket counterpart, except that it uses a	445	Works similarly to its Socket counterpart, except that it uses a
230	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
231	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
232	for IPv6).	448	readable format.
233		449
234	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,
235	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
236		467
237	=cut	468	=cut
238		469
239	sub inet_aton {	470	sub inet_aton {
240	my ($name, $cb) = @_;	471	my ($name, $cb) = @_;
…		…
244	} elsif (my $ipn = &parse_ipv6) {	475	} elsif (my $ipn = &parse_ipv6) {
245	$cb->($ipn);	476	$cb->($ipn);
246	} elsif ($name eq "localhost") { # rfc2606 et al.	477	} elsif ($name eq "localhost") { # rfc2606 et al.
247	$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);
248	} else {	479	} else {
249	require AnyEvent::DNS;	480	require AnyEvent::DNS unless $AnyEvent::DNS::VERSION;
250		481
251	# 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;
252	AnyEvent::DNS::a ($name, sub {	495	AnyEvent::DNS::a ($name, sub {
253	if (@_) {	496	$res[$ipv4] = [map &parse_ipv4, @_];
254	$cb->(map +(parse_ipv4 $_), @_);
255	} else {
256	$cb->();	497	$cv->end;
257	#AnyEvent::DNS::aaaa ($name, $cb); need inet_pton
258	}	498	});
259	});	499	};
260	}
261	}
262		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
263	# check for broken platforms with extra field in sockaddr structure	523	# check for broken platforms with an extra field in sockaddr structure
264	# 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
265	# 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
266	# correctness vs. bsd issue.	526	# correctness vs. bsd issue.)
267	my $pack_family = 0x55 == Socket::sockaddr_family "\x55\x55"	527	my $pack_family = 0x55 == sockaddr_family ("\x55\x55")
268	? "xC" : "S";	528	? "xC" : "S";
269		529
270	=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host	530	=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host
271		531
272	Pack the given port/host combination into a binary sockaddr	532	Pack the given port/host combination into a binary sockaddr
273	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
274	domain sockets (C<$host> == C<unix/> and C<$service> == absolute	534	domain sockets (C<$host> == C<unix/> and C<$service> == absolute
275	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: $!";
276		542
277	=cut	543	=cut
278		544
279	sub pack_sockaddr($$) {	545	sub pack_sockaddr($$) {
280	my $af = address_family $_[1];	546	my $af = address_family $_[1];
…		…
307	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
308	module (C<format_address> converts it to C<unix/>).	574	module (C<format_address> converts it to C<unix/>).
309		575
310	=cut	576	=cut
311		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
312	sub unpack_sockaddr($) {	584	sub unpack_sockaddr($) {
313	my $af = Socket::sockaddr_family $_[0];	585	my $af = sockaddr_family $_[0];
314		586
315	if ($af == AF_INET) {	587	if ($af == AF_INET) {
316	Socket::unpack_sockaddr_in $_[0]	588	Socket::unpack_sockaddr_in $_[0]
317	} elsif ($af == AF_INET6) {	589	} elsif ($af == AF_INET6) {
318	unpack "x2 n x4 a16", $_[0]	590	unpack "x2 n x4 a16", $_[0]
319	} elsif ($af == AF_UNIX) {	591	} elsif ($af == AF_UNIX) {
320	((Socket::unpack_sockaddr_un $_[0]), pack "S", AF_UNIX)	592	((Socket::unpack_sockaddr_un $_[0] ^ $sa_un_zero), pack "S", AF_UNIX)
321	} else {	593	} else {
322	Carp::croak "unpack_sockaddr: unsupported protocol family $af";	594	Carp::croak "unpack_sockaddr: unsupported protocol family $af";
323	}	595	}
324	}	596	}
325		597
…		…
328	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
329	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
330	protocol-independent way. It works remotely similar to the getaddrinfo	602	protocol-independent way. It works remotely similar to the getaddrinfo
331	posix function.	603	posix function.
332		604
333	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
334	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
335	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
336	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
337	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
338	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
339	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.
340		619
341	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
342	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,
343	C<$proto> will be ignored.	622	C<$proto> will be ignored.
344		623
…		…
346	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
347	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
348	type and any SRV records it might find.	627	type and any SRV records it might find.
349		628
350	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
351	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
352	C<$ENV{PERL_ANYEVENT_PROTOCOLS}>.	631	C<$ENV{PERL_ANYEVENT_PROTOCOLS}>.
353		632
354	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
355	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>).
356		636
357	The callback will receive zero or more array references that contain	637	The callback will receive zero or more array references that contain
358	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
359	C<$sockaddr> for use in C<connect> (or C<bind>).	639	C<$sockaddr> for use in C<connect> (or C<bind>).
360		640
…		…
364		644
365	resolve_sockaddr "google.com", "http", 0, undef, undef, sub { ... };	645	resolve_sockaddr "google.com", "http", 0, undef, undef, sub { ... };
366		646
367	=cut	647	=cut
368		648
		649	our %HOSTS; # $HOSTS{$nodename}[$ipv6] = [@aliases...]
		650	our @HOSTS_CHECKING; # callbacks to call when hosts have been loaded
		651	our $HOSTS_MTIME;
		652
		653	sub _parse_hosts($) {
		654	%HOSTS = ();
		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 clal 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	}
		711
369	sub resolve_sockaddr($$$$$$) {	712	sub resolve_sockaddr($$$$$$) {
370	my ($node, $service, $proto, $family, $type, $cb) = @_;	713	my ($node, $service, $proto, $family, $type, $cb) = @_;
371		714
372	if ($node eq "unix/") {	715	if ($node eq "unix/") {
373	return $cb->() if $family \|\| !/^\//; # no can do	716	return $cb->() if $family \|\| $service !~ /^\//; # no can do
374		717
375	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]);
376	}	719	}
377		720
378	unless (AF_INET6) {	721	unless (AF_INET6) {
379	$family != 6	722	$family != 6
380	or return $cb->();	723	or return $cb->();
…		…
389	$family \|\|= 6 unless $AnyEvent::PROTOCOL{ipv4};	732	$family \|\|= 6 unless $AnyEvent::PROTOCOL{ipv4};
390		733
391	$proto \|\|= "tcp";	734	$proto \|\|= "tcp";
392	$type \|\|= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;	735	$type \|\|= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;
393		736
394	my $proton = (getprotobyname $proto)[2]	737	my $proton = AnyEvent::Socket::getprotobyname $proto
395	or Carp::croak "$proto: protocol unknown";	738	or Carp::croak "$proto: protocol unknown";
396		739
397	my $port;	740	my $port;
398		741
399	if ($service =~ /^(\S+)=(\d+)$/) {	742	if ($service =~ /^(\S+)=(\d+)$/) {
…		…
403	} else {	746	} else {
404	$port = (getservbyname $service, $proto)[2]	747	$port = (getservbyname $service, $proto)[2]
405	or Carp::croak "$service/$proto: service unknown";	748	or Carp::croak "$service/$proto: service unknown";
406	}	749	}
407		750
408	my @target = [$node, $port];
409
410	# resolve a records / provide sockaddr structures	751	# resolve a records / provide sockaddr structures
411	my $resolve = sub {	752	my $resolve = sub {
		753	my @target = @_;
		754
412	my @res;	755	my @res;
413	my $cv = AnyEvent->condvar (cb => sub {	756	my $cv = AE::cv {
414	$cb->(	757	$cb->(
415	map $_->[2],	758	map $_->[2],
416	sort {	759	sort {
417	$AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]}	760	$AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]}
418	or $a->[0] <=> $b->[0]	761	or $a->[0] <=> $b->[0]
419	}	762	}
420	@res	763	@res
421	)	764	)
422	});	765	};
423		766
424	$cv->begin;	767	$cv->begin;
425	for my $idx (0 .. $#target) {	768	for my $idx (0 .. $#target) {
426	my ($node, $port) = @{ $target[$idx] };	769	my ($node, $port) = @{ $target[$idx] };
427		770
428	if (my $noden = parse_address $node) {	771	if (my $noden = parse_address $node) {
		772	my $af = address_family $noden;
		773
429	if (4 == length $noden && $family != 6) {	774	if ($af == AF_INET && $family != 6) {
430	push @res, [$idx, "ipv4", [AF_INET, $type, $proton,	775	push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
431	pack_sockaddr $port, $noden]]	776	pack_sockaddr $port, $noden]]
432	}	777	}
433		778
434	if (16 == length $noden && $family != 4) {	779	if ($af == AF_INET6 && $family != 4) {
435	push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,	780	push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,
436	pack_sockaddr $port, $noden]]	781	pack_sockaddr $port, $noden]]
437	}	782	}
438	} else {	783	} else {
439	# ipv4	784	$node =~ y/A-Z/a-z/;
		785
		786	my $hosts = $HOSTS{$node};
		787
		788	# a records
440	if ($family != 6) {	789	if ($family != 6) {
441	$cv->begin;	790	$cv->begin;
442	a $node, sub {	791	AnyEvent::DNS::a $node, sub {
443	push @res, [$idx, "ipv4", [AF_INET, $type, $proton,	792	push @res, [$idx, "ipv4", [AF_INET , $type, $proton, pack_sockaddr $port, parse_ipv4 $_]]
444	pack_sockaddr $port, parse_ipv4 $_]]
445	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{$node}[0] };
446	$cv->end;	800	} $cv, @_;
447	};	801	};
448	}	802	}
449		803
450	# ipv6	804	# aaaa records
451	if ($family != 4) {	805	if ($family != 4) {
452	$cv->begin;	806	$cv->begin;
453	aaaa $node, sub {	807	AnyEvent::DNS::aaaa $node, sub {
454	push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,	808	push @res, [$idx, "ipv6", [AF_INET6, $type, $proton, pack_sockaddr $port, parse_ipv6 $_]]
455	pack_sockaddr $port, parse_ipv6 $_]]
456	for @_;	809	for @_;
		810
		811	_load_hosts_unless {
		812	push @res,
		813	map [$idx + 0.5, "ipv6", [AF_INET6, $type, $proton, pack_sockaddr $port, $_]],
		814	@{ $HOSTS{$node}[1] }
457	$cv->end;	815	} $cv, @_;
458	};	816	};
459	}	817	}
460	}	818	}
461	}	819	}
462	$cv->end;	820	$cv->end;
463	};	821	};
464		822
		823	$node = AnyEvent::Util::idn_to_ascii $node
		824	if $node =~ /[^\x00-\x7f]/;
		825
465	# try srv records, if applicable	826	# try srv records, if applicable
466	if ($node eq "localhost") {	827	if ($node eq "localhost") {
467	@target = (["127.0.0.1", $port], ["::1", $port]);	828	$resolve->(["127.0.0.1", $port], ["::1", $port]);
468	&$resolve;
469	} elsif (defined $service && !parse_address $node) {	829	} elsif (defined $service && !parse_address $node) {
470	srv $service, $proto, $node, sub {	830	AnyEvent::DNS::srv $service, $proto, $node, sub {
471	my (@srv) = @_;	831	my (@srv) = @_;
472		832
		833	if (@srv) {
		834	# the only srv record has "." ("" here) => abort
		835	$srv[0][2] ne "" \|\| $#srv
		836	or return $cb->();
		837
		838	# use srv records then
		839	$resolve->(
		840	map ["$_->[3].", $_->[2]],
		841	grep $_->[3] ne ".",
		842	@srv
		843	);
		844	} else {
473	# no srv records, continue traditionally	845	# no srv records, continue traditionally
		846	$resolve->([$node, $port]);
474	@srv	847	}
475	or return &$resolve;
476
477	# only srv record has "." => abort
478	$srv[0][2] ne "." \|\| $#srv
479	or return $cb->();
480
481	# use srv records then
482	@target = map ["$_->[3].", $_->[2]],
483	grep $_->[3] ne ".",
484	@srv;
485
486	&$resolve;
487	};	848	};
488	} else {	849	} else {
489	&$resolve;	850	# most common case
		851	$resolve->([$node, $port]);
490	}	852	}
491	}	853	}
492		854
493	=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]	855	=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]
494		856
495	This is a convenience function that creates a TCP socket and makes a 100%	857	This is a convenience function that creates a TCP socket and makes a
496	non-blocking connect to the given C<$host> (which can be a hostname or	858	100% non-blocking connect to the given C<$host> (which can be a DNS/IDN
497	a textual IP address, or the string C<unix/> for UNIX domain sockets)	859	hostname or a textual IP address, or the string C<unix/> for UNIX domain
498	and C<$service> (which can be a numeric port number or a service name,	860	sockets) and C<$service> (which can be a numeric port number or a service
499	or a C<servicename=portnumber> string, or the pathname to a UNIX domain	861	name, or a C<servicename=portnumber> string, or the pathname to a UNIX
500	socket).	862	domain socket).
501		863
502	If both C<$host> and C<$port> are names, then this function will use SRV	864	If both C<$host> and C<$port> are names, then this function will use SRV
503	records to locate the real target(s).	865	records to locate the real target(s).
504		866
505	In either case, it will create a list of target hosts (e.g. for multihomed	867	In either case, it will create a list of target hosts (e.g. for multihomed
506	hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to	868	hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to
507	each in turn.	869	each in turn.
508		870
509	If the connect is successful, then the C<$connect_cb> will be invoked with	871	After the connection is established, then the C<$connect_cb> will be
510	the socket file handle (in non-blocking mode) as first and the peer host	872	invoked with the socket file handle (in non-blocking mode) as first, and
511	(as a textual IP address) and peer port as second and third arguments,	873	the peer host (as a textual IP address) and peer port as second and third
512	respectively. The fourth argument is a code reference that you can call	874	arguments, respectively. The fourth argument is a code reference that you
513	if, for some reason, you don't like this connection, which will cause	875	can call if, for some reason, you don't like this connection, which will
514	C<tcp_connect> to try the next one (or call your callback without any	876	cause C<tcp_connect> to try the next one (or call your callback without
515	arguments if there are no more connections). In most cases, you can simply	877	any arguments if there are no more connections). In most cases, you can
516	ignore this argument.	878	simply ignore this argument.
517		879
518	$cb->($filehandle, $host, $port, $retry)	880	$cb->($filehandle, $host, $port, $retry)
519		881
520	If the connect is unsuccessful, then the C<$connect_cb> will be invoked	882	If the connect is unsuccessful, then the C<$connect_cb> will be invoked
521	without any arguments and C<$!> will be set appropriately (with C<ENXIO>	883	without any arguments and C<$!> will be set appropriately (with C<ENXIO>
522	indicating a DNS resolution failure).	884	indicating a DNS resolution failure).
523		885
		886	The callback will I<never> be invoked before C<tcp_connect> returns, even
		887	if C<tcp_connect> was able to connect immediately (e.g. on unix domain
		888	sockets).
		889
524	The file handle is perfect for being plugged into L<AnyEvent::Handle>, but	890	The file handle is perfect for being plugged into L<AnyEvent::Handle>, but
525	can be used as a normal perl file handle as well.	891	can be used as a normal perl file handle as well.
526		892
527	Unless called in void context, C<tcp_connect> returns a guard object that	893	Unless called in void context, C<tcp_connect> returns a guard object that
528	will automatically abort connecting when it gets destroyed (it does not do	894	will automatically cancel the connection attempt when it gets destroyed
		895	- in which case the callback will not be invoked. Destroying it does not
529	anything to the socket after the connect was successful).	896	do anything to the socket after the connect was successful - you cannot
		897	"uncall" a callback that has been invoked already.
530		898
531	Sometimes you need to "prepare" the socket before connecting, for example,	899	Sometimes you need to "prepare" the socket before connecting, for example,
532	to C<bind> it to some port, or you want a specific connect timeout that	900	to C<bind> it to some port, or you want a specific connect timeout that
533	is lower than your kernel's default timeout. In this case you can specify	901	is lower than your kernel's default timeout. In this case you can specify
534	a second callback, C<$prepare_cb>. It will be called with the file handle	902	a second callback, C<$prepare_cb>. It will be called with the file handle
…		…
548	lessen the impact of this windows bug, a default timeout of 30 seconds	916	lessen the impact of this windows bug, a default timeout of 30 seconds
549	will be imposed on windows. Cygwin is not affected.	917	will be imposed on windows. Cygwin is not affected.
550		918
551	Simple Example: connect to localhost on port 22.	919	Simple Example: connect to localhost on port 22.
552		920
553	tcp_connect localhost => 22, sub {	921	tcp_connect localhost => 22, sub {
554	my $fh = shift	922	my $fh = shift
555	or die "unable to connect: $!";	923	or die "unable to connect: $!";
556	# do something	924	# do something
557	};	925	};
558		926
559	Complex Example: connect to www.google.com on port 80 and make a simple	927	Complex Example: connect to www.google.com on port 80 and make a simple
560	GET request without much error handling. Also limit the connection timeout	928	GET request without much error handling. Also limit the connection timeout
561	to 15 seconds.	929	to 15 seconds.
562		930
…		…
566	or die "unable to connect: $!";	934	or die "unable to connect: $!";
567		935
568	my $handle; # avoid direct assignment so on_eof has it in scope.	936	my $handle; # avoid direct assignment so on_eof has it in scope.
569	$handle = new AnyEvent::Handle	937	$handle = new AnyEvent::Handle
570	fh => $fh,	938	fh => $fh,
		939	on_error => sub {
		940	AE::log error => $_[2];
		941	$_[0]->destroy;
		942	},
571	on_eof => sub {	943	on_eof => sub {
572	undef $handle; # keep it alive till eof	944	$handle->destroy; # destroy handle
573	warn "done.\n";	945	AE::log info => "Done.";
574	};	946	};
575		947
576	$handle->push_write ("GET / HTTP/1.0\015\012\015\012");	948	$handle->push_write ("GET / HTTP/1.0\015\012\015\012");
577		949
578	$handle->push_read_line ("\015\012\015\012", sub {	950	$handle->push_read (line => "\015\012\015\012", sub {
579	my ($handle, $line) = @_;	951	my ($handle, $line) = @_;
580		952
581	# print response header	953	# print response header
582	print "HEADER\n$line\n\nBODY\n";	954	print "HEADER\n$line\n\nBODY\n";
583		955
…		…
603	=cut	975	=cut
604		976
605	sub tcp_connect($$$;$) {	977	sub tcp_connect($$$;$) {
606	my ($host, $port, $connect, $prepare) = @_;	978	my ($host, $port, $connect, $prepare) = @_;
607		979
608	# see http://cr.yp.to/docs/connect.html for some background	980	# see http://cr.yp.to/docs/connect.html for some tricky aspects
609	# also http://advogato.org/article/672.html	981	# also http://advogato.org/article/672.html
610		982
611	my %state = ( fh => undef );	983	my %state = ( fh => undef );
612		984
613	# name/service to type/sockaddr resolution	985	# name/service to type/sockaddr resolution
614	resolve_sockaddr $host, $port, 0, 0, 0, sub {	986	resolve_sockaddr $host, $port, 0, 0, undef, sub {
615	my @target = @_;	987	my @target = @_;
616		988
617	$state{next} = sub {	989	$state{next} = sub {
618	return unless exists $state{fh};	990	return unless exists $state{fh};
619		991
		992	my $errno = $!;
620	my $target = shift @target	993	my $target = shift @target
621	or do {	994	or return AE::postpone {
		995	return unless exists $state{fh};
622	%state = ();	996	%state = ();
		997	$! = $errno;
623	return $connect->();	998	$connect->();
624	};	999	};
625		1000
626	my ($domain, $type, $proto, $sockaddr) = @$target;	1001	my ($domain, $type, $proto, $sockaddr) = @$target;
627		1002
628	# socket creation	1003	# socket creation
…		…
633		1008
634	my $timeout = $prepare && $prepare->($state{fh});	1009	my $timeout = $prepare && $prepare->($state{fh});
635		1010
636	$timeout \|\|= 30 if AnyEvent::WIN32;	1011	$timeout \|\|= 30 if AnyEvent::WIN32;
637		1012
638	$state{to} = AnyEvent->timer (after => $timeout, cb => sub {	1013	$state{to} = AE::timer $timeout, 0, sub {
639	$! = &Errno::ETIMEDOUT;	1014	$! = Errno::ETIMEDOUT;
640	$state{next}();	1015	$state{next}();
641	}) if $timeout;	1016	} if $timeout;
642		1017
643	# called when the connect was successful, which,	1018	# now connect
644	# in theory, could be the case immediately (but never is in practise)	1019	if (
645	my $connected = sub {	1020	(connect $state{fh}, $sockaddr)
646	delete $state{ww};	1021	\|\| ($! == Errno::EINPROGRESS # POSIX
647	delete $state{to};	1022	\|\| $! == Errno::EWOULDBLOCK
648		1023	# WSAEINPROGRESS intentionally not checked - it means something else entirely
		1024	\|\| $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt
		1025	\|\| $! == AnyEvent::Util::WSAEWOULDBLOCK)
		1026	) {
		1027	$state{ww} = AE::io $state{fh}, 1, sub {
649	# we are connected, or maybe there was an error	1028	# we are connected, or maybe there was an error
650	if (my $sin = getpeername $state{fh}) {	1029	if (my $sin = getpeername $state{fh}) {
651	my ($port, $host) = unpack_sockaddr $sin;	1030	my ($port, $host) = unpack_sockaddr $sin;
652		1031
		1032	delete $state{ww}; delete $state{to};
		1033
653	my $guard = guard {	1034	my $guard = guard { %state = () };
654	%state = ();
655	};
656		1035
657	$connect->($state{fh}, format_address $host, $port, sub {	1036	$connect->(delete $state{fh}, format_address $host, $port, sub {
658	$guard->cancel;	1037	$guard->cancel;
		1038	$state{next}();
		1039	});
		1040	} else {
		1041	if ($! == Errno::ENOTCONN) {
		1042	# dummy read to fetch real error code if !cygwin
		1043	sysread $state{fh}, my $buf, 1;
		1044
		1045	# cygwin 1.5 continously reports "ready' but never delivers
		1046	# an error with getpeername or sysread.
		1047	# cygwin 1.7 only reports readyness once, but is otherwise
		1048	# the same, which is actually more broken.
		1049	# Work around both by using unportable SO_ERROR for cygwin.
		1050	$! = (unpack "l", getsockopt $state{fh}, Socket::SOL_SOCKET(), Socket::SO_ERROR()) \|\| Errno::EAGAIN
		1051	if AnyEvent::CYGWIN && $! == Errno::EAGAIN;
		1052	}
		1053
		1054	return if $! == Errno::EAGAIN; # skip spurious wake-ups
		1055
		1056	delete $state{ww}; delete $state{to};
		1057
659	$state{next}();	1058	$state{next}();
660	});	1059	}
661	} else {
662	# dummy read to fetch real error code
663	sysread $state{fh}, my $buf, 1 if $! == &Errno::ENOTCONN;
664	$state{next}();
665	}	1060	};
666	};
667
668	# now connect
669	if (connect $state{fh}, $sockaddr) {
670	$connected->();
671	} elsif ($! == &Errno::EINPROGRESS # POSIX
672	\|\| $! == &Errno::EWOULDBLOCK
673	# WSAEINPROGRESS intentionally not checked - it means something else entirely
674	\|\| $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt
675	\|\| $! == AnyEvent::Util::WSAEWOULDBLOCK) {
676	$state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $connected);
677	} else {	1061	} else {
678	$state{next}();	1062	$state{next}();
679	}	1063	}
680	};	1064	};
681		1065
682	$! = &Errno::ENXIO;	1066	$! = Errno::ENXIO;
683	$state{next}();	1067	$state{next}();
684	};	1068	};
685		1069
686	defined wantarray && guard { %state = () }	1070	defined wantarray && guard { %state = () }
687	}	1071	}
688		1072
689	=item $guard = tcp_server $host, $service, $accept_cb[, $prepare_cb]	1073	=item $guard = tcp_server $host, $service, $accept_cb[, $prepare_cb]
690		1074
691	Create and bind a stream socket to the given host, and port, set the	1075	Create and bind a stream socket to the given host address and port, set
692	SO_REUSEADDR flag (if applicable) and call C<listen>. Unlike the name	1076	the SO_REUSEADDR flag (if applicable) and call C<listen>. Unlike the name
693	implies, this function can also bind on UNIX domain sockets.	1077	implies, this function can also bind on UNIX domain sockets.
694		1078
695	For internet sockets, C<$host> must be an IPv4 or IPv6 address (or	1079	For internet sockets, C<$host> must be an IPv4 or IPv6 address (or
696	C<undef>, in which case it binds either to C<0> or to C<::>, depending on	1080	C<undef>, in which case it binds either to C<0> or to C<::>, depending
697	whether IPv4 or IPv6 is the preferred protocol).	1081	on whether IPv4 or IPv6 is the preferred protocol, and maybe to both in
		1082	future versions, as applicable).
698		1083
699	To bind to the IPv4 wildcard address, use C<0>, to bind to the IPv6	1084	To bind to the IPv4 wildcard address, use C<0>, to bind to the IPv6
700	wildcard address, use C<::>.	1085	wildcard address, use C<::>.
701		1086
702	The port is specified by C<$service>, which must be either a service name or	1087	The port is specified by C<$service>, which must be either a service name
703	a numeric port number (or C<0> or C<undef>, in which case an ephemeral	1088	or a numeric port number (or C<0> or C<undef>, in which case an ephemeral
704	port will be used).	1089	port will be used).
705		1090
706	For UNIX domain sockets, C<$host> must be C<unix/> and C<$service> must be	1091	For UNIX domain sockets, C<$host> must be C<unix/> and C<$service> must be
707	the absolute pathname of the socket. This function will try to C<unlink>	1092	the absolute pathname of the socket. This function will try to C<unlink>
708	the socket before it tries to bind to it. See SECURITY CONSIDERATIONS,	1093	the socket before it tries to bind to it, and will try to unlink it after
709	below.	1094	it stops using it. See SECURITY CONSIDERATIONS, below.
710		1095
711	For each new connection that could be C<accept>ed, call the C<<	1096	For each new connection that could be C<accept>ed, call the C<<
712	$accept_cb->($fh, $host, $port) >> with the file handle (in non-blocking	1097	$accept_cb->($fh, $host, $port) >> with the file handle (in non-blocking
713	mode) as first and the peer host and port as second and third arguments	1098	mode) as first, and the peer host and port as second and third arguments
714	(see C<tcp_connect> for details).	1099	(see C<tcp_connect> for details).
715		1100
716	Croaks on any errors it can detect before the listen.	1101	Croaks on any errors it can detect before the listen.
717		1102
718	If called in non-void context, then this function returns a guard object	1103	If called in non-void context, then this function returns a guard object
719	whose lifetime it tied to the TCP server: If the object gets destroyed,	1104	whose lifetime it tied to the TCP server: If the object gets destroyed,
720	the server will be stopped (but existing accepted connections will	1105	the server will be stopped (but existing accepted connections will
721	continue).	1106	not be affected).
		1107
		1108	Regardless, when the function returns to the caller, the socket is bound
		1109	and in listening state.
722		1110
723	If you need more control over the listening socket, you can provide a	1111	If you need more control over the listening socket, you can provide a
724	C<< $prepare_cb->($fh, $host, $port) >>, which is called just before the	1112	C<< $prepare_cb->($fh, $host, $port) >>, which is called just before the
725	C<listen ()> call, with the listen file handle as first argument, and IP	1113	C<listen ()> call, with the listen file handle as first argument, and IP
726	address and port number of the local socket endpoint as second and third	1114	address and port number of the local socket endpoint as second and third
727	arguments.	1115	arguments.
728		1116
729	It should return the length of the listen queue (or C<0> for the default).	1117	It should return the length of the listen queue (or C<0> for the default).
730		1118
		1119	Note to IPv6 users: RFC-compliant behaviour for IPv6 sockets listening on
		1120	C<::> is to bind to both IPv6 and IPv4 addresses by default on dual-stack
		1121	hosts. Unfortunately, only GNU/Linux seems to implement this properly, so
		1122	if you want both IPv4 and IPv6 listening sockets you should create the
		1123	IPv6 socket first and then attempt to bind on the IPv4 socket, but ignore
		1124	any C<EADDRINUSE> errors.
		1125
731	Example: bind on some TCP port on the local machine and tell each client	1126	Example: bind on some TCP port on the local machine and tell each client
732	to go away.	1127	to go away.
733		1128
734	tcp_server undef, undef, sub {	1129	tcp_server undef, undef, sub {
735	my ($fh, $host, $port) = @_;	1130	my ($fh, $host, $port) = @_;
736		1131
737	syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";	1132	syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";
738	}, sub {	1133	}, sub {
739	my ($fh, $thishost, $thisport) = @_;	1134	my ($fh, $thishost, $thisport) = @_;
740	warn "bound to $thishost, port $thisport\n";	1135	AE::log info => "Bound to $thishost, port $thisport.";
		1136	};
		1137
		1138	Example: bind a server on a unix domain socket.
		1139
		1140	tcp_server "unix/", "/tmp/mydir/mysocket", sub {
		1141	my ($fh) = @_;
741	};	1142	};
742		1143
743	=cut	1144	=cut
744		1145
745	sub tcp_server($$$;$) {	1146	sub tcp_server($$$;$) {
…		…
764	or Carp::croak "tcp_server/socket: $!";	1165	or Carp::croak "tcp_server/socket: $!";
765		1166
766	if ($af == AF_INET \|\| $af == AF_INET6) {	1167	if ($af == AF_INET \|\| $af == AF_INET6) {
767	setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1	1168	setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1
768	or Carp::croak "tcp_server/so_reuseaddr: $!"	1169	or Carp::croak "tcp_server/so_reuseaddr: $!"
769	unless !AnyEvent::WIN32; # work around windows bug	1170	unless AnyEvent::WIN32; # work around windows bug
770		1171
771	unless ($service =~ /^\d*$/) {	1172	unless ($service =~ /^\d*$/) {
772	$service = (getservbyname $service, "tcp")[2]	1173	$service = (getservbyname $service, "tcp")[2]
773	or Carp::croak "$service: service unknown"	1174	or Carp::croak "$service: service unknown"
774	}	1175	}
…		…
777	}	1178	}
778		1179
779	bind $state{fh}, pack_sockaddr $service, $ipn	1180	bind $state{fh}, pack_sockaddr $service, $ipn
780	or Carp::croak "bind: $!";	1181	or Carp::croak "bind: $!";
781		1182
		1183	if ($af == AF_UNIX) {
		1184	my $fh = $state{fh};
		1185	my $ino = (stat $fh)[1];
		1186	$state{unlink} = guard {
		1187	# this is racy, but is not designed to be foolproof, just best-effort
		1188	unlink $service
		1189	if $ino == (stat $fh)[1];
		1190	};
		1191	}
		1192
782	fh_nonblocking $state{fh}, 1;	1193	fh_nonblocking $state{fh}, 1;
783		1194
784	my $len;	1195	my $len;
785		1196
786	if ($prepare) {	1197	if ($prepare) {
…		…
791	$len \|\|= 128;	1202	$len \|\|= 128;
792		1203
793	listen $state{fh}, $len	1204	listen $state{fh}, $len
794	or Carp::croak "listen: $!";	1205	or Carp::croak "listen: $!";
795		1206
796	$state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {	1207	$state{aw} = AE::io $state{fh}, 0, sub {
797	# this closure keeps $state alive	1208	# this closure keeps $state alive
798	while (my $peer = accept my $fh, $state{fh}) {	1209	while ($state{fh} && (my $peer = accept my $fh, $state{fh})) {
799	fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not	1210	fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not
		1211
800	my ($service, $host) = unpack_sockaddr $peer;	1212	my ($service, $host) = unpack_sockaddr $peer;
801	$accept->($fh, format_address $host, $service);	1213	$accept->($fh, format_address $host, $service);
802	}	1214	}
803	});	1215	};
804		1216
805	defined wantarray	1217	defined wantarray
806	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency	1218	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency
807	: ()	1219	: ()
808	}	1220	}
809		1221
810	1;	1222	=item tcp_nodelay $fh, $enable
		1223
		1224	Enables (or disables) the C<TCP_NODELAY> socket option (also known as
		1225	Nagle's algorithm). Returns false on error, true otherwise.
		1226
		1227	=cut
		1228
		1229	sub tcp_nodelay($$) {
		1230	my $onoff = int ! ! $_[1];
		1231
		1232	setsockopt $_[0], Socket::IPPROTO_TCP (), Socket::TCP_NODELAY (), $onoff
		1233	}
		1234
		1235	=item tcp_congestion $fh, $algorithm
		1236
		1237	Sets the tcp congestion avoidance algorithm (via the C<TCP_CONGESTION>
		1238	socket option). The default is OS-specific, but is usually
		1239	C<reno>. Typical other available choices include C<cubic>, C<lp>, C<bic>,
		1240	C<highspeed>, C<htcp>, C<hybla>, C<illinois>, C<scalable>, C<vegas>,
		1241	C<veno>, C<westwood> and C<yeah>.
		1242
		1243	=cut
		1244
		1245	sub tcp_congestion($$) {
		1246	defined TCP_CONGESTION
		1247	? setsockopt $_[0], Socket::IPPROTO_TCP (), TCP_CONGESTION, "$_[1]"
		1248	: undef
		1249	}
811		1250
812	=back	1251	=back
813		1252
		1253	=head1 SECURITY CONSIDERATIONS
		1254
		1255	This module is quite powerful, with with power comes the ability to abuse
		1256	as well: If you accept "hostnames" and ports from untrusted sources,
		1257	then note that this can be abused to delete files (host=C<unix/>). This
		1258	is not really a problem with this module, however, as blindly accepting
		1259	any address and protocol and trying to bind a server or connect to it is
		1260	harmful in general.
		1261
814	=head1 AUTHOR	1262	=head1 AUTHOR
815		1263
816	Marc Lehmann <schmorp@schmorp.de>	1264	Marc Lehmann <schmorp@schmorp.de>
817	http://home.schmorp.de/	1265	http://anyevent.schmorp.de
818		1266
819	=cut	1267	=cut
820		1268
		1269	1
		1270

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents): Revision 1.36 by root, Wed May 28 21:29:03 2008 UTC vs. Revision 1.152 by root, Mon Apr 9 02:25:48 2012 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.36 by root, Wed May 28 21:29:03 2008 UTC vs.
Revision 1.152 by root, Mon Apr 9 02:25:48 2012 UTC