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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.32 by root, Mon May 26 17:45:05 2008 UTC vs.
Revision 1.114 by root, Fri Aug 21 11:59:25 2009 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 ();	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);
…		…
128		148
129	# and done	149	# and done
130	pack "n*", map hex, @h, @t	150	pack "n*", map hex, @h, @t
131	}	151	}
132		152
133	=item $ipn = parse_ip $text	153	sub parse_unix($) {
		154	$_[0] eq "unix/"
		155	? pack "S", AF_UNIX
		156	: undef
134		157
		158	}
		159
		160	=item $ipn = parse_address $ip
		161
135	Combines C<parse_ipv4> and C<parse_ipv6> in one function.	162	Combines C<parse_ipv4> and C<parse_ipv6> in one function. The address
		163	here refers to the host address (not socket address) in network form
		164	(binary).
136		165
137	=cut	166	If the C<$text> is C<unix/>, then this function returns a special token
		167	recognised by the other functions in this module to mean "UNIX domain
		168	socket".
138		169
		170	If the C<$text> to parse is a mapped IPv4 in IPv6 address (:ffff::<ipv4>),
		171	then it will be treated as an IPv4 address. If you don't want that, you
		172	have to call C<parse_ipv4> and/or C<parse_ipv6> manually.
		173
		174	=item $ipn = AnyEvent::Socket::aton $ip
		175
		176	Same as C<parse_address>, but not exported (think C<Socket::inet_aton> but
		177	I<without> name resolution).
		178
		179	=cut
		180
