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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.20 by root, Sun May 25 01:05:27 2008 UTC vs.
Revision 1.97 by root, Sat Jul 18 05:19:09 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 ();	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);	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.85;
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);
…		…
84		92
85	Tries to parse the given IPv6 address and return it in	93	Tries to parse the given IPv6 address and return it in
86	octet form (or undef when it isn't in a parsable format).	94	octet form (or undef when it isn't in a parsable format).
87		95
88	Should support all forms specified by RFC 2373 (and additionally all IPv4	96	Should support all forms specified by RFC 2373 (and additionally all IPv4
89	forms supported by parse_ipv4).	97	forms supported by parse_ipv4). Note that scope-id's are not supported
		98	(and will not parse).
90		99
91	This function works similarly to C<inet_pton AF_INET6, ...>.	100	This function works similarly to C<inet_pton AF_INET6, ...>.
92		101
93	=cut	102	=cut
94		103
…		…
127		136
128	# and done	137	# and done
129	pack "n*", map hex, @h, @t	138	pack "n*", map hex, @h, @t
130	}	139	}
131		140
132	=item $ipn = parse_ip $text	141	sub parse_unix($) {
		142	$_[0] eq "unix/"
		143	? pack "S", AF_UNIX
		144	: undef
133		145
		146	}
		147
		148	=item $ipn = parse_address $ip
		149
134	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).
135		153
136	=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".
137		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
138	sub parse_ip($) {	169	sub parse_address($) {
139	&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	}
140	}	178	}
141		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
142	=item $text = format_ip $ipn	300	=item $text = format_ipv4 $ipn
143		301
144	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
145	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.
146		318
147	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, ...>,
148	except it automatically detects the address type.	320	except it automatically detects the address type.
149		321
150	=cut	322	Returns C<undef> if it cannot detect the type.
151		323
152	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
153	sub format_ip($) {	334	sub format_ipv4($) {
154	if (4 == length $_[0]) {
155	return join ".", unpack "C4", $_[0]	335	join ".", unpack "C4", $_[0]
156	} 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;
157	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) {
158	# v4mapped	347	# v4mapped
159	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;
160	} else {	352	} else {
161	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];
162		354
		355	# this is rather sucky, I admit
163	$ip =~ s/^0:(?:0:)*/::/	356	$ip =~ s/^0:(?:0:)*(0$)?/::/
164	or $ip =~ s/(:0)+$/::/	357	or $ip =~ s/(:0){7}$/::/ or $ip =~ s/(:0){7}/:/
165	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}/:/;
166	return $ip	364	return $ip
167	}	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/"
168	} else {	378	} else {
169	return undef	379	return undef
170	}	380	}
171	}	381	}
		382
		383	*ntoa = \&format_address;
