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

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

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents): Revision 1.21 by root, Sun May 25 02:26:49 2008 UTC vs. Revision 1.55 by root, Thu Jul 17 15:44:19 2008 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.21 by root, Sun May 25 02:26:49 2008 UTC vs.
Revision 1.55 by root, Thu Jul 17 15:44:19 2008 UTC