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

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.83 by root, Mon Jun 29 21:00:32 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.83 by root, Mon Jun 29 21:00:32 2009 UTC