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

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

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents): Revision 1.28 by root, Mon May 26 05:09:53 2008 UTC vs. Revision 1.99 by root, Sun Jul 26 00:17:25 2009 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.28 by root, Mon May 26 05:09:53 2008 UTC vs.
Revision 1.99 by root, Sun Jul 26 00:17:25 2009 UTC