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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.34 by root, Wed May 28 21:07:07 2008 UTC vs.
Revision 1.114 by root, Fri Aug 21 11:59:25 2009 UTC

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

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents): Revision 1.34 by root, Wed May 28 21:07:07 2008 UTC vs. Revision 1.114 by root, Fri Aug 21 11:59:25 2009 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.34 by root, Wed May 28 21:07:07 2008 UTC vs.
Revision 1.114 by root, Fri Aug 21 11:59:25 2009 UTC