139	sub parse_ip($) {	181	sub parse_address($) {
140	&parse_ipv4 \|\| &parse_ipv6	182	for (&parse_ipv6) {
		183	if ($_) {
		184	s/^\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff//;
		185	return $_;
		186	} else {
		187	return &parse_ipv4 \|\| &parse_unix
		188	}
		189	}
141	}	190	}
142		191
		192	*aton = \&parse_address;
		193
		194	=item ($name, $aliases, $proto) = getprotobyname $name
		195
		196	Works like the builtin function of the same name, except it tries hard to
		197	work even on broken platforms (well, that's windows), where getprotobyname
		198	is traditionally very unreliable.
		199
		200	=cut
		201
		202	# microsoft can't even get getprotobyname working (the etc/protocols file
		203	# gets lost fairly often on windows), so we have to hardcode some common
		204	# protocol numbers ourselves.
		205	our %PROTO_BYNAME;
		206
		207	$PROTO_BYNAME{tcp} = Socket::IPPROTO_TCP () if defined &Socket::IPPROTO_TCP;
		208	$PROTO_BYNAME{udp} = Socket::IPPROTO_UDP () if defined &Socket::IPPROTO_UDP;
		209	$PROTO_BYNAME{icmp} = Socket::IPPROTO_ICMP() if defined &Socket::IPPROTO_ICMP;
		210
		211	sub getprotobyname($) {
		212	my $name = lc shift;
		213
		214	defined (my $proton = $PROTO_BYNAME{$name} \|\| (getprotobyname $name)[2])
		215	or return;
		216
		217	($name, uc $name, $proton)
		218	}
		219
		220	=item ($host, $service) = parse_hostport $string[, $default_service]
		221
		222	Splitting a string of the form C<hostname:port> is a common
		223	problem. Unfortunately, just splitting on the colon makes it hard to
		224	specify IPv6 addresses and doesn't support the less common but well
		225	standardised C<[ip literal]> syntax.
		226
		227	This function tries to do this job in a better way, it supports the
		228	following formats, where C<port> can be a numerical port number of a
		229	service name, or a C<name=port> string, and the C< port> and C<:port>
		230	parts are optional. Also, everywhere where an IP address is supported
		231	a hostname or unix domain socket address is also supported (see
		232	C<parse_unix>).
		233
		234	hostname:port e.g. "www.linux.org", "www.x.de:443", "www.x.de:https=443"
		235	ipv4:port e.g. "198.182.196.56", "127.1:22"
		236	ipv6 e.g. "::1", "affe::1"
		237	[ipv4or6]:port e.g. "[::1]", "[10.0.1]:80"
		238	[ipv4or6] port e.g. "[127.0.0.1]", "[www.x.org] 17"
		239	ipv4or6 port e.g. "::1 443", "10.0.0.1 smtp"
		240
		241	It also supports defaulting the service name in a simple way by using
		242	C<$default_service> if no service was detected. If neither a service was
		243	detected nor a default was specified, then this function returns the
		244	empty list. The same happens when a parse error was detected, such as a
		245	hostname with a colon in it (the function is rather conservative, though).
		246
		247	Example:
		248
		249	print join ",", parse_hostport "localhost:443";
		250	# => "localhost,443"
		251
		252	print join ",", parse_hostport "localhost", "https";
		253	# => "localhost,https"
		254
		255	print join ",", parse_hostport "[::1]";
		256	# => "," (empty list)
		257
		258	=cut
		259
		260	sub parse_hostport($;$) {
		261	my ($host, $port);
		262
		263	for ("$_[0]") { # work on a copy, just in case, and also reset pos
		264
		265	# parse host, special cases: "ipv6" or "ipv6 port"
		266	unless (
		267	($host) = /^\s* ([0-9a-fA-F:]:[0-9a-fA-F:]:[0-9a-fA-F\.:]*)/xgc
		268	and parse_ipv6 $host
		269	) {
		270	/^\s*/xgc;
		271
		272	if (/^ \[ ([^\[\]]+) \]/xgc) {
		273	$host = $1;
		274	} elsif (/^ ([^\[\]:\ ]+) /xgc) {
		275	$host = $1;
		276	} else {
		277	return;
		278	}
		279	}
		280
		281	# parse port
		282	if (/\G (?:\s+\|:) ([^:[:space:]]+) \s*$/xgc) {
		283	$port = $1;
		284	} elsif (/\G\s*$/gc && length $_[1]) {
		285	$port = $_[1];
		286	} else {
		287	return;
		288	}
		289	}
		290
		291	# hostnames must not contain :'s
		292	return if $host =~ /:/ && !parse_ipv6 $host;
		293
		294	($host, $port)
		295	}
		296
		297	=item $string = format_hostport $host, $port
		298
		299	Takes a host (in textual form) and a port and formats in unambigiously in
		300	a way that C<parse_hostport> can parse it again. C<$port> can be C<undef>.
		301
		302	=cut
		303
		304	sub format_hostport($;$) {
		305	my ($host, $port) = @_;
		306
		307	$port = ":$port" if length $port;
		308	$host = "[$host]" if $host =~ /:/;
		309
		310	"$host$port"
		311	}
		312
		313	=item $sa_family = address_family $ipn
		314
		315	Returns the address family/protocol-family (AF_xxx/PF_xxx, in one value :)
		316	of the given host address in network format.
		317
		318	=cut
		319
		320	sub address_family($) {
		321	4 == length $_[0]
		322	? AF_INET
		323	: 16 == length $_[0]
		324	? AF_INET6
		325	: unpack "S", $_[0]
		326	}
		327
143	=item $text = format_ip $ipn	328	=item $text = format_ipv4 $ipn
144		329
145	Takes either an IPv4 address (4 octets) or and IPv6 address (16 octets)	330	Expects a four octet string representing a binary IPv4 address and returns
		331	its textual format. Rarely used, see C<format_address> for a nicer
		332	interface.
		333
		334	=item $text = format_ipv6 $ipn
		335
		336	Expects a sixteen octet string representing a binary IPv6 address and
		337	returns its textual format. Rarely used, see C<format_address> for a
		338	nicer interface.
		339
		340	=item $text = format_address $ipn
		341
		342	Covnvert a host address in network format (e.g. 4 octets for IPv4 or 16
146	and converts it into textual form.	343	octets for IPv6) and convert it into textual form.
		344
		345	Returns C<unix/> for UNIX domain sockets.
147		346
148	This function works similarly to C<inet_ntop AF_INET \|\| AF_INET6, ...>,	347	This function works similarly to C<inet_ntop AF_INET \|\| AF_INET6, ...>,
149	except it automatically detects the address type.	348	except it automatically detects the address type.
150		349
151	=cut	350	Returns C<undef> if it cannot detect the type.
152		351
153	sub format_ip;	352	If the C<$ipn> is a mapped IPv4 in IPv6 address (:ffff::<ipv4>), then just
		353	the contained IPv4 address will be returned. If you do not want that, you
		354	have to call C<format_ipv6> manually.
		355
		356	=item $text = AnyEvent::Socket::ntoa $ipn
		357
		358	Same as format_address, but not exported (think C<inet_ntoa>).
		359
		360	=cut
		361
154	sub format_ip($) {	362	sub format_ipv4($) {
155	if (4 == length $_[0]) {
156	return join ".", unpack "C4", $_[0]	363	join ".", unpack "C4", $_[0]
157	} elsif (16 == length $_[0]) {	364	}
		365
		366	sub format_ipv6($) {
		367	if (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0 eq $_[0]) {
		368	return "::";
		369	} elsif (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1 eq $_[0]) {
		370	return "::1";
		371	} elsif (v0.0.0.0.0.0.0.0.0.0.0.0 eq substr $_[0], 0, 12) {
		372	# v4compatible
		373	return "::" . format_ipv4 substr $_[0], 12;
158	if (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) {	374	} elsif (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) {
159	# v4mapped	375	# v4mapped
160	return "::ffff:" . format_ip substr $_[0], 12;	376	return "::ffff:" . format_ipv4 substr $_[0], 12;
		377	} elsif (v0.0.0.0.0.0.0.0.255.255.0.0 eq substr $_[0], 0, 12) {
		378	# v4translated
		379	return "::ffff:0:" . format_ipv4 substr $_[0], 12;
161	} else {	380	} else {
162	my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];	381	my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];
163		382
		383	# this is rather sucky, I admit
164	$ip =~ s/^0:(?:0:)*(0$)?/::/	384	$ip =~ s/^0:(?:0:)*(0$)?/::/
165	or $ip =~ s/(:0)+$/::/	385	or $ip =~ s/(:0){7}$/::/ or $ip =~ s/(:0){7}/:/
166	or $ip =~ s/(:0)+/:/;	386	or $ip =~ s/(:0){6}$/::/ or $ip =~ s/(:0){6}/:/
		387	or $ip =~ s/(:0){5}$/::/ or $ip =~ s/(:0){5}/:/
		388	or $ip =~ s/(:0){4}$/::/ or $ip =~ s/(:0){4}/:/
		389	or $ip =~ s/(:0){3}$/::/ or $ip =~ s/(:0){3}/:/
		390	or $ip =~ s/(:0){2}$/::/ or $ip =~ s/(:0){2}/:/
		391	or $ip =~ s/(:0){1}$/::/ or $ip =~ s/(:0){1}/:/;
167	return $ip	392	return $ip
168	}	393	}
		394	}
		395
		396	sub format_address($) {
		397	my $af = address_family $_[0];
		398	if ($af == AF_INET) {
		399	return &format_ipv4;
		400	} elsif ($af == AF_INET6) {
		401	return (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12)
		402	? format_ipv4 substr $_[0], 12
		403	: &format_ipv6;
		404	} elsif ($af == AF_UNIX) {
		405	return "unix/"
169	} else {	406	} else {
170	return undef	407	return undef
171	}	408	}
172	}	409	}
		410
		411	*ntoa = \&format_address;
