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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.29 by root, Mon May 26 06:03:20 2008 UTC vs.
Revision 1.130 by root, Fri Jan 14 17:43:11 2011 UTC

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

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents): Revision 1.29 by root, Mon May 26 06:03:20 2008 UTC vs. Revision 1.130 by root, Fri Jan 14 17:43:11 2011 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.29 by root, Mon May 26 06:03:20 2008 UTC vs.
Revision 1.130 by root, Fri Jan 14 17:43:11 2011 UTC