172		384
173	=item inet_aton $name_or_address, $cb->(@addresses)	385	=item inet_aton $name_or_address, $cb->(@addresses)
174		386
175	Works similarly to its Socket counterpart, except that it uses a	387	Works similarly to its Socket counterpart, except that it uses a
176	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
177	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
178	for IPv6).	390	for IPv6).
179		391
180	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
181	and IPv6 addresses as result.	393	and IPv6 addresses as result (and maybe even other adrdess types).
182		394
183	=cut	395	=cut
184		396
185	sub inet_aton {	397	sub inet_aton {
186	my ($name, $cb) = @_;	398	my ($name, $cb) = @_;
…		…
204	}	416	}
205	});	417	});
206	}	418	}
207	}	419	}
208		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
209	=item $sa = AnyEvent::Socket::pack_sockaddr $port, $host	438	=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host
210		439
211	Pack the given port/host combination into a binary sockaddr structure. Handles	440	Pack the given port/host combination into a binary sockaddr
212	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).
213		444
214	=cut	445	=cut
215		446
216	sub pack_sockaddr($$) {	447	sub pack_sockaddr($$) {
217	if (4 == length $_[1]) {	448	my $af = address_family $_[1];
		449
		450	if ($af == AF_INET) {
218	Socket::pack_sockaddr_in $_[0], $_[1]	451	Socket::pack_sockaddr_in $_[0], $_[1]
219	} elsif (16 == length $_[1]) {	452	} elsif ($af == AF_INET6) {
220	pack "SnL a16 L",	453	pack "$pack_family nL a16 L",
221	&AnyEvent::Util::AF_INET6,	454	AF_INET6,
222	$_[0], # port	455	$_[0], # port
223	0, # flowinfo	456	0, # flowinfo
224	$_[1], # addr	457	$_[1], # addr
225	0 # scope id	458	0 # scope id
		459	} elsif ($af == AF_UNIX) {
		460	Socket::pack_sockaddr_un $_[0]
226	} else {	461	} else {
227	Carp::croak "pack_sockaddr: invalid host";	462	Carp::croak "pack_sockaddr: invalid host";
228	}	463	}
229	}	464	}
230		465
231	=item ($port, $host) = AnyEvent::Socket::unpack_sockaddr $sa	466	=item ($service, $host) = AnyEvent::Socket::unpack_sockaddr $sa
232		467
233	Unpack the given binary sockaddr structure (as used by bind, getpeername	468	Unpack the given binary sockaddr structure (as used by bind, getpeername
234	etc.) into a C<$port, $host> combination.	469	etc.) into a C<$service, $host> combination.
235		470
236	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/>).
237		477
238	=cut	478	=cut
239		479
240	sub unpack_sockaddr($) {	480	sub unpack_sockaddr($) {
241	my $af = unpack "S", $_[0];	481	my $af = sockaddr_family $_[0];
242		482
243	if ($af == &Socket::AF_INET) {	483	if ($af == AF_INET) {
244	Socket::unpack_sockaddr_in $_[0]	484	Socket::unpack_sockaddr_in $_[0]
245	} elsif ($af == &AnyEvent::Util::AF_INET6) {	485	} elsif ($af == AF_INET6) {
246	(unpack "SnL a16 L")[1, 3]	486	unpack "x2 n x4 a16", $_[0]
		487	} elsif ($af == AF_UNIX) {
		488	((Socket::unpack_sockaddr_un $_[0]), pack "S", AF_UNIX)
247	} else {	489	} else {
248	Carp::croak "unpack_sockaddr: unsupported protocol family $af";	490	Carp::croak "unpack_sockaddr: unsupported protocol family $af";
249	}	491	}
250	}	492	}
251		493
252	sub _tcp_port($) {	494	=item resolve_sockaddr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...)
253	$_[0] =~ /^(\d)$/ and return $11;
254		495
255	(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
256	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	}
257	}	662	}
258		663
259	=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]	664	=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]
260		665
261	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%
262	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)
263	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,
264	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).
265		672
266	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
267	records to locate the real target(s).	674	records to locate the real target(s).
268		675
269	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
…		…
301	timeout is to be used).	708	timeout is to be used).
302		709
303	Note that the socket could be either a IPv4 TCP socket or an IPv6 TCP	710	Note that the socket could be either a IPv4 TCP socket or an IPv6 TCP
304	socket (although only IPv4 is currently supported by this module).	711	socket (although only IPv4 is currently supported by this module).
305		712
		713	Note to the poor Microsoft Windows users: Windows (of course) doesn't
		714	correctly signal connection errors, so unless your event library works
		715	around this, failed connections will simply hang. The only event libraries
		716	that handle this condition correctly are L<EV> and L<Glib>. Additionally,
		717	AnyEvent works around this bug with L<Event> and in its pure-perl
		718	backend. All other libraries cannot correctly handle this condition. To
		719	lessen the impact of this windows bug, a default timeout of 30 seconds
		720	will be imposed on windows. Cygwin is not affected.
		721