173		412
174	=item inet_aton $name_or_address, $cb->(@addresses)	413	=item inet_aton $name_or_address, $cb->(@addresses)
175		414
176	Works similarly to its Socket counterpart, except that it uses a	415	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	416	callback. Also, if a host has only an IPv6 address, this might be passed
178	to the callback instead (use the length to detect this - 4 for IPv4, 16	417	to the callback instead (use the length to detect this - 4 for IPv4, 16
179	for IPv6).	418	for IPv6).
180		419
181	Unlike the L<Socket> function of the same name, you can get multiple IPv4	420	Unlike the L<Socket> function of the same name, you can get multiple IPv4
182	and IPv6 addresses as result.	421	and IPv6 addresses as result (and maybe even other adrdess types).
183		422
184	=cut	423	=cut
185		424
186	sub inet_aton {	425	sub inet_aton {
187	my ($name, $cb) = @_;	426	my ($name, $cb) = @_;
…		…
205	}	444	}
206	});	445	});
207	}	446	}
208	}	447	}
209		448
		449	BEGIN {
		450	*sockaddr_family = $Socket::VERSION >= 1.75
		451	? \&Socket::sockaddr_family
		452	: # for 5.6.x, we need to do something much more horrible
		453	(Socket::pack_sockaddr_in 0x5555, "\x55\x55\x55\x55"
		454	\| eval { Socket::pack_sockaddr_un "U" }) =~ /^\x00/
		455	? sub { unpack "xC", $_[0] }
		456	: sub { unpack "S" , $_[0] };
		457	}
		458
210	# check for broken platforms with extra field in sockaddr structure	459	# check for broken platforms with extra field in sockaddr structure
211	# kind of a rfc vs. bsd issue, as usual (ok, normally it's a	460	# kind of a rfc vs. bsd issue, as usual (ok, normally it's a
212	# unix vs. bsd issue, a iso C vs. bsd issue or simply a	461	# unix vs. bsd issue, a iso C vs. bsd issue or simply a
213	# correctness vs. bsd issue.	462	# correctness vs. bsd issue.)
214	my $pack_family = 0x55 == Socket::sockaddr_family "\x55\x55"	463	my $pack_family = 0x55 == sockaddr_family ("\x55\x55")
215	? "xC" : "S";	464	? "xC" : "S";
216		465
217	=item $sa = AnyEvent::Socket::pack_sockaddr $port, $host	466	=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host
218		467
219	Pack the given port/host combination into a binary sockaddr structure. Handles	468	Pack the given port/host combination into a binary sockaddr
220	both IPv4 and IPv6 host addresses.	469	structure. Handles both IPv4 and IPv6 host addresses, as well as UNIX
		470	domain sockets (C<$host> == C<unix/> and C<$service> == absolute
		471	pathname).
221		472
222	=cut	473	=cut
223		474
224	sub pack_sockaddr($$) {	475	sub pack_sockaddr($$) {
225	if (4 == length $_[1]) {	476	my $af = address_family $_[1];
		477
		478	if ($af == AF_INET) {
226	Socket::pack_sockaddr_in $_[0], $_[1]	479	Socket::pack_sockaddr_in $_[0], $_[1]
227	} elsif (16 == length $_[1]) {	480	} elsif ($af == AF_INET6) {
228	pack "$pack_family nL a16 L",	481	pack "$pack_family nL a16 L",
229	AF_INET6,	482	AF_INET6,
230	$_[0], # port	483	$_[0], # port
231	0, # flowinfo	484	0, # flowinfo
232	$_[1], # addr	485	$_[1], # addr
233	0 # scope id	486	0 # scope id
		487	} elsif ($af == AF_UNIX) {
		488	Socket::pack_sockaddr_un $_[0]
234	} else {	489	} else {
235	Carp::croak "pack_sockaddr: invalid host";	490	Carp::croak "pack_sockaddr: invalid host";
236	}	491	}
237	}	492	}
238		493
239	=item ($port, $host) = AnyEvent::Socket::unpack_sockaddr $sa	494	=item ($service, $host) = AnyEvent::Socket::unpack_sockaddr $sa
240		495
241	Unpack the given binary sockaddr structure (as used by bind, getpeername	496	Unpack the given binary sockaddr structure (as used by bind, getpeername
242	etc.) into a C<$port, $host> combination.	497	etc.) into a C<$service, $host> combination.
243		498
244	Handles both IPv4 and IPv6 sockaddr structures.	499	For IPv4 and IPv6, C<$service> is the port number and C<$host> the host
		500	address in network format (binary).
245		501
		502	For UNIX domain sockets, C<$service> is the absolute pathname and C<$host>
		503	is a special token that is understood by the other functions in this
		504	module (C<format_address> converts it to C<unix/>).
		505
