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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.36 by root, Wed May 28 21:29:03 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]), pack "S", AF_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	}	526	}
325		527
…		…
346	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
347	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
348	type and any SRV records it might find.	550	type and any SRV records it might find.
349		551
350	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
351	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
352	C<$ENV{PERL_ANYEVENT_PROTOCOLS}>.	554	C<$ENV{PERL_ANYEVENT_PROTOCOLS}>.
353		555
354	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
355	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>).
356		559
357	The callback will receive zero or more array references that contain	560	The callback will receive zero or more array references that contain
358	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
359	C<$sockaddr> for use in C<connect> (or C<bind>).	562	C<$sockaddr> for use in C<connect> (or C<bind>).
360		563
…		…
368		571
369	sub resolve_sockaddr($$$$$$) {	572	sub resolve_sockaddr($$$$$$) {
370	my ($node, $service, $proto, $family, $type, $cb) = @_;	573	my ($node, $service, $proto, $family, $type, $cb) = @_;
371		574
372	if ($node eq "unix/") {	575	if ($node eq "unix/") {
373	return $cb->() if $family \|\| !/^\//; # no can do	576	return $cb->() if $family \|\| $service !~ /^\//; # no can do
374		577
375	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]);
376	}	579	}
377		580
378	unless (AF_INET6) {	581	unless (AF_INET6) {
379	$family != 6	582	$family != 6
380	or return $cb->();	583	or return $cb->();
…		…
389	$family \|\|= 6 unless $AnyEvent::PROTOCOL{ipv4};	592	$family \|\|= 6 unless $AnyEvent::PROTOCOL{ipv4};
390		593
391	$proto \|\|= "tcp";	594	$proto \|\|= "tcp";
392	$type \|\|= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;	595	$type \|\|= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;
393		596
394	my $proton = (getprotobyname $proto)[2]	597	my $proton = getprotobyname $proto
395	or Carp::croak "$proto: protocol unknown";	598	or Carp::croak "$proto: protocol unknown";
396		599
397	my $port;	600	my $port;
398		601
399	if ($service =~ /^(\S+)=(\d+)$/) {	602	if ($service =~ /^(\S+)=(\d+)$/) {
…		…
408	my @target = [$node, $port];	611	my @target = [$node, $port];
409		612
410	# resolve a records / provide sockaddr structures	613	# resolve a records / provide sockaddr structures
411	my $resolve = sub {	614	my $resolve = sub {
412	my @res;	615	my @res;
413	my $cv = AnyEvent->condvar (cb => sub {	616	my $cv = AE::cv {
414	$cb->(	617	$cb->(
415	map $_->[2],	618	map $_->[2],
416	sort {	619	sort {
417	$AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]}	620	$AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]}
418	or $a->[0] <=> $b->[0]	621	or $a->[0] <=> $b->[0]
419	}	622	}
420	@res	623	@res
421	)	624	)
422	});	625	};
423		626
424	$cv->begin;	627	$cv->begin;
425	for my $idx (0 .. $#target) {	628	for my $idx (0 .. $#target) {
426	my ($node, $port) = @{ $target[$idx] };	629	my ($node, $port) = @{ $target[$idx] };
427		630
428	if (my $noden = parse_address $node) {	631	if (my $noden = parse_address $node) {
		632	my $af = address_family $noden;
		633
429	if (4 == length $noden && $family != 6) {	634	if ($af == AF_INET && $family != 6) {
430	push @res, [$idx, "ipv4", [AF_INET, $type, $proton,	635	push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
431	pack_sockaddr $port, $noden]]	636	pack_sockaddr $port, $noden]]
432	}	637	}
433		638
434	if (16 == length $noden && $family != 4) {	639	if ($af == AF_INET6 && $family != 4) {
435	push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,	640	push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,
436	pack_sockaddr $port, $noden]]	641	pack_sockaddr $port, $noden]]
437	}	642	}
438	} else {	643	} else {
439	# ipv4	644	# ipv4
440	if ($family != 6) {	645	if ($family != 6) {
441	$cv->begin;	646	$cv->begin;
442	a $node, sub {	647	AnyEvent::DNS::a $node, sub {
443	push @res, [$idx, "ipv4", [AF_INET, $type, $proton,	648	push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
444	pack_sockaddr $port, parse_ipv4 $_]]	649	pack_sockaddr $port, parse_ipv4 $_]]
445	for @_;	650	for @_;
446	$cv->end;	651	$cv->end;
447	};	652	};
448	}	653	}
449		654
450	# ipv6	655	# ipv6
451	if ($family != 4) {	656	if ($family != 4) {
452	$cv->begin;	657	$cv->begin;
453	aaaa $node, sub {	658	AnyEvent::DNS::aaaa $node, sub {
454	push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,	659	push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,
455	pack_sockaddr $port, parse_ipv6 $_]]	660	pack_sockaddr $port, parse_ipv6 $_]]
456	for @_;	661	for @_;
457	$cv->end;	662	$cv->end;
458	};	663	};
…		…
465	# try srv records, if applicable	670	# try srv records, if applicable
466	if ($node eq "localhost") {	671	if ($node eq "localhost") {
467	@target = (["127.0.0.1", $port], ["::1", $port]);	672	@target = (["127.0.0.1", $port], ["::1", $port]);
468	&$resolve;	673	&$resolve;
469	} elsif (defined $service && !parse_address $node) {	674	} elsif (defined $service && !parse_address $node) {
470	srv $service, $proto, $node, sub {	675	AnyEvent::DNS::srv $service, $proto, $node, sub {
471	my (@srv) = @_;	676	my (@srv) = @_;
472		677
473	# no srv records, continue traditionally	678	# no srv records, continue traditionally
474	@srv	679	@srv
475	or return &$resolve;	680	or return &$resolve;
476		681
477	# only srv record has "." => abort	682	# the only srv record has "." ("" here) => abort
478	$srv[0][2] ne "." \|\| $#srv	683	$srv[0][2] ne "" \|\| $#srv
479	or return $cb->();	684	or return $cb->();
480		685
481	# use srv records then	686	# use srv records then
482	@target = map ["$_->[3].", $_->[2]],	687	@target = map ["$_->[3].", $_->[2]],
483	grep $_->[3] ne ".",	688	grep $_->[3] ne ".",
…		…
504		709
505	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
506	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
507	each in turn.	712	each in turn.
508		713
509	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
510	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
511	(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
512	respectively. The fourth argument is a code reference that you can call	717	arguments, respectively. The fourth argument is a code reference that you
513	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
514	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
515	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
516	ignore this argument.	721	simply ignore this argument.
517		722
518	$cb->($filehandle, $host, $port, $retry)	723	$cb->($filehandle, $host, $port, $retry)
519		724
520	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
521	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>
522	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).
523		732
524	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
525	can be used as a normal perl file handle as well.	734	can be used as a normal perl file handle as well.
526		735
527	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
…		…
548	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
549	will be imposed on windows. Cygwin is not affected.	758	will be imposed on windows. Cygwin is not affected.
550		759
551	Simple Example: connect to localhost on port 22.	760	Simple Example: connect to localhost on port 22.
552		761
553	tcp_connect localhost => 22, sub {	762	tcp_connect localhost => 22, sub {
554	my $fh = shift	763	my $fh = shift
555	or die "unable to connect: $!";	764	or die "unable to connect: $!";
556	# do something	765	# do something
557	};	766	};
558		767
559	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
560	GET request without much error handling. Also limit the connection timeout	769	GET request without much error handling. Also limit the connection timeout
561	to 15 seconds.	770	to 15 seconds.
562		771
…		…
566	or die "unable to connect: $!";	775	or die "unable to connect: $!";
567		776
568	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.
569	$handle = new AnyEvent::Handle	778	$handle = new AnyEvent::Handle
570	fh => $fh,	779	fh => $fh,
		780	on_error => sub {
		781	warn "error $_[2]\n";
		782	$_[0]->destroy;
		783	},
571	on_eof => sub {	784	on_eof => sub {
572	undef $handle; # keep it alive till eof	785	$handle->destroy; # destroy handle
573	warn "done.\n";	786	warn "done.\n";
574	};	787	};
575		788
576	$handle->push_write ("GET / HTTP/1.0\015\012\015\012");	789	$handle->push_write ("GET / HTTP/1.0\015\012\015\012");
577		790
578	$handle->push_read_line ("\015\012\015\012", sub {	791	$handle->push_read (line => "\015\012\015\012", sub {
579	my ($handle, $line) = @_;	792	my ($handle, $line) = @_;
580		793
581	# print response header	794	# print response header
582	print "HEADER\n$line\n\nBODY\n";	795	print "HEADER\n$line\n\nBODY\n";
583		796
…		…
609	# also http://advogato.org/article/672.html	822	# also http://advogato.org/article/672.html
610		823
611	my %state = ( fh => undef );	824	my %state = ( fh => undef );
612		825
613	# name/service to type/sockaddr resolution	826	# name/service to type/sockaddr resolution
614	resolve_sockaddr $host, $port, 0, 0, 0, sub {	827	resolve_sockaddr $host, $port, 0, 0, undef, sub {
615	my @target = @_;	828	my @target = @_;
616		829
617	$state{next} = sub {	830	$state{next} = sub {
618	return unless exists $state{fh};	831	return unless exists $state{fh};
619		832
620	my $target = shift @target	833	my $target = shift @target
621	or do {	834	or return (%state = (), _postpone $connect);
622	%state = ();
623	return $connect->();
624	};
625		835
626	my ($domain, $type, $proto, $sockaddr) = @$target;	836	my ($domain, $type, $proto, $sockaddr) = @$target;
627		837
628	# socket creation	838	# socket creation
629	socket $state{fh}, $domain, $type, $proto	839	socket $state{fh}, $domain, $type, $proto
…		…
633		843
634	my $timeout = $prepare && $prepare->($state{fh});	844	my $timeout = $prepare && $prepare->($state{fh});
635		845
636	$timeout \|\|= 30 if AnyEvent::WIN32;	846	$timeout \|\|= 30 if AnyEvent::WIN32;
637		847
638	$state{to} = AnyEvent->timer (after => $timeout, cb => sub {	848	$state{to} = AE::timer $timeout, 0, sub {
639	$! = &Errno::ETIMEDOUT;	849	$! = Errno::ETIMEDOUT;
640	$state{next}();	850	$state{next}();
641	}) if $timeout;	851	} if $timeout;
642		852
643	# called when the connect was successful, which,	853	# now connect
644	# in theory, could be the case immediately (but never is in practise)	854	if (
645	my $connected = sub {	855	(connect $state{fh}, $sockaddr)
646	delete $state{ww};	856	\|\| ($! == Errno::EINPROGRESS # POSIX
647	delete $state{to};	857	\|\| $! == Errno::EWOULDBLOCK
648		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 {
649	# we are connected, or maybe there was an error	863	# we are connected, or maybe there was an error
650	if (my $sin = getpeername $state{fh}) {	864	if (my $sin = getpeername $state{fh}) {
651	my ($port, $host) = unpack_sockaddr $sin;	865	my ($port, $host) = unpack_sockaddr $sin;
652		866
		867	delete $state{ww}; delete $state{to};
		868
653	my $guard = guard {	869	my $guard = guard { %state = () };
654	%state = ();
655	};
656		870
657	$connect->($state{fh}, format_address $host, $port, sub {	871	$connect->(delete $state{fh}, format_address $host, $port, sub {
658	$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
659	$state{next}();	883	$state{next}();
660	});	884	}
661	} else {
662	# dummy read to fetch real error code
663	sysread $state{fh}, my $buf, 1 if $! == &Errno::ENOTCONN;
664	$state{next}();
665	}	885	};
666	};
667
668	# now connect
669	if (connect $state{fh}, $sockaddr) {
670	$connected->();
671	} elsif ($! == &Errno::EINPROGRESS # POSIX
672	\|\| $! == &Errno::EWOULDBLOCK
673	# WSAEINPROGRESS intentionally not checked - it means something else entirely
674	\|\| $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt
675	\|\| $! == AnyEvent::Util::WSAEWOULDBLOCK) {
676	$state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $connected);
677	} else {	886	} else {
678	$state{next}();	887	$state{next}();
679	}	888	}
680	};	889	};
681		890
682	$! = &Errno::ENXIO;	891	$! = Errno::ENXIO;
683	$state{next}();	892	$state{next}();
684	};	893	};
685		894
686	defined wantarray && guard { %state = () }	895	defined wantarray && guard { %state = () }
687	}	896	}
…		…
691	Create and bind a stream socket to the given host, and port, set the	900	Create and bind a stream socket to the given host, and port, set the
692	SO_REUSEADDR flag (if applicable) and call C<listen>. Unlike the name	901	SO_REUSEADDR flag (if applicable) and call C<listen>. Unlike the name
693	implies, this function can also bind on UNIX domain sockets.	902	implies, this function can also bind on UNIX domain sockets.
694		903
695	For internet sockets, C<$host> must be an IPv4 or IPv6 address (or	904	For internet sockets, C<$host> must be an IPv4 or IPv6 address (or
696	C<undef>, in which case it binds either to C<0> or to C<::>, depending on	905	C<undef>, in which case it binds either to C<0> or to C<::>, depending
697	whether IPv4 or IPv6 is the preferred protocol).	906	on whether IPv4 or IPv6 is the preferred protocol, and maybe to both in
		907	future versions, as applicable).
698		908
699	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
700	wildcard address, use C<::>.	910	wildcard address, use C<::>.
701		911
702	The port is specified by C<$service>, which must be either a service name or	912	The port is specified by C<$service>, which must be either a service name or
…		…
726	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
727	arguments.	937	arguments.
728		938
729	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).
730		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
731	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
732	to go away.	949	to go away.
733		950
734	tcp_server undef, undef, sub {	951	tcp_server undef, undef, sub {
735	my ($fh, $host, $port) = @_;	952	my ($fh, $host, $port) = @_;
…		…
738	}, sub {	955	}, sub {
739	my ($fh, $thishost, $thisport) = @_;	956	my ($fh, $thishost, $thisport) = @_;
740	warn "bound to $thishost, port $thisport\n";	957	warn "bound to $thishost, port $thisport\n";
741	};	958	};
742		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
743	=cut	966	=cut
744		967
745	sub tcp_server($$$;$) {	968	sub tcp_server($$$;$) {
746	my ($host, $service, $accept, $prepare) = @_;	969	my ($host, $service, $accept, $prepare) = @_;
747		970
…		…
764	or Carp::croak "tcp_server/socket: $!";	987	or Carp::croak "tcp_server/socket: $!";
765		988
766	if ($af == AF_INET \|\| $af == AF_INET6) {	989	if ($af == AF_INET \|\| $af == AF_INET6) {
767	setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1	990	setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1
768	or Carp::croak "tcp_server/so_reuseaddr: $!"	991	or Carp::croak "tcp_server/so_reuseaddr: $!"
769	unless !AnyEvent::WIN32; # work around windows bug	992	unless AnyEvent::WIN32; # work around windows bug
770		993
771	unless ($service =~ /^\d*$/) {	994	unless ($service =~ /^\d*$/) {
772	$service = (getservbyname $service, "tcp")[2]	995	$service = (getservbyname $service, "tcp")[2]
773	or Carp::croak "$service: service unknown"	996	or Carp::croak "$service: service unknown"
774	}	997	}
…		…
791	$len \|\|= 128;	1014	$len \|\|= 128;
792		1015
793	listen $state{fh}, $len	1016	listen $state{fh}, $len
794	or Carp::croak "listen: $!";	1017	or Carp::croak "listen: $!";
795		1018
796	$state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {	1019	$state{aw} = AE::io $state{fh}, 0, sub {
797	# this closure keeps $state alive	1020	# this closure keeps $state alive
798	while (my $peer = accept my $fh, $state{fh}) {	1021	while (my $peer = accept my $fh, $state{fh}) {
799	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
800	my ($service, $host) = unpack_sockaddr $peer;	1024	my ($service, $host) = unpack_sockaddr $peer;
801	$accept->($fh, format_address $host, $service);	1025	$accept->($fh, format_address $host, $service);
802	}	1026	}
803	});	1027	};
804		1028
805	defined wantarray	1029	defined wantarray
806	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency	1030	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency
807	: ()	1031	: ()
808	}	1032	}
809		1033
810	1;	1034	1;
811		1035
812	=back	1036	=back
813		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
814	=head1 AUTHOR	1047	=head1 AUTHOR
815		1048
816	Marc Lehmann <schmorp@schmorp.de>	1049	Marc Lehmann <schmorp@schmorp.de>
817	http://home.schmorp.de/	1050	http://home.schmorp.de/
818		1051

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents): Revision 1.36 by root, Wed May 28 21:29:03 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.36 by root, Wed May 28 21:29:03 2008 UTC vs.
Revision 1.114 by root, Fri Aug 21 11:59:25 2009 UTC