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

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

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents): Revision 1.11 by root, Fri May 23 20:09:56 2008 UTC vs. Revision 1.91 by root, Thu Jul 16 04:20:24 2009 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.11 by root, Fri May 23 20:09:56 2008 UTC vs.
Revision 1.91 by root, Thu Jul 16 04:20:24 2009 UTC