246	=cut	506	=cut
		507
		508	# perl contains a bug (imho) where it requires that the kernel always returns
		509	# sockaddr_un structures of maximum length (which is not, AFAICS, required
		510	# by any standard). try to 0-pad structures for the benefit of those platforms.
		511
		512	my $sa_un_zero = eval { Socket::pack_sockaddr_un "" }; $sa_un_zero ^= $sa_un_zero;
247		513
248	sub unpack_sockaddr($) {	514	sub unpack_sockaddr($) {
249	my $af = Socket::sockaddr_family $_[0];	515	my $af = sockaddr_family $_[0];
250		516
251	if ($af == AF_INET) {	517	if ($af == AF_INET) {
252	Socket::unpack_sockaddr_in $_[0]	518	Socket::unpack_sockaddr_in $_[0]
253	} elsif ($af == AF_INET6) {	519	} elsif ($af == AF_INET6) {
254	unpack "x2 n x4 a16", $_[0]	520	unpack "x2 n x4 a16", $_[0]
		521	} elsif ($af == AF_UNIX) {
		522	((Socket::unpack_sockaddr_un $_[0] ^ $sa_un_zero), pack "S", AF_UNIX)
255	} else {	523	} else {
256	Carp::croak "unpack_sockaddr: unsupported protocol family $af";	524	Carp::croak "unpack_sockaddr: unsupported protocol family $af";
257	}	525	}
258	}	526	}
259		527
260	sub _tcp_port($) {	528	=item resolve_sockaddr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...)
261	$_[0] =~ /^(\d)$/ and return $11;
262		529
263	(getservbyname $_[0], "tcp")[2]	530	Tries to resolve the given nodename and service name into protocol families
		531	and sockaddr structures usable to connect to this node and service in a
		532	protocol-independent way. It works remotely similar to the getaddrinfo
		533	posix function.
		534
		535	For internet addresses, C<$node> is either an IPv4 or IPv6 address or an
		536	internet hostname, and C<$service> is either a service name (port name
		537	from F</etc/services>) or a numerical port number. If both C<$node> and
		538	C<$service> are names, then SRV records will be consulted to find the real
		539	service, otherwise they will be used as-is. If you know that the service
		540	name is not in your services database, then you can specify the service in
		541	the format C<name=port> (e.g. C<http=80>).
		542
		543	For UNIX domain sockets, C<$node> must be the string C<unix/> and
		544	C<$service> must be the absolute pathname of the socket. In this case,
		545	C<$proto> will be ignored.
		546
		547	C<$proto> must be a protocol name, currently C<tcp>, C<udp> or
		548	C<sctp>. The default is currently C<tcp>, but in the future, this function
		549	might try to use other protocols such as C<sctp>, depending on the socket
		550	type and any SRV records it might find.
		551
		552	C<$family> must be either C<0> (meaning any protocol is OK), C<4> (use
		553	only IPv4) or C<6> (use only IPv6). The default is influenced by
		554	C<$ENV{PERL_ANYEVENT_PROTOCOLS}>.
		555
		556	C<$type> must be C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_SEQPACKET> (or
		557	C<undef> in which case it gets automatically chosen to be C<SOCK_STREAM>
		558	unless C<$proto> is C<udp>).
		559
		560	The callback will receive zero or more array references that contain
		561	C<$family, $type, $proto> for use in C<socket> and a binary
		562	C<$sockaddr> for use in C<connect> (or C<bind>).
		563
		564	The application should try these in the order given.
		565
		566	Example:
		567
		568	resolve_sockaddr "google.com", "http", 0, undef, undef, sub { ... };
		569
		570	=cut
		571
		572	sub resolve_sockaddr($$$$$$) {
		573	my ($node, $service, $proto, $family, $type, $cb) = @_;
		574
		575	if ($node eq "unix/") {
		576	return $cb->() if $family \|\| $service !~ /^\//; # no can do
		577
		578	return $cb->([AF_UNIX, defined $type ? $type : SOCK_STREAM, 0, Socket::pack_sockaddr_un $service]);
		579	}
		580
		581	unless (AF_INET6) {
		582	$family != 6
		583	or return $cb->();
		584
		585	$family = 4;
		586	}
		587
		588	$cb->() if $family == 4 && !$AnyEvent::PROTOCOL{ipv4};
		589	$cb->() if $family == 6 && !$AnyEvent::PROTOCOL{ipv6};
		590
		591	$family \|\|= 4 unless $AnyEvent::PROTOCOL{ipv6};
		592	$family \|\|= 6 unless $AnyEvent::PROTOCOL{ipv4};
		593
		594	$proto \|\|= "tcp";
		595	$type \|\|= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;
		596
		597	my $proton = getprotobyname $proto
264	or Carp::croak "$_[0]: service unknown"	598	or Carp::croak "$proto: protocol unknown";
		599
		600	my $port;
		601
		602	if ($service =~ /^(\S+)=(\d+)$/) {
		603	($service, $port) = ($1, $2);
		604	} elsif ($service =~ /^\d+$/) {
		605	($service, $port) = (undef, $service);
		606	} else {
		607	$port = (getservbyname $service, $proto)[2]
		608	or Carp::croak "$service/$proto: service unknown";
		609	}
		610
		611	my @target = [$node, $port];
		612
		613	# resolve a records / provide sockaddr structures
		614	my $resolve = sub {
		615	my @res;
		616	my $cv = AE::cv {
		617	$cb->(
		618	map $_->[2],
		619	sort {
		620	$AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]}
		621	or $a->[0] <=> $b->[0]
		622	}
		623	@res
		624	)
		625	};
		626
		627	$cv->begin;
		628	for my $idx (0 .. $#target) {
		629	my ($node, $port) = @{ $target[$idx] };
		630
		631	if (my $noden = parse_address $node) {
		632	my $af = address_family $noden;
		633
		634	if ($af == AF_INET && $family != 6) {
		635	push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
		636	pack_sockaddr $port, $noden]]
		637	}
		638
		639	if ($af == AF_INET6 && $family != 4) {
		640	push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,
		641	pack_sockaddr $port, $noden]]
		642	}
		643	} else {
		644	# ipv4
		645	if ($family != 6) {
		646	$cv->begin;
		647	AnyEvent::DNS::a $node, sub {
		648	push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
		649	pack_sockaddr $port, parse_ipv4 $_]]
		650	for @_;
		651	$cv->end;
		652	};
		653	}
		654
		655	# ipv6
		656	if ($family != 4) {
		657	$cv->begin;
		658	AnyEvent::DNS::aaaa $node, sub {
		659	push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,
		660	pack_sockaddr $port, parse_ipv6 $_]]
		661	for @_;
		662	$cv->end;
		663	};
		664	}
		665	}
		666	}
		667	$cv->end;
		668	};
		669
		670	# try srv records, if applicable
		671	if ($node eq "localhost") {
		672	@target = (["127.0.0.1", $port], ["::1", $port]);
		673	&$resolve;
		674	} elsif (defined $service && !parse_address $node) {
		675	AnyEvent::DNS::srv $service, $proto, $node, sub {
		676	my (@srv) = @_;
		677
		678	# no srv records, continue traditionally
		679	@srv
		680	or return &$resolve;
		681
		682	# the only srv record has "." ("" here) => abort
		683	$srv[0][2] ne "" \|\| $#srv
		684	or return $cb->();
		685
		686	# use srv records then
		687	@target = map ["$_->[3].", $_->[2]],
		688	grep $_->[3] ne ".",
		689	@srv;
		690
		691	&$resolve;
		692	};
		693	} else {
		694	&$resolve;
		695	}
