[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.63 by root, Wed Oct 1 07:40:39 2008 UTC

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

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.63 by root, Wed Oct 1 07:40:39 2008 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.63 by root, Wed Oct 1 07:40:39 2008 UTC