306	Simple Example: connect to localhost on port 22.	722	Simple Example: connect to localhost on port 22.
307		723
308	tcp_connect localhost => 22, sub {	724	tcp_connect localhost => 22, sub {
309	my $fh = shift	725	my $fh = shift
310	or die "unable to connect: $!";	726	or die "unable to connect: $!";
311	# do something	727	# do something
312	};	728	};
313		729
314	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
315	GET request without much error handling. Also limit the connection timeout	731	GET request without much error handling. Also limit the connection timeout
316	to 15 seconds.	732	to 15 seconds.
317		733
…		…
321	or die "unable to connect: $!";	737	or die "unable to connect: $!";
322		738
323	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.
324	$handle = new AnyEvent::Handle	740	$handle = new AnyEvent::Handle
325	fh => $fh,	741	fh => $fh,
		742	on_error => sub {
		743	warn "error $_[2]\n";
		744	$_[0]->destroy;
		745	},
326	on_eof => sub {	746	on_eof => sub {
327	undef $handle; # keep it alive till eof	747	$handle->destroy; # destroy handle
328	warn "done.\n";	748	warn "done.\n";
329	};	749	};
330		750
331	$handle->push_write ("GET / HTTP/1.0\015\012\015\012");	751	$handle->push_write ("GET / HTTP/1.0\015\012\015\012");
332		752
…		…
347	# could call $fh->bind etc. here	767	# could call $fh->bind etc. here
348		768
349	15	769	15
350	};	770	};
351		771
		772	Example: connect to a UNIX domain socket.
		773
		774	tcp_connect "unix/", "/tmp/.X11-unix/X0", sub {
		775	...
		776	}
		777