265	}	696	}
266		697
267	=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]	698	=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]
268		699
269	This is a convenience function that creates a TCP socket and makes a 100%	700	This is a convenience function that creates a TCP socket and makes a 100%
270	non-blocking connect to the given C<$host> (which can be a hostname or a	701	non-blocking connect to the given C<$host> (which can be a hostname or
		702	a textual IP address, or the string C<unix/> for UNIX domain sockets)
271	textual IP address) and C<$service> (which can be a numeric port number or	703	and C<$service> (which can be a numeric port number or a service name,
272	a service name, or a C<servicename=portnumber> string).	704	or a C<servicename=portnumber> string, or the pathname to a UNIX domain
		705	socket).
273		706
274	If both C<$host> and C<$port> are names, then this function will use SRV	707	If both C<$host> and C<$port> are names, then this function will use SRV
275	records to locate the real target(s).	708	records to locate the real target(s).
276		709
277	In either case, it will create a list of target hosts (e.g. for multihomed	710	In either case, it will create a list of target hosts (e.g. for multihomed
278	hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to	711	hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to
279	each in turn.	712	each in turn.
280		713
281	If the connect is successful, then the C<$connect_cb> will be invoked with	714	After the connection is established, then the C<$connect_cb> will be
282	the socket file handle (in non-blocking mode) as first and the peer host	715	invoked with the socket file handle (in non-blocking mode) as first and
283	(as a textual IP address) and peer port as second and third arguments,	716	the peer host (as a textual IP address) and peer port as second and third
284	respectively. The fourth argument is a code reference that you can call	717	arguments, respectively. The fourth argument is a code reference that you
285	if, for some reason, you don't like this connection, which will cause	718	can call if, for some reason, you don't like this connection, which will
286	C<tcp_connect> to try the next one (or call your callback without any	719	cause C<tcp_connect> to try the next one (or call your callback without
287	arguments if there are no more connections). In most cases, you can simply	720	any arguments if there are no more connections). In most cases, you can
288	ignore this argument.	721	simply ignore this argument.
289		722
290	$cb->($filehandle, $host, $port, $retry)	723	$cb->($filehandle, $host, $port, $retry)
291		724
292	If the connect is unsuccessful, then the C<$connect_cb> will be invoked	725	If the connect is unsuccessful, then the C<$connect_cb> will be invoked
293	without any arguments and C<$!> will be set appropriately (with C<ENXIO>	726	without any arguments and C<$!> will be set appropriately (with C<ENXIO>
294	indicating a DNS resolution failure).	727	indicating a DNS resolution failure).
		728
		729	The callback will I<never> be invoked before C<tcp_connect> returns, even
		730	if C<tcp_connect> was able to connect immediately (e.g. on unix domain
		731	sockets).
295		732
296	The file handle is perfect for being plugged into L<AnyEvent::Handle>, but	733	The file handle is perfect for being plugged into L<AnyEvent::Handle>, but
297	can be used as a normal perl file handle as well.	734	can be used as a normal perl file handle as well.
298		735
299	Unless called in void context, C<tcp_connect> returns a guard object that	736	Unless called in void context, C<tcp_connect> returns a guard object that
…		…
320	lessen the impact of this windows bug, a default timeout of 30 seconds	757	lessen the impact of this windows bug, a default timeout of 30 seconds
321	will be imposed on windows. Cygwin is not affected.	758	will be imposed on windows. Cygwin is not affected.
322		759
323	Simple Example: connect to localhost on port 22.	760	Simple Example: connect to localhost on port 22.
324		761
325	tcp_connect localhost => 22, sub {	762	tcp_connect localhost => 22, sub {
326	my $fh = shift	763	my $fh = shift
327	or die "unable to connect: $!";	764	or die "unable to connect: $!";
328	# do something	765	# do something
329	};	766	};
330		767
331	Complex Example: connect to www.google.com on port 80 and make a simple	768	Complex Example: connect to www.google.com on port 80 and make a simple
332	GET request without much error handling. Also limit the connection timeout	769	GET request without much error handling. Also limit the connection timeout
333	to 15 seconds.	770	to 15 seconds.
334		771
…		…
338	or die "unable to connect: $!";	775	or die "unable to connect: $!";
339		776
340	my $handle; # avoid direct assignment so on_eof has it in scope.	777	my $handle; # avoid direct assignment so on_eof has it in scope.
341	$handle = new AnyEvent::Handle	778	$handle = new AnyEvent::Handle
342	fh => $fh,	779	fh => $fh,
		780	on_error => sub {
		781	warn "error $_[2]\n";
		782	$_[0]->destroy;
		783	},
343	on_eof => sub {	784	on_eof => sub {
344	undef $handle; # keep it alive till eof	785	$handle->destroy; # destroy handle
345	warn "done.\n";	786	warn "done.\n";
346	};	787	};
347		788
348	$handle->push_write ("GET / HTTP/1.0\015\012\015\012");	789	$handle->push_write ("GET / HTTP/1.0\015\012\015\012");
349		790
350	$handle->push_read_line ("\015\012\015\012", sub {	791	$handle->push_read (line => "\015\012\015\012", sub {
351	my ($handle, $line) = @_;	792	my ($handle, $line) = @_;
352		793
353	# print response header	794	# print response header
354	print "HEADER\n$line\n\nBODY\n";	795	print "HEADER\n$line\n\nBODY\n";
355		796
…		…
364	# could call $fh->bind etc. here	805	# could call $fh->bind etc. here
365		806
366	15	807	15
367	};	808	};
368		809
		810	Example: connect to a UNIX domain socket.
		811
		812	tcp_connect "unix/", "/tmp/.X11-unix/X0", sub {
		813	...
		814	}
		815
369	=cut	816	=cut
370		817
371	sub tcp_connect($$$;$) {	818	sub tcp_connect($$$;$) {
372	my ($host, $port, $connect, $prepare) = @_;	819	my ($host, $port, $connect, $prepare) = @_;
373		820
374	# see http://cr.yp.to/docs/connect.html for some background	821	# see http://cr.yp.to/docs/connect.html for some background
		822	# also http://advogato.org/article/672.html
375		823
376	my %state = ( fh => undef );	824	my %state = ( fh => undef );
377		825
378	# name resolution	826	# name/service to type/sockaddr resolution
379	AnyEvent::DNS::addr $host, $port, 0, 0, 0, sub {	827	resolve_sockaddr $host, $port, 0, 0, undef, sub {
380	my @target = @_;	828	my @target = @_;
381		829
382	$state{next} = sub {	830	$state{next} = sub {
383	return unless exists $state{fh};	831	return unless exists $state{fh};
384		832
385	my $target = shift @target	833	my $target = shift @target
386	or do {	834	or return (%state = (), _postpone $connect);
387	%state = ();
388	return $connect->();
389	};
390		835
391	my ($domain, $type, $proto, $sockaddr) = @$target;	836	my ($domain, $type, $proto, $sockaddr) = @$target;
392		837
393	# socket creation	838	# socket creation
394	socket $state{fh}, $domain, $type, $proto	839	socket $state{fh}, $domain, $type, $proto
…		…
398		843
399	my $timeout = $prepare && $prepare->($state{fh});	844	my $timeout = $prepare && $prepare->($state{fh});
400		845
401	$timeout \|\|= 30 if AnyEvent::WIN32;	846	$timeout \|\|= 30 if AnyEvent::WIN32;
402		847
403	$state{to} = AnyEvent->timer (after => $timeout, cb => sub {	848	$state{to} = AE::timer $timeout, 0, sub {
404	$! = &Errno::ETIMEDOUT;	849	$! = Errno::ETIMEDOUT;
405	$state{next}();	850	$state{next}();
406	}) if $timeout;	851	} if $timeout;
407		852
408	# called when the connect was successful, which,	853	# now connect
409	# in theory, could be the case immediately (but never is in practise)	854	if (
410	my $connected = sub {	855	(connect $state{fh}, $sockaddr)
411	delete $state{ww};	856	\|\| ($! == Errno::EINPROGRESS # POSIX
412	delete $state{to};	857	\|\| $! == Errno::EWOULDBLOCK
413		858	# WSAEINPROGRESS intentionally not checked - it means something else entirely
		859	\|\| $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt
		860	\|\| $! == AnyEvent::Util::WSAEWOULDBLOCK)
		861	) {
		862	$state{ww} = AE::io $state{fh}, 1, sub {
414	# we are connected, or maybe there was an error	863	# we are connected, or maybe there was an error
415	if (my $sin = getpeername $state{fh}) {	864	if (my $sin = getpeername $state{fh}) {
416	my ($port, $host) = unpack_sockaddr $sin;	865	my ($port, $host) = unpack_sockaddr $sin;
417		866
		867	delete $state{ww}; delete $state{to};
		868
418	my $guard = guard {	869	my $guard = guard { %state = () };
419	%state = ();
420	};
421		870
422	$connect->($state{fh}, format_ip $host, $port, sub {	871	$connect->(delete $state{fh}, format_address $host, $port, sub {
423	$guard->cancel;	872	$guard->cancel;
		873	$state{next}();
		874	});
		875	} else {
		876	# dummy read to fetch real error code
		877	sysread $state{fh}, my $buf, 1 if $! == Errno::ENOTCONN;
		878
		879	return if $! == Errno::EAGAIN; # skip spurious wake-ups
		880
		881	delete $state{ww}; delete $state{to};
		882
424	$state{next}();	883	$state{next}();
425	});	884	}
426	} else {
427	# dummy read to fetch real error code
428	sysread $state{fh}, my $buf, 1 if $! == &Errno::ENOTCONN;
429	$state{next}();
430	}	885	};
431	};
432
433	# now connect
434	if (connect $state{fh}, $sockaddr) {
435	$connected->();
436	} elsif ($! == &Errno::EINPROGRESS \|\| $! == &Errno::EWOULDBLOCK) { # EINPROGRESS is POSIX
437	$state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $connected);
438	} else {	886	} else {
439	$state{next}();	887	$state{next}();
440	}	888	}
441	};	889	};
442		890
443	$! = &Errno::ENXIO;	891	$! = Errno::ENXIO;
444	$state{next}();	892	$state{next}();
445	};	893	};
446		894
447	defined wantarray && guard { %state = () }	895	defined wantarray && guard { %state = () }
448	}	896	}
449		897
450	=item $guard = tcp_server $host, $port, $accept_cb[, $prepare_cb]	898	=item $guard = tcp_server $host, $service, $accept_cb[, $prepare_cb]
451		899
452	Create and bind a TCP socket to the given host, and port, set the	900	Create and bind a stream socket to the given host, and port, set the
453	SO_REUSEADDR flag and call C<listen>.	901	SO_REUSEADDR flag (if applicable) and call C<listen>. Unlike the name
		902	implies, this function can also bind on UNIX domain sockets.
454		903
455	C<$host> must be an IPv4 or IPv6 address (or C<undef>, in which case it	904	For internet sockets, C<$host> must be an IPv4 or IPv6 address (or
456	binds either to C<0> or to C<::>, depending on whether IPv4 or IPv6 is the	905	C<undef>, in which case it binds either to C<0> or to C<::>, depending
457	preferred protocol).	906	on whether IPv4 or IPv6 is the preferred protocol, and maybe to both in
		907	future versions, as applicable).
458		908
459	To bind to the IPv4 wildcard address, use C<0>, to bind to the IPv6	909	To bind to the IPv4 wildcard address, use C<0>, to bind to the IPv6
460	wildcard address, use C<::>.	910	wildcard address, use C<::>.
461		911
462	The port is specified by C<$port>, which must be either a service name or	912	The port is specified by C<$service>, which must be either a service name or
463	a numeric port number (or C<0> or C<undef>, in which case an ephemeral	913	a numeric port number (or C<0> or C<undef>, in which case an ephemeral
464	port will be used).	914	port will be used).
		915
		916	For UNIX domain sockets, C<$host> must be C<unix/> and C<$service> must be
		917	the absolute pathname of the socket. This function will try to C<unlink>
		918	the socket before it tries to bind to it. See SECURITY CONSIDERATIONS,
		919	below.
465		920
466	For each new connection that could be C<accept>ed, call the C<<	921	For each new connection that could be C<accept>ed, call the C<<
467	$accept_cb->($fh, $host, $port) >> with the file handle (in non-blocking	922	$accept_cb->($fh, $host, $port) >> with the file handle (in non-blocking
468	mode) as first and the peer host and port as second and third arguments	923	mode) as first and the peer host and port as second and third arguments
469	(see C<tcp_connect> for details).	924	(see C<tcp_connect> for details).
…		…
481	address and port number of the local socket endpoint as second and third	936	address and port number of the local socket endpoint as second and third
482	arguments.	937	arguments.
483		938
484	It should return the length of the listen queue (or C<0> for the default).	939	It should return the length of the listen queue (or C<0> for the default).
485		940
		941	Note to IPv6 users: RFC-compliant behaviour for IPv6 sockets listening on
		942	C<::> is to bind to both IPv6 and IPv4 addresses by default on dual-stack
		943	hosts. Unfortunately, only GNU/Linux seems to implement this properly, so
		944	if you want both IPv4 and IPv6 listening sockets you should create the
		945	IPv6 socket first and then attempt to bind on the IPv4 socket, but ignore
		946	any C<EADDRINUSE> errors.
		947
486	Example: bind on some TCP port on the local machine and tell each client	948	Example: bind on some TCP port on the local machine and tell each client
487	to go away.	949	to go away.
488		950
489	tcp_server undef, undef, sub {	951	tcp_server undef, undef, sub {
490	my ($fh, $host, $port) = @_;	952	my ($fh, $host, $port) = @_;
…		…
493	}, sub {	955	}, sub {
494	my ($fh, $thishost, $thisport) = @_;	956	my ($fh, $thishost, $thisport) = @_;
495	warn "bound to $thishost, port $thisport\n";	957	warn "bound to $thishost, port $thisport\n";
496	};	958	};
497		959
		960	Example: bind a server on a unix domain socket.
		961
		962	tcp_server "unix/", "/tmp/mydir/mysocket", sub {
		963	my ($fh) = @_;
		964	};
		965
498	=cut	966	=cut
499		967
500	sub tcp_server($$$;$) {	968	sub tcp_server($$$;$) {
501	my ($host, $port, $accept, $prepare) = @_;	969	my ($host, $service, $accept, $prepare) = @_;
502		970
503	$host = $AnyEvent::PROTOCOL{ipv4} < $AnyEvent::PROTOCOL{ipv6} && AF_INET6	971	$host = $AnyEvent::PROTOCOL{ipv4} < $AnyEvent::PROTOCOL{ipv6} && AF_INET6
504	? "::" : "0"	972	? "::" : "0"
505	unless defined $host;	973	unless defined $host;
506		974
507	my $ipn = parse_ip $host	975	my $ipn = parse_address $host
508	or Carp::croak "AnyEvent::Socket::tcp_server: cannot parse '$host' as IPv4 or IPv6 address";	976	or Carp::croak "AnyEvent::Socket::tcp_server: cannot parse '$host' as host address";
509		977
510	my $domain = 4 == length $ipn ? AF_INET : AF_INET6;	978	my $af = address_family $ipn;
511		979
512	my %state;	980	my %state;
513		981
		982	# win32 perl is too stupid to get this right :/
		983	Carp::croak "tcp_server/socket: address family not supported"
		984	if AnyEvent::WIN32 && $af == AF_UNIX;
		985
514	socket $state{fh}, $domain, SOCK_STREAM, 0	986	socket $state{fh}, $af, SOCK_STREAM, 0
515	or Carp::croak "socket: $!";	987	or Carp::croak "tcp_server/socket: $!";
516		988
		989	if ($af == AF_INET \|\| $af == AF_INET6) {
517	setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1	990	setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1
518	or Carp::croak "so_reuseaddr: $!";	991	or Carp::croak "tcp_server/so_reuseaddr: $!"
		992	unless AnyEvent::WIN32; # work around windows bug
519		993
		994	unless ($service =~ /^\d*$/) {
		995	$service = (getservbyname $service, "tcp")[2]
		996	or Carp::croak "$service: service unknown"
		997	}
		998	} elsif ($af == AF_UNIX) {
		999	unlink $service;
		1000	}
		1001
520	bind $state{fh}, pack_sockaddr _tcp_port $port, $ipn	1002	bind $state{fh}, pack_sockaddr $service, $ipn
521	or Carp::croak "bind: $!";	1003	or Carp::croak "bind: $!";
522		1004
523	fh_nonblocking $state{fh}, 1;	1005	fh_nonblocking $state{fh}, 1;
524		1006
525	my $len;	1007	my $len;
526		1008
527	if ($prepare) {	1009	if ($prepare) {
528	my ($port, $host) = unpack_sockaddr getsockname $state{fh};	1010	my ($service, $host) = unpack_sockaddr getsockname $state{fh};
529	$len = $prepare && $prepare->($state{fh}, format_ip $host, $port);	1011	$len = $prepare && $prepare->($state{fh}, format_address $host, $service);
530	}	1012	}
531		1013
532	$len \|\|= 128;	1014	$len \|\|= 128;
533		1015
534	listen $state{fh}, $len	1016	listen $state{fh}, $len
535	or Carp::croak "listen: $!";	1017	or Carp::croak "listen: $!";
536		1018
537	$state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {	1019	$state{aw} = AE::io $state{fh}, 0, sub {
538	# this closure keeps $state alive	1020	# this closure keeps $state alive
539	while (my $peer = accept my $fh, $state{fh}) {	1021	while (my $peer = accept my $fh, $state{fh}) {
540	fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not	1022	fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not
		1023
541	my ($port, $host) = unpack_sockaddr $peer;	1024	my ($service, $host) = unpack_sockaddr $peer;
542	$accept->($fh, format_ip $host, $port);	1025	$accept->($fh, format_address $host, $service);
543	}	1026	}
544	});	1027	};
545		1028
546	defined wantarray	1029	defined wantarray
547	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency	1030	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency
548	: ()	1031	: ()
549	}	1032	}
550		1033
551	1;	1034	1;
552		1035
553	=back	1036	=back
554		1037
		1038	=head1 SECURITY CONSIDERATIONS
		1039
		1040	This module is quite powerful, with with power comes the ability to abuse
		1041	as well: If you accept "hostnames" and ports from untrusted sources,
		1042	then note that this can be abused to delete files (host=C<unix/>). This
		1043	is not really a problem with this module, however, as blindly accepting
		1044	any address and protocol and trying to bind a server or connect to it is
		1045	harmful in general.
		1046
555	=head1 AUTHOR	1047	=head1 AUTHOR
556		1048
557	Marc Lehmann <schmorp@schmorp.de>	1049	Marc Lehmann <schmorp@schmorp.de>
558	http://home.schmorp.de/	1050	http://home.schmorp.de/
559		1051

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents): Revision 1.32 by root, Mon May 26 17:45:05 2008 UTC vs. Revision 1.114 by root, Fri Aug 21 11:59:25 2009 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.32 by root, Mon May 26 17:45:05 2008 UTC vs.
Revision 1.114 by root, Fri Aug 21 11:59:25 2009 UTC