352	=cut	778	=cut
353		779
354	sub tcp_connect($$$;$) {	780	sub tcp_connect($$$;$) {
355	my ($host, $port, $connect, $prepare) = @_;	781	my ($host, $port, $connect, $prepare) = @_;
356		782
357	# 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
358		785
359	my %state = ( fh => undef );	786	my %state = ( fh => undef );
360		787
361	# name resolution	788	# name/service to type/sockaddr resolution
362	AnyEvent::DNS::addr $host, $port, 0, 0, 0, sub {	789	resolve_sockaddr $host, $port, 0, 0, undef, sub {
363	my @target = @_;	790	my @target = @_;
364		791
365	$state{next} = sub {	792	$state{next} = sub {
366	return unless exists $state{fh};	793	return unless exists $state{fh};
367		794
368	my $target = shift @target	795	my $target = shift @target
369	or do {
370	%state = ();
371	return $connect->();	796	or return (%state = (), $connect->());
372	};
373		797
374	my ($domain, $type, $proto, $sockaddr) = @$target;	798	my ($domain, $type, $proto, $sockaddr) = @$target;
375		799
376	# socket creation	800	# socket creation
377	socket $state{fh}, $domain, $type, $proto	801	socket $state{fh}, $domain, $type, $proto
378	or return $state{next}();	802	or return $state{next}();
379		803
380	fh_nonblocking $state{fh}, 1;	804	fh_nonblocking $state{fh}, 1;
381		805
382	# prepare and optional timeout
383	if ($prepare) {
384	my $timeout = $prepare->($state{fh});	806	my $timeout = $prepare && $prepare->($state{fh});
385		807
		808	$timeout \|\|= 30 if AnyEvent::WIN32;
		809
386	$state{to} = AnyEvent->timer (after => $timeout, cb => sub {	810	$state{to} = AnyEvent->timer (after => $timeout, cb => sub {
387	$! = &Errno::ETIMEDOUT;	811	$! = Errno::ETIMEDOUT;
388	$state{next}();	812	$state{next}();
389	}) if $timeout;	813	}) if $timeout;
390	}
391		814
392	# called when the connect was successful, which,	815	# called when the connect was successful, which,
393	# 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)
394	my $connected = sub {	817	$state{connected} = sub {
395	delete $state{ww};
396	delete $state{to};
397
398	# we are connected, or maybe there was an error	818	# we are connected, or maybe there was an error
399	if (my $sin = getpeername $state{fh}) {	819	if (my $sin = getpeername $state{fh}) {
400	my ($port, $host) = unpack_sockaddr $sin;	820	my ($port, $host) = unpack_sockaddr $sin;
401		821
		822	delete $state{ww}; delete $state{to};
		823
402	my $guard = guard {	824	my $guard = guard { %state = () };
403	%state = ();
404	};
405		825
406	$connect->($state{fh}, format_ip $host, $port, sub {	826	$connect->(delete $state{fh}, format_address $host, $port, sub {
407	$guard->cancel;	827	$guard->cancel;
408	$state{next}();	828	$state{next}();
409	});	829	});
410	} else {	830	} else {
411	# dummy read to fetch real error code	831	# dummy read to fetch real error code
412	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
413	$state{next}();	838	$state{next}();
414	}	839	}
415	};	840	};
416		841
417	# now connect	842	# now connect
418	if (connect $state{fh}, $sockaddr) {	843	if (connect $state{fh}, $sockaddr) {
419	$connected->();	844	$state{connected}->();
420	} 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) {
421	$state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $connected);	850	$state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $state{connected});
422	} else {	851	} else {
423	%state = ();	852	$state{next}();
424	$connect->();
425	}	853	}
426	};	854	};
427		855
428	$! = &Errno::ENXIO;	856	$! = Errno::ENXIO;
429	$state{next}();	857	$state{next}();
430	};	858	};
431		859
432	defined wantarray && guard { %state = () }	860	defined wantarray && guard { %state = () }
433	}	861	}
434		862
435	=item $guard = tcp_server $host, $port, $accept_cb[, $prepare_cb]	863	=item $guard = tcp_server $host, $service, $accept_cb[, $prepare_cb]
436		864
437	Create and bind a TCP socket to the given host (any IPv4 host if undef,	865	Create and bind a stream socket to the given host, and port, set the
438	otherwise it must be an IPv4 or IPv6 address) and port (service name or	866	SO_REUSEADDR flag (if applicable) and call C<listen>. Unlike the name
439	numeric port number, or an ephemeral port if given as zero or undef), set	867	implies, this function can also bind on UNIX domain sockets.
440	the SO_REUSEADDR flag and call C<listen>.
441		868
		869	For internet sockets, C<$host> must be an IPv4 or IPv6 address (or
		870	C<undef>, in which case it binds either to C<0> or to C<::>, depending
		871	on whether IPv4 or IPv6 is the preferred protocol, and maybe to both in
		872	future versions, as applicable).
		873
		874	To bind to the IPv4 wildcard address, use C<0>, to bind to the IPv6
		875	wildcard address, use C<::>.
		876
		877	The port is specified by C<$service>, which must be either a service name or
		878	a numeric port number (or C<0> or C<undef>, in which case an ephemeral
		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.
		885
442	For each new connection that could be C<accept>ed, call the C<$accept_cb>	886	For each new connection that could be C<accept>ed, call the C<<
443	with the file handle (in non-blocking mode) as first and the peer host and	887	$accept_cb->($fh, $host, $port) >> with the file handle (in non-blocking
444	port as second and third arguments (see C<tcp_connect> for details).	888	mode) as first and the peer host and port as second and third arguments
		889	(see C<tcp_connect> for details).
445		890
446	Croaks on any errors.	891	Croaks on any errors it can detect before the listen.
447		892
448	If called in non-void context, then this function returns a guard object	893	If called in non-void context, then this function returns a guard object
449	whose lifetime it tied to the TCP server: If the object gets destroyed,	894	whose lifetime it tied to the TCP server: If the object gets destroyed,
450	the server will be stopped (but existing accepted connections will	895	the server will be stopped (but existing accepted connections will
451	continue).	896	continue).
452		897
453	If you need more control over the listening socket, you can provide a	898	If you need more control over the listening socket, you can provide a
454	C<$prepare_cb>, which is called just before the C<listen ()> call, with	899	C<< $prepare_cb->($fh, $host, $port) >>, which is called just before the
455	the listen file handle as first argument.	900	C<listen ()> call, with the listen file handle as first argument, and IP
		901	address and port number of the local socket endpoint as second and third
		902	arguments.
456		903
457	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).
458		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
459	Example: bind on TCP port 8888 on the local machine and tell each client	913	Example: bind on some TCP port on the local machine and tell each client
460	to go away.	914	to go away.
461		915
462	tcp_server undef, 8888, sub {	916	tcp_server undef, undef, sub {
463	my ($fh, $host, $port) = @_;	917	my ($fh, $host, $port) = @_;
464		918
465	syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";	919	syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";
		920	}, sub {
		921	my ($fh, $thishost, $thisport) = @_;
		922	warn "bound to $thishost, port $thisport\n";
466	};	923	};
467		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
468	=cut	931	=cut
469		932
470	sub tcp_server($$$;$) {	933	sub tcp_server($$$;$) {
471	my ($host, $port, $accept, $prepare) = @_;	934	my ($host, $service, $accept, $prepare) = @_;
		935
		936	$host = $AnyEvent::PROTOCOL{ipv4} < $AnyEvent::PROTOCOL{ipv6} && AF_INET6
		937	? "::" : "0"
		938	unless defined $host;
		939
		940	my $ipn = parse_address $host
		941	or Carp::croak "AnyEvent::Socket::tcp_server: cannot parse '$host' as host address";
		942
		943	my $af = address_family $ipn;
472		944
473	my %state;	945	my %state;
474		946
475	socket $state{fh}, &Socket::AF_INET, &Socket::SOCK_STREAM, 0	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
		951	socket $state{fh}, $af, SOCK_STREAM, 0
476	or Carp::croak "socket: $!";	952	or Carp::croak "tcp_server/socket: $!";
477		953
		954	if ($af == AF_INET \|\| $af == AF_INET6) {
478	setsockopt $state{fh}, &Socket::SOL_SOCKET, &Socket::SO_REUSEADDR, 1	955	setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1
479	or Carp::croak "so_reuseaddr: $!";	956	or Carp::croak "tcp_server/so_reuseaddr: $!"
		957	unless AnyEvent::WIN32; # work around windows bug
480		958
481	bind $state{fh}, Socket::pack_sockaddr_in _tcp_port $port, parse_ip ($host \|\| "0.0.0.0")	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
		967	bind $state{fh}, pack_sockaddr $service, $ipn
482	or Carp::croak "bind: $!";	968	or Carp::croak "bind: $!";
483		969
484	fh_nonblocking $state{fh}, 1;	970	fh_nonblocking $state{fh}, 1;
485		971
486	my $len = ($prepare && $prepare->($state{fh})) \|\| 128;	972	my $len;
		973
		974	if ($prepare) {
		975	my ($service, $host) = unpack_sockaddr getsockname $state{fh};
		976	$len = $prepare && $prepare->($state{fh}, format_address $host, $service);
		977	}
		978
		979	$len \|\|= 128;
487		980
488	listen $state{fh}, $len	981	listen $state{fh}, $len
489	or Carp::croak "listen: $!";	982	or Carp::croak "listen: $!";
490		983
491	$state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {	984	$state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {
492	# this closure keeps $state alive	985	# this closure keeps $state alive
493	while (my $peer = accept my $fh, $state{fh}) {	986	while (my $peer = accept my $fh, $state{fh}) {
494	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
495	my ($port, $host) = Socket::unpack_sockaddr_in $peer;	989	my ($service, $host) = unpack_sockaddr $peer;
496	$accept->($fh, (Socket::inet_ntoa $host), $port);	990	$accept->($fh, format_address $host, $service);
497	}	991	}
498	});	992	});
499		993
500	defined wantarray	994	defined wantarray
501	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency	995	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency
…		…
504		998
505	1;	999	1;
506		1000
507	=back	1001	=back
508		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
509	=head1 AUTHOR	1012	=head1 AUTHOR
510		1013
511	Marc Lehmann <schmorp@schmorp.de>	1014	Marc Lehmann <schmorp@schmorp.de>
512	http://home.schmorp.de/	1015	http://home.schmorp.de/
513		1016

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents): Revision 1.20 by root, Sun May 25 01:05:27 2008 UTC vs. Revision 1.97 by root, Sat Jul 18 05:19:09 2009 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.20 by root, Sun May 25 01:05:27 2008 UTC vs.
Revision 1.97 by root, Sat Jul 18 05:19:09 2009 UTC