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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.4 by root, Fri May 23 04:10:40 2008 UTC vs.
Revision 1.110 by root, Sun Jul 26 00:17:25 2009 UTC

…		…
2		2
3	AnyEvent::DNS - fully asynchronous DNS resolution	3	AnyEvent::DNS - fully asynchronous DNS resolution
4		4
5	=head1 SYNOPSIS	5	=head1 SYNOPSIS
6		6
7	use AnyEvent::DNS;	7	use AnyEvent::DNS;
		8
		9	my $cv = AnyEvent->condvar;
		10	AnyEvent::DNS::a "www.google.de", $cv;
		11	# ... later
		12	my @addrs = $cv->recv;
8		13
9	=head1 DESCRIPTION	14	=head1 DESCRIPTION
10		15
11	This module offers both a number of DNS convenience functions as well	16	This module offers both a number of DNS convenience functions as well
12	as a fully asynchronous and high-performance pure-perl stub resolver.	17	as a fully asynchronous and high-performance pure-perl stub resolver.
13		18
		19	The stub resolver supports DNS over IPv4 and IPv6, UDP and TCP, optional
		20	EDNS0 support for up to 4kiB datagrams and automatically falls back to
		21	virtual circuit mode for large responses.
		22
14	=head2 CONVENIENCE FUNCTIONS	23	=head2 CONVENIENCE FUNCTIONS
15		24
16	=over 4	25	=over 4
17		26
18	=cut	27	=cut
19		28
20	package AnyEvent::DNS;	29	package AnyEvent::DNS;
21		30
22	no warnings;	31	use Carp ();
23	use strict;	32	use Socket qw(AF_INET SOCK_DGRAM SOCK_STREAM);
24		33
		34	use AnyEvent (); BEGIN { AnyEvent::common_sense }
25	use AnyEvent::Util ();	35	use AnyEvent::Util qw(AF_INET6);
26		36
27	=item AnyEvent::DNS::addr $node, $service, $family, $type, $cb->(@addrs)	37	our $VERSION = 4.87;
28		38
29	NOT YET IMPLEMENTED	39	our @DNS_FALLBACK = (v208.67.220.220, v208.67.222.222);
30
31	Tries to resolve the given nodename and service name into sockaddr
32	structures usable to connect to this node and service in a
33	protocol-independent way. It works similarly to the getaddrinfo posix
34	function.
35
36	Example:
37
38	AnyEvent::DNS::addr "google.com", "http", AF_UNSPEC, SOCK_STREAM, sub { ... };
39		40
40	=item AnyEvent::DNS::a $domain, $cb->(@addrs)	41	=item AnyEvent::DNS::a $domain, $cb->(@addrs)
41		42
42	Tries to resolve the given domain to IPv4 address(es).	43	Tries to resolve the given domain to IPv4 address(es).
		44
		45	=item AnyEvent::DNS::aaaa $domain, $cb->(@addrs)
		46
		47	Tries to resolve the given domain to IPv6 address(es).
43		48
44	=item AnyEvent::DNS::mx $domain, $cb->(@hostnames)	49	=item AnyEvent::DNS::mx $domain, $cb->(@hostnames)
45		50
46	Tries to resolve the given domain into a sorted (lower preference value	51	Tries to resolve the given domain into a sorted (lower preference value
47	first) list of domain names.	52	first) list of domain names.
…		…
57	=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)	62	=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)
58		63
59	Tries to resolve the given service, protocol and domain name into a list	64	Tries to resolve the given service, protocol and domain name into a list
60	of service records.	65	of service records.
61		66
62	Each srv_rr is an arrayref with the following contents:	67	Each C<$srv_rr> is an array reference with the following contents:
63	C<[$priority, $weight, $transport, $target]>.	68	C<[$priority, $weight, $transport, $target]>.
64		69
65	They will be sorted with lowest priority, highest weight first (TODO:	70	They will be sorted with lowest priority first, then randomly
66	should use the rfc algorithm to reorder same-priority records for weight).	71	distributed by weight as per RFC 2782.
67		72
68	Example:	73	Example:
69		74
70	AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...	75	AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...
71	# @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )	76	# @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )
72		77
73	=item AnyEvent::DNS::ptr $ipv4_or_6, $cb->(@hostnames)	78	=item AnyEvent::DNS::ptr $domain, $cb->(@hostnames)
		79
		80	Tries to make a PTR lookup on the given domain. See C<reverse_lookup>
		81	and C<reverse_verify> if you want to resolve an IP address to a hostname
		82	instead.
		83
		84	=item AnyEvent::DNS::any $domain, $cb->(@rrs)
		85
		86	Tries to resolve the given domain and passes all resource records found to
		87	the callback.
		88
		89	=item AnyEvent::DNS::reverse_lookup $ipv4_or_6, $cb->(@hostnames)
74		90
75	Tries to reverse-resolve the given IPv4 or IPv6 address (in textual form)	91	Tries to reverse-resolve the given IPv4 or IPv6 address (in textual form)
76	into it's hostname(s).	92	into it's hostname(s). Handles V4MAPPED and V4COMPAT IPv6 addresses
		93	transparently.
77		94
78	Requires the Socket6 module for IPv6 support.	95	=item AnyEvent::DNS::reverse_verify $ipv4_or_6, $cb->(@hostnames)
		96
		97	The same as C<reverse_lookup>, but does forward-lookups to verify that
		98	the resolved hostnames indeed point to the address, which makes spoofing
		99	harder.
		100
		101	If you want to resolve an address into a hostname, this is the preferred
		102	method: The DNS records could still change, but at least this function
		103	verified that the hostname, at one point in the past, pointed at the IP
		104	address you originally resolved.
79		105
80	Example:	106	Example:
81		107
82	AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };	108	AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };
83	# => f.root-servers.net	109	# => f.root-servers.net
84		110
85	=cut	111	=cut
		112
		113	sub MAX_PKT() { 4096 } # max packet size we advertise and accept
		114
		115	sub DOMAIN_PORT() { 53 } # if this changes drop me a note
86		116
87	sub resolver;	117	sub resolver;
88		118
89	sub a($$) {	119	sub a($$) {
90	my ($domain, $cb) = @_;	120	my ($domain, $cb) = @_;
…		…
92	resolver->resolve ($domain => "a", sub {	122	resolver->resolve ($domain => "a", sub {
93	$cb->(map $_->[3], @_);	123	$cb->(map $_->[3], @_);
94	});	124	});
95	}	125	}
96		126
		127	sub aaaa($$) {
		128	my ($domain, $cb) = @_;
		129
		130	resolver->resolve ($domain => "aaaa", sub {
		131	$cb->(map $_->[3], @_);
		132	});
		133	}
		134
97	sub mx($$) {	135	sub mx($$) {
98	my ($domain, $cb) = @_;	136	my ($domain, $cb) = @_;
99		137
100	resolver->resolve ($domain => "mx", sub {	138	resolver->resolve ($domain => "mx", sub {
101	$cb->(map $_->[4], sort { $a->[3] <=> $b->[3] } @_);	139	$cb->(map $_->[4], sort { $a->[3] <=> $b->[3] } @_);
…		…
121	sub srv($$$$) {	159	sub srv($$$$) {
122	my ($service, $proto, $domain, $cb) = @_;	160	my ($service, $proto, $domain, $cb) = @_;
123		161
124	# todo, ask for any and check glue records	162	# todo, ask for any and check glue records
125	resolver->resolve ("_$service._$proto.$domain" => "srv", sub {	163	resolver->resolve ("_$service._$proto.$domain" => "srv", sub {
126	$cb->(map [@$_[3,4,5,6]], sort { $a->[3] <=> $b->[3] \|\| $b->[4] <=> $a->[4] } @_);	164	my @res;
		165
		166	# classify by priority
		167	my %pri;
		168	push @{ $pri{$_->[3]} }, [ @$_[3,4,5,6] ]
		169	for @_;
		170
		171	# order by priority
		172	for my $pri (sort { $a <=> $b } keys %pri) {
		173	# order by weight
		174	my @rr = sort { $a->[1] <=> $b->[1] } @{ delete $pri{$pri} };
		175
		176	my $sum; $sum += $_->[1] for @rr;
		177
		178	while (@rr) {
		179	my $w = int rand $sum + 1;
		180	for (0 .. $#rr) {
		181	if (($w -= $rr[$_][1]) <= 0) {
		182	$sum -= $rr[$_][1];
		183	push @res, splice @rr, $_, 1, ();
		184	last;
		185	}
		186	}
		187	}
		188	}
		189
		190	$cb->(@res);
127	});	191	});
128	}	192	}
129		193
130	sub ptr($$) {	194	sub ptr($$) {
131	my ($ip, $cb) = @_;	195	my ($domain, $cb) = @_;
132		196
133	my $name;
134
135	if (AnyEvent::Util::dotted_quad $ip) {
136	$name = join ".", (reverse split /\./, $ip), "in-addr.arpa.";
137	} else {
138	require Socket6;
139	$name = join ".",
140	(reverse split //,
141	unpack "H*", Socket6::inet_pton (Socket::AF_INET6, $ip)),
142	"ip6.arpa.";
143	}
144
145	resolver->resolve ($name => "ptr", sub {	197	resolver->resolve ($domain => "ptr", sub {
146	$cb->(map $_->[3], @_);	198	$cb->(map $_->[3], @_);
147	});	199	});
148	}	200	}
149		201
		202	sub any($$) {
		203	my ($domain, $cb) = @_;
		204
		205	resolver->resolve ($domain => "*", $cb);
		206	}
		207
		208	# convert textual ip address into reverse lookup form
		209	sub _munge_ptr($) {
		210	my $ipn = $_[0]
		211	or return;
		212
		213	my $ptr;
		214
		215	my $af = AnyEvent::Socket::address_family ($ipn);
		216
		217	if ($af == AF_INET6) {
		218	$ipn = substr $ipn, 0, 16; # anticipate future expansion
		219
		220	# handle v4mapped and v4compat
		221	if ($ipn =~ s/^\x00{10}(?:\xff\xff\|\x00\x00)//) {
		222	$af = AF_INET;
		223	} else {
		224	$ptr = join ".", (reverse split //, unpack "H32", $ipn), "ip6.arpa.";
		225	}
		226	}
		227
		228	if ($af == AF_INET) {
		229	$ptr = join ".", (reverse unpack "C4", $ipn), "in-addr.arpa.";
		230	}
		231
		232	$ptr
		233	}
		234
		235	sub reverse_lookup($$) {
		236	my ($ip, $cb) = @_;
		237
		238	$ip = _munge_ptr AnyEvent::Socket::parse_address ($ip)
		239	or return $cb->();
		240
		241	resolver->resolve ($ip => "ptr", sub {
		242	$cb->(map $_->[3], @_);
		243	});
		244	}
		245
		246	sub reverse_verify($$) {
		247	my ($ip, $cb) = @_;
		248
		249	my $ipn = AnyEvent::Socket::parse_address ($ip)
		250	or return $cb->();
		251
		252	my $af = AnyEvent::Socket::address_family ($ipn);
		253
		254	my @res;
		255	my $cnt;
		256
		257	my $ptr = _munge_ptr $ipn
		258	or return $cb->();
		259
		260	$ip = AnyEvent::Socket::format_address ($ipn); # normalise into the same form
		261
		262	ptr $ptr, sub {
		263	for my $name (@_) {
		264	++$cnt;
		265
		266	# () around AF_INET to work around bug in 5.8
		267	resolver->resolve ("$name." => ($af == (AF_INET) ? "a" : "aaaa"), sub {
		268	for (@_) {
		269	push @res, $name
		270	if $_->[3] eq $ip;
		271	}
		272	$cb->(@res) unless --$cnt;
		273	});
		274	}
		275
		276	$cb->() unless $cnt;
		277	};
		278	}
		279
		280	#################################################################################
		281
		282	=back
		283
150	=head2 DNS EN-/DECODING FUNCTIONS	284	=head2 LOW-LEVEL DNS EN-/DECODING FUNCTIONS
151		285
152	=over 4	286	=over 4
153		287
		288	=item $AnyEvent::DNS::EDNS0
		289
		290	This variable decides whether dns_pack automatically enables EDNS0
		291	support. By default, this is disabled (C<0>), unless overridden by
		292	C<$ENV{PERL_ANYEVENT_EDNS0}>, but when set to C<1>, AnyEvent::DNS will use
		293	EDNS0 in all requests.
		294
154	=cut	295	=cut
		296
		297	our $EDNS0 = $ENV{PERL_ANYEVENT_EDNS0}*1; # set to 1 to enable (partial) edns0
155		298
156	our %opcode_id = (	299	our %opcode_id = (
157	query => 0,	300	query => 0,
158	iquery => 1,	301	iquery => 1,
159	status => 2,	302	status => 2,
		303	notify => 4,
		304	update => 5,
160	map +($_ => $_), 3..15	305	map +($_ => $_), 3, 6..15
161	);	306	);
162		307
163	our %opcode_str = reverse %opcode_id;	308	our %opcode_str = reverse %opcode_id;
164		309
165	our %rcode_id = (	310	our %rcode_id = (
166	noerror => 0,	311	noerror => 0,
167	formerr => 1,	312	formerr => 1,
168	servfail => 2,	313	servfail => 2,
169	nxdomain => 3,	314	nxdomain => 3,
170	notimp => 4,	315	notimp => 4,
171	refused => 5,	316	refused => 5,
		317	yxdomain => 6, # Name Exists when it should not [RFC 2136]
		318	yxrrset => 7, # RR Set Exists when it should not [RFC 2136]
		319	nxrrset => 8, # RR Set that should exist does not [RFC 2136]
		320	notauth => 9, # Server Not Authoritative for zone [RFC 2136]
		321	notzone => 10, # Name not contained in zone [RFC 2136]
		322	# EDNS0 16 BADVERS Bad OPT Version [RFC 2671]
		323	# EDNS0 16 BADSIG TSIG Signature Failure [RFC 2845]
		324	# EDNS0 17 BADKEY Key not recognized [RFC 2845]
		325	# EDNS0 18 BADTIME Signature out of time window [RFC 2845]
		326	# EDNS0 19 BADMODE Bad TKEY Mode [RFC 2930]
		327	# EDNS0 20 BADNAME Duplicate key name [RFC 2930]
		328	# EDNS0 21 BADALG Algorithm not supported [RFC 2930]
172	map +($_ => $_), 6..15	329	map +($_ => $_), 11..15
173	);	330	);
174		331
175	our %rcode_str = reverse %rcode_id;	332	our %rcode_str = reverse %rcode_id;
176		333
177	our %type_id = (	334	our %type_id = (
…		…
191	minfo => 14,	348	minfo => 14,
192	mx => 15,	349	mx => 15,
193	txt => 16,	350	txt => 16,
194	aaaa => 28,	351	aaaa => 28,
195	srv => 33,	352	srv => 33,
		353	naptr => 35, # rfc2915
		354	dname => 39, # rfc2672
		355	opt => 41,
		356	spf => 99,
		357	tkey => 249,
		358	tsig => 250,
		359	ixfr => 251,
196	axfr => 252,	360	axfr => 252,
197	mailb => 253,	361	mailb => 253,
198	"*" => 255,	362	"*" => 255,
199	);	363	);
200		364
201	our %type_str = reverse %type_id;	365	our %type_str = reverse %type_id;
202		366
203	our %class_id = (	367	our %class_id = (
204	in => 1,	368	in => 1,
205	ch => 3,	369	ch => 3,
206	hs => 4,	370	hs => 4,
		371	none => 254,
207	"*" => 255,	372	"*" => 255,
208	);	373	);
209		374
210	our %class_str = reverse %class_id;	375	our %class_str = reverse %class_id;
211		376
212	# names MUST have a trailing dot
213	sub _enc_qname($) {	377	sub _enc_name($) {
214	pack "(C/a)*", (split /\./, shift), ""	378	pack "(C/a)", (split /\./, shift), ""
		379	}
		380
		381	if ($[ < 5.008) {
		382	# special slower 5.6 version
		383	*_enc_name = sub {
		384	join "", map +(pack "C/a*", $_), (split /\./, shift), ""
		385	};
215	}	386	}
216		387
217	sub _enc_qd() {	388	sub _enc_qd() {
218	(_enc_qname $_->[0]) . pack "nn",	389	(_enc_name $_->[0]) . pack "nn",
219	($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}),	390	($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}),
220	($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] \|\| "in"})	391	($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] \|\| "in"})
221	}	392	}
222		393
223	sub _enc_rr() {	394	sub _enc_rr() {
224	die "encoding of resource records is not supported";	395	die "encoding of resource records is not supported";
225	}	396	}
226		397
227	=item $pkt = AnyEvent::DNS::dns_pack $dns	398	=item $pkt = AnyEvent::DNS::dns_pack $dns
228		399
229	Packs a perl data structure into a DNS packet. Reading RFC1034 is strongly	400	Packs a perl data structure into a DNS packet. Reading RFC 1035 is strongly
230	recommended, then everything will be totally clear. Or maybe not.	401	recommended, then everything will be totally clear. Or maybe not.
231		402
232	Resource records are not yet encodable.	403	Resource records are not yet encodable.
233		404
234	Examples:	405	Examples:
235		406
236	# very simple request, using lots of default values:	407	# very simple request, using lots of default values:
237	{ rd => 1, qd => [ [ "host.domain", "a"] ] }	408	{ rd => 1, qd => [ [ "host.domain", "a"] ] }
238		409
239	# more complex example, showing how flags etc. are named:	410	# more complex example, showing how flags etc. are named:
240		411
241	{	412	{
242	id => 10000,	413	id => 10000,
243	op => "query",	414	op => "query",
244	rc => "nxdomain",	415	rc => "nxdomain",
245		416
246	# flags	417	# flags
247	qr => 1,	418	qr => 1,
248	aa => 0,	419	aa => 0,
249	tc => 0,	420	tc => 0,
250	rd => 0,	421	rd => 0,
251	ra => 0,	422	ra => 0,
252		423	ad => 0,
		424	cd => 0,
		425
253	qd => [@rr], # query section	426	qd => [@rr], # query section
254	an => [@rr], # answer section	427	an => [@rr], # answer section
255	ns => [@rr], # authority section	428	ns => [@rr], # authority section
256	ar => [@rr], # additional records section	429	ar => [@rr], # additional records section
257	}	430	}
258		431
259	=cut	432	=cut
260		433
261	sub dns_pack($) {	434	sub dns_pack($) {
262	my ($req) = @_;	435	my ($req) = @_;
263		436
264	pack "nn nnnn a* a* a* a*",	437	pack "nn nnnn a* a* a* a* a*",
265	$req->{id},	438	$req->{id},
266		439
267	! !$req->{qr} * 0x8000	440	! !$req->{qr} * 0x8000
268	+ $opcode_id{$req->{op}} * 0x0800	441	+ $opcode_id{$req->{op}} * 0x0800
269	+ ! !$req->{aa} * 0x0400	442	+ ! !$req->{aa} * 0x0400
270	+ ! !$req->{tc} * 0x0200	443	+ ! !$req->{tc} * 0x0200
271	+ ! !$req->{rd} * 0x0100	444	+ ! !$req->{rd} * 0x0100
272	+ ! !$req->{ra} * 0x0080	445	+ ! !$req->{ra} * 0x0080
		446	+ ! !$req->{ad} * 0x0020
		447	+ ! !$req->{cd} * 0x0010
273	+ $rcode_id{$req->{rc}} * 0x0001,	448	+ $rcode_id{$req->{rc}} * 0x0001,
274		449
275	scalar @{ $req->{qd} \|\| [] },	450	scalar @{ $req->{qd} \|\| [] },
276	scalar @{ $req->{an} \|\| [] },	451	scalar @{ $req->{an} \|\| [] },
277	scalar @{ $req->{ns} \|\| [] },	452	scalar @{ $req->{ns} \|\| [] },
278	scalar @{ $req->{ar} \|\| [] },	453	$EDNS0 + scalar @{ $req->{ar} \|\| [] }, # EDNS0 option included here
279		454
280	(join "", map _enc_qd, @{ $req->{qd} \|\| [] }),	455	(join "", map _enc_qd, @{ $req->{qd} \|\| [] }),
281	(join "", map _enc_rr, @{ $req->{an} \|\| [] }),	456	(join "", map _enc_rr, @{ $req->{an} \|\| [] }),
282	(join "", map _enc_rr, @{ $req->{ns} \|\| [] }),	457	(join "", map _enc_rr, @{ $req->{ns} \|\| [] }),
283	(join "", map _enc_rr, @{ $req->{ar} \|\| [] });	458	(join "", map _enc_rr, @{ $req->{ar} \|\| [] }),
		459
		460	($EDNS0 ? pack "C nnNn", 0, 41, MAX_PKT, 0, 0 : "") # EDNS0 option
284	}	461	}
285		462
286	our $ofs;	463	our $ofs;
287	our $pkt;	464	our $pkt;
288		465
289	# bitches	466	# bitches
290	sub _dec_qname {	467	sub _dec_name {
291	my @res;	468	my @res;
292	my $redir;	469	my $redir;
293	my $ptr = $ofs;	470	my $ptr = $ofs;
294	my $cnt;	471	my $cnt;
295		472
296	while () {	473	while () {
297	return undef if ++$cnt >= 256; # to avoid DoS attacks	474	return undef if ++$cnt >= 256; # to avoid DoS attacks
298		475
299	my $len = ord substr $pkt, $ptr++, 1;	476	my $len = ord substr $pkt, $ptr++, 1;
300		477
301	if ($len & 0xc0) {	478	if ($len >= 0xc0) {
302	$ptr++;	479	$ptr++;
303	$ofs = $ptr if $ptr > $ofs;	480	$ofs = $ptr if $ptr > $ofs;
304	$ptr = (unpack "n", substr $pkt, $ptr - 2, 2) & 0x3fff;	481	$ptr = (unpack "n", substr $pkt, $ptr - 2, 2) & 0x3fff;
305	} elsif ($len) {	482	} elsif ($len) {
306	push @res, substr $pkt, $ptr, $len;	483	push @res, substr $pkt, $ptr, $len;
…		…
311	}	488	}
312	}	489	}
313	}	490	}
314		491
315	sub _dec_qd {	492	sub _dec_qd {
316	my $qname = _dec_qname;	493	my $qname = _dec_name;
317	my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;	494	my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;
318	[$qname, $type_str{$qt} \|\| $qt, $class_str{$qc} \|\| $qc]	495	[$qname, $type_str{$qt} \|\| $qt, $class_str{$qc} \|\| $qc]
319	}	496	}
320		497
321	our %dec_rr = (	498	our %dec_rr = (
322	1 => sub { Socket::inet_ntoa $_ }, # a	499	1 => sub { join ".", unpack "C4", $_ }, # a
323	2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns	500	2 => sub { local $ofs = $ofs - length; _dec_name }, # ns
324	5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname	501	5 => sub { local $ofs = $ofs - length; _dec_name }, # cname
325	6 => sub {	502	6 => sub {
326	local $ofs = $ofs - length;	503	local $ofs = $ofs - length;
327	my $mname = _dec_qname;	504	my $mname = _dec_name;
328	my $rname = _dec_qname;	505	my $rname = _dec_name;
329	($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)	506	($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)
330	}, # soa	507	}, # soa
331	11 => sub { ((Socket::inet_aton substr $_, 0, 4), unpack "C a*", substr $_, 4) }, # wks	508	11 => sub { ((join ".", unpack "C4", $_), unpack "C a*", substr $_, 4) }, # wks
332	12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr	509	12 => sub { local $ofs = $ofs - length; _dec_name }, # ptr
333	13 => sub { unpack "C/a C/a", $_ },	510	13 => sub { unpack "C/a* C/a*", $_ }, # hinfo
334	15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_qname) }, # mx	511	15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_name) }, # mx
335	16 => sub { unpack "C/a", $_ }, # txt	512	16 => sub { unpack "(C/a)", $_ }, # txt
336	28 => sub { sprintf "%04x:%04x:%04x:%04x:%04x:%04x:%04x:%04x", unpack "n8" }, # aaaa	513	28 => sub { AnyEvent::Socket::format_ipv6 ($_) }, # aaaa
337	33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_qname) }, # srv	514	33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_name) }, # srv
		515	35 => sub { # naptr
		516	# requires perl 5.10, sorry
		517	my ($order, $preference, $flags, $service, $regexp, $offset) = unpack "nn C/a* C/a* C/a* .", $_;
		518	local $ofs = $ofs + $offset - length;
		519	($order, $preference, $flags, $service, $regexp, _dec_name)
		520	},
		521	39 => sub { local $ofs = $ofs - length; _dec_name }, # dname
		522	99 => sub { unpack "(C/a)", $_ }, # spf
338	);	523	);
339		524
340	sub _dec_rr {	525	sub _dec_rr {
341	my $qname = _dec_qname;	526	my $name = _dec_name;
342		527
343	my ($rt, $rc, $ttl, $rdlen) = unpack "nn N n", substr $pkt, $ofs; $ofs += 10;	528	my ($rt, $rc, $ttl, $rdlen) = unpack "nn N n", substr $pkt, $ofs; $ofs += 10;
344	local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen;	529	local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen;
345		530
346	[	531	[
347	$qname,	532	$name,
348	$type_str{$rt} \|\| $rt,	533	$type_str{$rt} \|\| $rt,
349	$class_str{$rc} \|\| $rc,	534	$class_str{$rc} \|\| $rc,
350	($dec_rr{$rt} \|\| sub { $_ })->(),	535	($dec_rr{$rt} \|\| sub { $_ })->(),
351	]	536	]
352	}	537	}
…		…
355		540
356	Unpacks a DNS packet into a perl data structure.	541	Unpacks a DNS packet into a perl data structure.
357		542
358	Examples:	543	Examples:
359		544
360	# a non-successful reply	545	# an unsuccessful reply
361	{	546	{
362	'qd' => [	547	'qd' => [
363	[ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]	548	[ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]
364	],	549	],
365	'rc' => 'nxdomain',	550	'rc' => 'nxdomain',
366	'ar' => [],	551	'ar' => [],
367	'ns' => [	552	'ns' => [
368	[	553	[
369	'uni-karlsruhe.de',	554	'uni-karlsruhe.de',
370	'soa',	555	'soa',
371	'in',	556	'in',
372	'netserv.rz.uni-karlsruhe.de',	557	'netserv.rz.uni-karlsruhe.de',
373	'hostmaster.rz.uni-karlsruhe.de',	558	'hostmaster.rz.uni-karlsruhe.de',
374	2008052201,	559	2008052201, 10800, 1800, 2592000, 86400
375	10800,
376	1800,
377	2592000,
378	86400
379	]	560	]
380	],	561	],
381	'tc' => '',	562	'tc' => '',
382	'ra' => 1,	563	'ra' => 1,
383	'qr' => 1,	564	'qr' => 1,
384	'id' => 45915,	565	'id' => 45915,
385	'aa' => '',	566	'aa' => '',
386	'an' => [],	567	'an' => [],
387	'rd' => 1,	568	'rd' => 1,
388	'op' => 'query'	569	'op' => 'query'
389	}	570	}
390		571
391	# a successful reply	572	# a successful reply
392		573
393	{	574	{
394	'qd' => [ [ 'www.google.de', 'a', 'in' ] ],	575	'qd' => [ [ 'www.google.de', 'a', 'in' ] ],
395	'rc' => 0,	576	'rc' => 0,
396	'ar' => [	577	'ar' => [
397	[ 'a.l.google.com', 'a', 'in', '209.85.139.9' ],	578	[ 'a.l.google.com', 'a', 'in', '209.85.139.9' ],
398	[ 'b.l.google.com', 'a', 'in', '64.233.179.9' ],	579	[ 'b.l.google.com', 'a', 'in', '64.233.179.9' ],
399	[ 'c.l.google.com', 'a', 'in', '64.233.161.9' ],	580	[ 'c.l.google.com', 'a', 'in', '64.233.161.9' ],
400	],	581	],
401	'ns' => [	582	'ns' => [
402	[ 'l.google.com', 'ns', 'in', 'a.l.google.com' ],	583	[ 'l.google.com', 'ns', 'in', 'a.l.google.com' ],
403	[ 'l.google.com', 'ns', 'in', 'b.l.google.com' ],	584	[ 'l.google.com', 'ns', 'in', 'b.l.google.com' ],
404	],	585	],
405	'tc' => '',	586	'tc' => '',
406	'ra' => 1,	587	'ra' => 1,
407	'qr' => 1,	588	'qr' => 1,
408	'id' => 64265,	589	'id' => 64265,
409	'aa' => '',	590	'aa' => '',
410	'an' => [	591	'an' => [
411	[ 'www.google.de', 'cname', 'in', 'www.google.com' ],	592	[ 'www.google.de', 'cname', 'in', 'www.google.com' ],
412	[ 'www.google.com', 'cname', 'in', 'www.l.google.com' ],	593	[ 'www.google.com', 'cname', 'in', 'www.l.google.com' ],
413	[ 'www.l.google.com', 'a', 'in', '66.249.93.104' ],	594	[ 'www.l.google.com', 'a', 'in', '66.249.93.104' ],
414	[ 'www.l.google.com', 'a', 'in', '66.249.93.147' ],	595	[ 'www.l.google.com', 'a', 'in', '66.249.93.147' ],
415	],	596	],
416	'rd' => 1,	597	'rd' => 1,
417	'op' => 0	598	'op' => 0
418	}	599	}
419		600
420	=cut	601	=cut
421		602
422	sub dns_unpack($) {	603	sub dns_unpack($) {
423	local $pkt = shift;	604	local $pkt = shift;
…		…
431	qr => ! ! ($flags & 0x8000),	612	qr => ! ! ($flags & 0x8000),
432	aa => ! ! ($flags & 0x0400),	613	aa => ! ! ($flags & 0x0400),
433	tc => ! ! ($flags & 0x0200),	614	tc => ! ! ($flags & 0x0200),
434	rd => ! ! ($flags & 0x0100),	615	rd => ! ! ($flags & 0x0100),
435	ra => ! ! ($flags & 0x0080),	616	ra => ! ! ($flags & 0x0080),
		617	ad => ! ! ($flags & 0x0020),
		618	cd => ! ! ($flags & 0x0010),
436	op => $opcode_str{($flags & 0x001e) >> 11},	619	op => $opcode_str{($flags & 0x001e) >> 11},
437	rc => $rcode_str{($flags & 0x000f)},	620	rc => $rcode_str{($flags & 0x000f)},
438		621
439	qd => [map _dec_qd, 1 .. $qd],	622	qd => [map _dec_qd, 1 .. $qd],
440	an => [map _dec_rr, 1 .. $an],	623	an => [map _dec_rr, 1 .. $an],
…		…
447		630
448	=back	631	=back
449		632
450	=head2 THE AnyEvent::DNS RESOLVER CLASS	633	=head2 THE AnyEvent::DNS RESOLVER CLASS
451		634
452	This is the class which deos the actual protocol work.	635	This is the class which does the actual protocol work.
453		636
454	=over 4	637	=over 4
455		638
456	=cut	639	=cut
457		640
…		…
470	calls.	653	calls.
471		654
472	Unless you have special needs, prefer this function over creating your own	655	Unless you have special needs, prefer this function over creating your own
473	resolver object.	656	resolver object.
474		657
		658	The resolver is created with the following parameters:
		659
		660	untaint enabled
		661	max_outstanding $ENV{PERL_ANYEVENT_MAX_OUTSTANDING_DNS}
		662
		663	C<os_config> will be used for OS-specific configuration, unless
		664	C<$ENV{PERL_ANYEVENT_RESOLV_CONF}> is specified, in which case that file
		665	gets parsed.
		666
475	=cut	667	=cut
476		668
477	our $RESOLVER;	669	our $RESOLVER;
478		670
479	sub resolver() {	671	sub resolver() {
480	$RESOLVER \|\| do {	672	$RESOLVER \|\| do {
481	$RESOLVER = new AnyEvent::DNS;	673	$RESOLVER = new AnyEvent::DNS
		674	untaint => 1,
		675	exists $ENV{PERL_ANYEVENT_MAX_OUTSTANDING_DNS}
		676	? (max_outstanding => $ENV{PERL_ANYEVENT_MAX_OUTSTANDING_DNS}*1 \|\| 1) : (),
		677	;
		678
		679	exists $ENV{PERL_ANYEVENT_RESOLV_CONF}
		680	? length $ENV{PERL_ANYEVENT_RESOLV_CONF} && $RESOLVER->_parse_resolv_conf_file ($ENV{PERL_ANYEVENT_RESOLV_CONF})
482	$RESOLVER->load_resolv_conf;	681	: $RESOLVER->os_config;
		682
483	$RESOLVER	683	$RESOLVER
484	}	684	}
485	}	685	}
486		686
487	=item $resolver = new AnyEvent::DNS key => value...	687	=item $resolver = new AnyEvent::DNS key => value...
488		688
489	Creates and returns a new resolver. It only supports UDP, so make sure	689	Creates and returns a new resolver.
490	your answer sections fit into a DNS packet.
491		690
492	The following options are supported:	691	The following options are supported:
493		692
494	=over 4	693	=over 4
495		694
496	=item server => [...]	695	=item server => [...]
497		696
498	A list of server addressses (default C<v127.0.0.1>) in network format (4	697	A list of server addresses (default: C<v127.0.0.1>) in network format
499	octets for IPv4, 16 octets for IPv6 - not yet supported).	698	(i.e. as returned by C<AnyEvent::Socket::parse_address> - both IPv4 and
		699	IPv6 are supported).
500		700
501	=item timeout => [...]	701	=item timeout => [...]
502		702
503	A list of timeouts to use (also determines the number of retries). To make	703	A list of timeouts to use (also determines the number of retries). To make
504	three retries with individual time-outs of 2, 5 and 5 seconds, use C<[2,	704	three retries with individual time-outs of 2, 5 and 5 seconds, use C<[2,
…		…
513	The number of dots (default: C<1>) that a name must have so that the resolver	713	The number of dots (default: C<1>) that a name must have so that the resolver
514	tries to resolve the name without any suffixes first.	714	tries to resolve the name without any suffixes first.
515		715
516	=item max_outstanding => $integer	716	=item max_outstanding => $integer
517		717
518	Most name servers do not handle many parallel requests very well. This option	718	Most name servers do not handle many parallel requests very well. This
519	limits the numbe rof outstanding requests to C<$n> (default: C<10>), that means	719	option limits the number of outstanding requests to C<$integer>
520	if you request more than this many requests, then the additional requests will be queued	720	(default: C<10>), that means if you request more than this many requests,
521	until some other requests have been resolved.	721	then the additional requests will be queued until some other requests have
		722	been resolved.
		723
		724	=item reuse => $seconds
		725
		726	The number of seconds (default: C<300>) that a query id cannot be re-used
		727	after a timeout. If there was no time-out then query ids can be reused
		728	immediately.
		729
		730	=item untaint => $boolean
		731
		732	When true, then the resolver will automatically untaint results, and might
		733	also ignore certain environment variables.
522		734
523	=back	735	=back
524		736
525	=cut	737	=cut
526		738
527	sub new {	739	sub new {
528	my ($class, %arg) = @_;	740	my ($class, %arg) = @_;
529		741
530	socket my $fh, &Socket::AF_INET, &Socket::SOCK_DGRAM, 0
531	or Carp::croak "socket: $!";
532
533	AnyEvent::Util::fh_nonblocking $fh, 1;
534
535	my $self = bless {	742	my $self = bless {
536	server => [v127.0.0.1],	743	server => [],
537	timeout => [2, 5, 5],	744	timeout => [2, 5, 5],
538	search => [],	745	search => [],
539	ndots => 1,	746	ndots => 1,
540	max_outstanding => 10,	747	max_outstanding => 10,
541	reuse => 300, # reuse id's after 5 minutes only, if possible	748	reuse => 300,
542	%arg,	749	%arg,
543	fh => $fh,
544	reuse_q => [],	750	reuse_q => [],
545	}, $class;	751	}, $class;
546		752
547	# search should default to gethostname's domain	753	# search should default to gethostname's domain
548	# but perl lacks a good posix module	754	# but perl lacks a good posix module
549		755
		756	# try to create an ipv4 and an ipv6 socket
		757	# only fail when we cannot create either
		758	my $got_socket;
		759
550	Scalar::Util::weaken (my $wself = $self);	760	Scalar::Util::weaken (my $wself = $self);
		761
		762	if (socket my $fh4, AF_INET , &Socket::SOCK_DGRAM, 0) {
		763	++$got_socket;
		764
		765	AnyEvent::Util::fh_nonblocking $fh4, 1;
		766	$self->{fh4} = $fh4;
551	$self->{rw} = AnyEvent->io (fh => $fh, poll => "r", cb => sub { $wself->_recv });	767	$self->{rw4} = AnyEvent->io (fh => $fh4, poll => "r", cb => sub {
		768	if (my $peer = recv $fh4, my $pkt, MAX_PKT, 0) {
		769	$wself->_recv ($pkt, $peer);
		770	}
		771	});
		772	}
		773
		774	if (AF_INET6 && socket my $fh6, AF_INET6, &Socket::SOCK_DGRAM, 0) {
		775	++$got_socket;
		776
		777	$self->{fh6} = $fh6;
		778	AnyEvent::Util::fh_nonblocking $fh6, 1;
		779	$self->{rw6} = AnyEvent->io (fh => $fh6, poll => "r", cb => sub {
		780	if (my $peer = recv $fh6, my $pkt, MAX_PKT, 0) {
		781	$wself->_recv ($pkt, $peer);
		782	}
		783	});
		784	}
		785
		786	$got_socket
		787	or Carp::croak "unable to create either an IPv4 or an IPv6 socket";
552		788
553	$self->_compile;	789	$self->_compile;
554		790
555	$self	791	$self
556	}	792	}
557		793
558	=item $resolver->parse_resolv_conv ($string)	794	=item $resolver->parse_resolv_conf ($string)
559		795
560	Parses the given string a sif it were a F<resolv.conf> file. The following	796	Parses the given string as if it were a F<resolv.conf> file. The following
561	directives are supported:	797	directives are supported (but not necessarily implemented).
562		798
563	C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,	799	C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,
564	C<options> (C<timeout>, C<attempts>, C<ndots>).	800	C<options> (C<timeout>, C<attempts>, C<ndots>).
565		801
566	Everything else is silently ignored.	802	Everything else is silently ignored.
…		…
578	for (split /\n/, $resolvconf) {	814	for (split /\n/, $resolvconf) {
579	if (/^\s*#/) {	815	if (/^\s*#/) {
580	# comment	816	# comment
581	} elsif (/^\snameserver\s+(\S+)\s$/i) {	817	} elsif (/^\snameserver\s+(\S+)\s$/i) {
582	my $ip = $1;	818	my $ip = $1;
583	if (AnyEvent::Util::dotted_quad $ip) {	819	if (my $ipn = AnyEvent::Socket::parse_address ($ip)) {
584	push @{ $self->{server} }, AnyEvent::Util::socket_inet_aton $ip;	820	push @{ $self->{server} }, $ipn;
585	} else {	821	} else {
586	warn "nameserver $ip invalid and ignored\n";	822	warn "nameserver $ip invalid and ignored\n";
587	}	823	}
588	} elsif (/^\sdomain\s+(\S)\s+$/i) {	824	} elsif (/^\sdomain\s+(\S)\s+$/i) {
589	$self->{search} = [$1];	825	$self->{search} = [$1];
…		…
610	if $attempts;	846	if $attempts;
611		847
612	$self->_compile;	848	$self->_compile;
613	}	849	}
614		850
615	=item $resolver->load_resolv_conf	851	sub _parse_resolv_conf_file {
		852	my ($self, $resolv_conf) = @_;
616		853
617	Tries to load and parse F</etc/resolv.conf>. If there will ever be windows
618	support, then this function will do the right thing under windows, too.
619
620	=cut
621
622	sub load_resolv_conf {
623	my ($self) = @_;
624
625	open my $fh, "</etc/resolv.conf"	854	open my $fh, "<", $resolv_conf
626	or return;	855	or Carp::croak "$resolv_conf: $!";
627		856
628	local $/;	857	local $/;
629	$self->parse_resolv_conf (<$fh>);	858	$self->parse_resolv_conf (<$fh>);
630	}	859	}
631		860
		861	=item $resolver->os_config
		862
		863	Tries so load and parse F</etc/resolv.conf> on portable operating
		864	systems. Tries various egregious hacks on windows to force the DNS servers
		865	and searchlist out of the system.
		866
		867	=cut
		868
		869	sub os_config {
		870	my ($self) = @_;
		871
		872	$self->{server} = [];
		873	$self->{search} = [];
		874
		875	if ((AnyEvent::WIN32 \|\| $^O =~ /cygwin/i)) {
		876	no strict 'refs';
		877
		878	# there are many options to find the current nameservers etc. on windows
		879	# all of them don't work consistently:
		880	# - the registry thing needs separate code on win32 native vs. cygwin
		881	# - the registry layout differs between windows versions
		882	# - calling windows api functions doesn't work on cygwin
		883	# - ipconfig uses locale-specific messages
		884
		885	# we use ipconfig parsing because, despite all its brokenness,
		886	# it seems most stable in practise.
		887	# for good measure, we append a fallback nameserver to our list.
		888
		889	if (open my $fh, "ipconfig /all \|") {
		890	# parsing strategy: we go through the output and look for
		891	# :-lines with DNS in them. everything in those is regarded as
		892	# either a nameserver (if it parses as an ip address), or a suffix
		893	# (all else).
		894
		895	my $dns;
		896	while (<$fh>) {
		897	if (s/^\s.\bdns\b.://i) {
		898	$dns = 1;
		899	} elsif (/^\S/ \|\| /^\s[^:]{16,}: /) {
		900	$dns = 0;
		901	}
		902	if ($dns && /^\s(\S+)\s$/) {
		903	my $s = $1;
		904	$s =~ s/%\d+(?!\S)//; # get rid of ipv6 scope id
		905	if (my $ipn = AnyEvent::Socket::parse_address ($s)) {
		906	push @{ $self->{server} }, $ipn;
		907	} else {
		908	push @{ $self->{search} }, $s;
		909	}
		910	}
		911	}
		912
		913	# always add one fallback server
		914	push @{ $self->{server} }, $DNS_FALLBACK[rand @DNS_FALLBACK];
		915
		916	$self->_compile;
		917	}
		918	} else {
		919	# try resolv.conf everywhere else
		920
		921	$self->_parse_resolv_conf_file ("/etc/resolv.conf")
		922	if -e "/etc/resolv.conf";
		923	}
		924	}
		925
		926	=item $resolver->timeout ($timeout, ...)
		927
		928	Sets the timeout values. See the C<timeout> constructor argument (and note
		929	that this method uses the values itself, not an array-reference).
		930
		931	=cut
		932
		933	sub timeout {
		934	my ($self, @timeout) = @_;
		935
		936	$self->{timeout} = \@timeout;
		937	$self->_compile;
		938	}
		939
		940	=item $resolver->max_outstanding ($nrequests)
		941
		942	Sets the maximum number of outstanding requests to C<$nrequests>. See the
		943	C<max_outstanding> constructor argument.
		944
		945	=cut
		946
		947	sub max_outstanding {
		948	my ($self, $max) = @_;
		949
		950	$self->{max_outstanding} = $max;
		951	$self->_scheduler;
		952	}
		953
632	sub _compile {	954	sub _compile {
633	my $self = shift;	955	my $self = shift;
		956
		957	my %search; $self->{search} = [grep 0 < length, grep !$search{$_}++, @{ $self->{search} }];
		958	my %server; $self->{server} = [grep 0 < length, grep !$server{$_}++, @{ $self->{server} }];
		959
		960	unless (@{ $self->{server} }) {
		961	# use 127.0.0.1 by default, and one opendns nameserver as fallback
		962	$self->{server} = [v127.0.0.1, $DNS_FALLBACK[rand @DNS_FALLBACK]];
		963	}
634		964
635	my @retry;	965	my @retry;
636		966
637	for my $timeout (@{ $self->{timeout} }) {	967	for my $timeout (@{ $self->{timeout} }) {
638	for my $server (@{ $self->{server} }) {	968	for my $server (@{ $self->{server} }) {
…		…
641	}	971	}
642		972
643	$self->{retry} = \@retry;	973	$self->{retry} = \@retry;
644	}	974	}
645		975
		976	sub _feed {
		977	my ($self, $res) = @_;
		978
		979	($res) = $res =~ /^(.*)$/s
		980	if AnyEvent::TAINT && $self->{untaint};
		981
		982	$res = dns_unpack $res
		983	or return;
		984
		985	my $id = $self->{id}{$res->{id}};
		986
		987	return unless ref $id;
		988
		989	$NOW = time;
		990	$id->[1]->($res);
		991	}
		992
646	sub _recv {	993	sub _recv {
647	my ($self) = @_;	994	my ($self, $pkt, $peer) = @_;
648		995
649	while (my $peer = recv $self->{fh}, my $res, 1024, 0) {	996	# we ignore errors (often one gets port unreachable, but there is
		997	# no good way to take advantage of that.
		998
650	my ($port, $host) = Socket::unpack_sockaddr_in $peer;	999	my ($port, $host) = AnyEvent::Socket::unpack_sockaddr ($peer);
651		1000
652	return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };	1001	return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };
653		1002
654	$res = dns_unpack $res	1003	$self->_feed ($pkt);
655	or return;
656
657	my $id = $self->{id}{$res->{id}};
658
659	return unless ref $id;
660
661	$NOW = time;
662	$id->[1]->($res);
663	}
664	}	1004	}
665		1005
		1006	sub _free_id {
		1007	my ($self, $id, $timeout) = @_;
		1008
		1009	if ($timeout) {
		1010	# we need to block the id for a while
		1011	$self->{id}{$id} = 1;
		1012	push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $id];
		1013	} else {
		1014	# we can quickly recycle the id
		1015	delete $self->{id}{$id};
		1016	}
		1017
		1018	--$self->{outstanding};
		1019	$self->_scheduler;
		1020	}
		1021
		1022	# execute a single request, involves sending it with timeouts to multiple servers
666	sub _exec {	1023	sub _exec {
667	my ($self, $req, $retry) = @_;	1024	my ($self, $req) = @_;
668		1025
		1026	my $retry; # of retries
		1027	my $do_retry;
		1028
		1029	$do_retry = sub {
669	if (my $retry_cfg = $self->{retry}[$retry]) {	1030	my $retry_cfg = $self->{retry}[$retry++]
		1031	or do {
		1032	# failure
		1033	$self->_free_id ($req->[2], $retry > 1);
		1034	undef $do_retry; return $req->[1]->();
		1035	};
		1036
670	my ($server, $timeout) = @$retry_cfg;	1037	my ($server, $timeout) = @$retry_cfg;
671		1038
672	$self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {	1039	$self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {
673	$NOW = time;	1040	$NOW = time;
674		1041
675	# timeout, try next	1042	# timeout, try next
676	$self->_exec ($req, $retry + 1);	1043	&$do_retry if $do_retry;
677	}), sub {	1044	}), sub {
678	my ($res) = @_;	1045	my ($res) = @_;
679		1046
		1047	if ($res->{tc}) {
		1048	# success, but truncated, so use tcp
		1049	AnyEvent::Socket::tcp_connect (AnyEvent::Socket::format_address ($server), DOMAIN_PORT, sub {
		1050	return unless $do_retry; # some other request could have invalidated us already
		1051
		1052	my ($fh) = @_
		1053	or return &$do_retry;
		1054
		1055	require AnyEvent::Handle;
		1056
		1057	my $handle; $handle = new AnyEvent::Handle
		1058	fh => $fh,
		1059	timeout => $timeout,
		1060	on_error => sub {
		1061	undef $handle;
		1062	return unless $do_retry; # some other request could have invalidated us already
		1063	# failure, try next
		1064	&$do_retry;
		1065	};
		1066
		1067	$handle->push_write (pack "n/a", $req->[0]);
		1068	$handle->push_read (chunk => 2, sub {
		1069	$handle->unshift_read (chunk => (unpack "n", $_[1]), sub {
		1070	undef $handle;
		1071	$self->_feed ($_[1]);
		1072	});
		1073	});
		1074
		1075	}, sub { $timeout });
		1076
		1077	} else {
680	# success	1078	# success
681	$self->{id}{$req->[2]} = 1;	1079	$self->_free_id ($req->[2], $retry > 1);
682	push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];	1080	undef $do_retry; return $req->[1]->($res);
683	--$self->{outstanding};	1081	}
684	$self->_scheduler;
685
686	$req->[1]->($res);
687	}];	1082	}];
		1083
		1084	my $sa = AnyEvent::Socket::pack_sockaddr (DOMAIN_PORT, $server);
688		1085
689	send $self->{fh}, $req->[0], 0, Socket::pack_sockaddr_in 53, $server;	1086	my $fh = AF_INET == AnyEvent::Socket::sockaddr_family ($sa)
690	} else {	1087	? $self->{fh4} : $self->{fh6}
691	# failure	1088	or return &$do_retry;
692	$self->{id}{$req->[2]} = 1;
693	push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];
694	--$self->{outstanding};
695	$self->_scheduler;
696		1089
697	$req->[1]->();	1090	send $fh, $req->[0], 0, $sa;
698	}	1091	};
		1092
		1093	&$do_retry;
699	}	1094	}
700		1095
701	sub _scheduler {	1096	sub _scheduler {
702	my ($self) = @_;	1097	my ($self) = @_;
703		1098
		1099	no strict 'refs';
		1100
704	$NOW = time;	1101	$NOW = time;
705		1102
706	# first clear id reuse queue	1103	# first clear id reuse queue
707	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }	1104	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }
708	while @{ $self->{reuse_q} } && $self->{reuse_q}[0] <= $NOW;	1105	while @{ $self->{reuse_q} } && $self->{reuse_q}[0][0] <= $NOW;
709		1106
710	while ($self->{outstanding} < $self->{max_outstanding}) {	1107	while ($self->{outstanding} < $self->{max_outstanding}) {
711	my $req = shift @{ $self->{queue} }	1108
		1109	if (@{ $self->{reuse_q} } >= 30000) {
		1110	# we ran out of ID's, wait a bit
		1111	$self->{reuse_to} \|\|= AnyEvent->timer (after => $self->{reuse_q}[0][0] - $NOW, cb => sub {
		1112	delete $self->{reuse_to};
		1113	$self->_scheduler;
		1114	});
712	or last;	1115	last;
713
714	while () {
715	$req->[2] = int rand 65536;
716	last unless exists $self->{id}{$req->[2]};
717	}	1116	}
718		1117
		1118	if (my $req = shift @{ $self->{queue} }) {
		1119	# found a request in the queue, execute it
		1120	while () {
		1121	$req->[2] = int rand 65536;
		1122	last unless exists $self->{id}{$req->[2]};
		1123	}
		1124
		1125	++$self->{outstanding};
719	$self->{id}{$req->[2]} = 1;	1126	$self->{id}{$req->[2]} = 1;
720	substr $req->[0], 0, 2, pack "n", $req->[2];	1127	substr $req->[0], 0, 2, pack "n", $req->[2];
721		1128
722	++$self->{outstanding};
723	$self->_exec ($req, 0);	1129	$self->_exec ($req);
		1130
		1131	} elsif (my $cb = shift @{ $self->{wait} }) {
		1132	# found a wait_for_slot callback, call that one first
		1133	$cb->($self);
		1134
		1135	} else {
		1136	# nothing to do, just exit
		1137	last;
		1138	}
724	}	1139	}
725	}	1140	}
726		1141
727	=item $resolver->request ($req, $cb->($res))	1142	=item $resolver->request ($req, $cb->($res))
728		1143
		1144	This is the main low-level workhorse for sending DNS requests.
		1145
729	Sends a single request (a hash-ref formated as specified for	1146	This function sends a single request (a hash-ref formated as specified
730	C<dns_pack>) to the configured nameservers including	1147	for C<dns_pack>) to the configured nameservers in turn until it gets a
		1148	response. It handles timeouts, retries and automatically falls back to
		1149	virtual circuit mode (TCP) when it receives a truncated reply.
		1150
731	retries. Calls the callback with the decoded response packet if a reply	1151	Calls the callback with the decoded response packet if a reply was
732	was received, or no arguments on timeout.	1152	received, or no arguments in case none of the servers answered.
733		1153
734	=cut	1154	=cut
735		1155
736	sub request($$) {	1156	sub request($$) {
737	my ($self, $req, $cb) = @_;	1157	my ($self, $req, $cb) = @_;
738		1158
739	push @{ $self->{queue} }, [dns_pack $req, $cb];	1159	push @{ $self->{queue} }, [dns_pack $req, $cb];
740	$self->_scheduler;	1160	$self->_scheduler;
741	}	1161	}
742		1162
743	=item $resolver->resolve ($qname, $qtype, %options, $cb->($rcode, @rr))	1163	=item $resolver->resolve ($qname, $qtype, %options, $cb->(@rr))
744		1164
745	Queries the DNS for the given domain name C<$qname> of type C<$qtype> (a	1165	Queries the DNS for the given domain name C<$qname> of type C<$qtype>.
746	qtype of "*" is supported and means "any").	1166
		1167	A C<$qtype> is either a numerical query type (e.g. C<1> for A records) or
		1168	a lowercase name (you have to look at the source to see which aliases are
		1169	supported, but all types from RFC 1035, C<aaaa>, C<srv>, C<spf> and a few
		1170	more are known to this module). A C<$qtype> of "*" is supported and means
		1171	"any" record type.
747		1172
748	The callback will be invoked with a list of matching result records or	1173	The callback will be invoked with a list of matching result records or
749	none on any error or if the name could not be found.	1174	none on any error or if the name could not be found.
750		1175
751	CNAME chains (although illegal) are followed up to a length of 8.	1176	CNAME chains (although illegal) are followed up to a length of 10.
752		1177
		1178	The callback will be invoked with arraryefs of the form C<[$name, $type,
		1179	$class, @data>], where C<$name> is the domain name, C<$type> a type string
		1180	or number, C<$class> a class name and @data is resource-record-dependent
		1181	data. For C<a> records, this will be the textual IPv4 addresses, for C<ns>
		1182	or C<cname> records this will be a domain name, for C<txt> records these
		1183	are all the strings and so on.
		1184
		1185	All types mentioned in RFC 1035, C<aaaa>, C<srv>, C<naptr> and C<spf> are
		1186	decoded. All resource records not known to this module will have
		1187	the raw C<rdata> field as fourth entry.
		1188
753	Note that this resolver is just a stub resolver: it requires a nameserver	1189	Note that this resolver is just a stub resolver: it requires a name server
754	supporting recursive queries, will not do any recursive queries itself and	1190	supporting recursive queries, will not do any recursive queries itself and
755	is not secure when used against an untrusted name server.	1191	is not secure when used against an untrusted name server.
756		1192
757	The following options are supported:	1193	The following options are supported:
758		1194
…		…
760		1196
761	=item search => [$suffix...]	1197	=item search => [$suffix...]
762		1198
763	Use the given search list (which might be empty), by appending each one	1199	Use the given search list (which might be empty), by appending each one
764	in turn to the C<$qname>. If this option is missing then the configured	1200	in turn to the C<$qname>. If this option is missing then the configured
765	C<ndots> and C<search> define its value. If the C<$qname> ends in a dot,	1201	C<ndots> and C<search> values define its value (depending on C<ndots>, the
766	then the searchlist will be ignored.	1202	empty suffix will be prepended or appended to that C<search> value). If
		1203	the C<$qname> ends in a dot, then the searchlist will be ignored.
767		1204
768	=item accept => [$type...]	1205	=item accept => [$type...]
769		1206
770	Lists the acceptable result types: only result types in this set will be	1207	Lists the acceptable result types: only result types in this set will be
771	accepted and returned. The default includes the C<$qtype> and nothing	1208	accepted and returned. The default includes the C<$qtype> and nothing
772	else.	1209	else. If this list includes C<cname>, then CNAME-chains will not be
		1210	followed (because you asked for the CNAME record).
773		1211
774	=item class => "class"	1212	=item class => "class"
775		1213
776	Specify the query class ("in" for internet, "ch" for chaosnet and "hs" for	1214	Specify the query class ("in" for internet, "ch" for chaosnet and "hs" for
777	hesiod are the only ones making sense). The default is "in", of course.	1215	hesiod are the only ones making sense). The default is "in", of course.
778		1216
779	=back	1217	=back
780		1218
781	Examples:	1219	Examples:
782		1220
783	$res->resolve ("ruth.plan9.de", "a", sub {	1221	# full example, you can paste this into perl:
784	warn Dumper [@_];	1222	use Data::Dumper;
785	});	1223	use AnyEvent::DNS;
		1224	AnyEvent::DNS::resolver->resolve (
		1225	"google.com", "*", my $cv = AnyEvent->condvar);
		1226	warn Dumper [$cv->recv];
786		1227
		1228	# shortened result:
787	[	1229	# [
		1230	# [ 'google.com', 'soa', 'in', 'ns1.google.com', 'dns-admin.google.com',
		1231	# 2008052701, 7200, 1800, 1209600, 300 ],
788	[	1232	# [
789	'ruth.schmorp.de',	1233	# 'google.com', 'txt', 'in',
790	'a',	1234	# 'v=spf1 include:_netblocks.google.com ~all'
791	'in',	1235	# ],
792	'129.13.162.95'	1236	# [ 'google.com', 'a', 'in', '64.233.187.99' ],
		1237	# [ 'google.com', 'mx', 'in', 10, 'smtp2.google.com' ],
		1238	# [ 'google.com', 'ns', 'in', 'ns2.google.com' ],
793	]	1239	# ]
		1240
		1241	# resolve a records:
		1242	$res->resolve ("ruth.plan9.de", "a", sub { warn Dumper [@_] });
		1243
		1244	# result:
		1245	# [
		1246	# [ 'ruth.schmorp.de', 'a', 'in', '129.13.162.95' ]
794	]	1247	# ]
795		1248
		1249	# resolve any records, but return only a and aaaa records:
796	$res->resolve ("test1.laendle", "*",	1250	$res->resolve ("test1.laendle", "*",
797	accept => ["a", "aaaa"],	1251	accept => ["a", "aaaa"],
798	sub {	1252	sub {
799	warn Dumper [@_];	1253	warn Dumper [@_];
800	}	1254	}
801	);	1255	);
802		1256
803	[	1257	# result:
804	[	1258	# [
805	'test1.laendle',	1259	# [ 'test1.laendle', 'a', 'in', '10.0.0.255' ],
806	'a',	1260	# [ 'test1.laendle', 'aaaa', 'in', '3ffe:1900:4545:0002:0240:0000:0000:f7e1' ]
807	'in',
808	'10.0.0.255'
809	],
810	[
811	'test1.laendle',
812	'aaaa',
813	'in',
814	'3ffe:1900:4545:0002:0240:0000:0000:f7e1'
815	]	1261	# ]
816	]
817		1262
818	=cut	1263	=cut
819		1264
820	sub resolve($%) {	1265	sub resolve($%) {
821	my $cb = pop;	1266	my $cb = pop;
…		…
834	my %atype = $opt{accept}	1279	my %atype = $opt{accept}
835	? map +($_ => 1), @{ $opt{accept} }	1280	? map +($_ => 1), @{ $opt{accept} }
836	: ($qtype => 1);	1281	: ($qtype => 1);
837		1282
838	# advance in searchlist	1283	# advance in searchlist
839	my $do_search; $do_search = sub {	1284	my ($do_search, $do_req);
		1285
		1286	$do_search = sub {
840	@search	1287	@search
841	or return $cb->();	1288	or (undef $do_search), (undef $do_req), return $cb->();
842		1289
843	(my $name = lc "$qname." . shift @search) =~ s/\.$//;	1290	(my $name = lc "$qname." . shift @search) =~ s/\.$//;
844	my $depth = 2;	1291	my $depth = 10;
845		1292
846	# advance in cname-chain	1293	# advance in cname-chain
847	my $do_req; $do_req = sub {	1294	$do_req = sub {
848	$self->request ({	1295	$self->request ({
849	rd => 1,	1296	rd => 1,
850	qd => [[$name, $qtype, $class]],	1297	qd => [[$name, $qtype, $class]],
851	}, sub {	1298	}, sub {
852	my ($res) = @_	1299	my ($res) = @_
…		…
856		1303
857	while () {	1304	while () {
858	# results found?	1305	# results found?
859	my @rr = grep $name eq lc $_->[0] && ($atype{"*"} \|\| $atype{$_->[1]}), @{ $res->{an} };	1306	my @rr = grep $name eq lc $_->[0] && ($atype{"*"} \|\| $atype{$_->[1]}), @{ $res->{an} };
860		1307
861	return $cb->(@rr)	1308	(undef $do_search), (undef $do_req), return $cb->(@rr)
862	if @rr;	1309	if @rr;
863		1310
864	# see if there is a cname we can follow	1311	# see if there is a cname we can follow
865	my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} };	1312	my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} };
866		1313
867	if (@rr) {	1314	if (@rr) {
868	$depth--	1315	$depth--
869	or return $do_search->(); # cname chain too long	1316	or return $do_search->(); # cname chain too long
870		1317
871	$cname = 1;	1318	$cname = 1;
872	$name = $rr[0][3];	1319	$name = lc $rr[0][3];
873		1320
874	} elsif ($cname) {	1321	} elsif ($cname) {
875	# follow the cname	1322	# follow the cname
876	return $do_req->();	1323	return $do_req->();
877		1324
…		…
887	};	1334	};
888		1335
889	$do_search->();	1336	$do_search->();
890	}	1337	}
891		1338
		1339	=item $resolver->wait_for_slot ($cb->($resolver))
		1340
		1341	Wait until a free request slot is available and call the callback with the
		1342	resolver object.
		1343
		1344	A request slot is used each time a request is actually sent to the
		1345	nameservers: There are never more than C<max_outstanding> of them.
		1346
		1347	Although you can submit more requests (they will simply be queued until
		1348	a request slot becomes available), sometimes, usually for rate-limiting
		1349	purposes, it is useful to instead wait for a slot before generating the
		1350	request (or simply to know when the request load is low enough so one can
		1351	submit requests again).
		1352
		1353	This is what this method does: The callback will be called when submitting
		1354	a DNS request will not result in that request being queued. The callback
		1355	may or may not generate any requests in response.
		1356
		1357	Note that the callback will only be invoked when the request queue is
		1358	empty, so this does not play well if somebody else keeps the request queue
		1359	full at all times.
		1360
		1361	=cut
		1362
		1363	sub wait_for_slot {
		1364	my ($self, $cb) = @_;
		1365
		1366	push @{ $self->{wait} }, $cb;
		1367	$self->_scheduler;
		1368	}
		1369
		1370	use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end
		1371
892	1;	1372	1;
893		1373
894	=back	1374	=back
895		1375
896	=head1 AUTHOR	1376	=head1 AUTHOR
897		1377
898	Marc Lehmann <schmorp@schmorp.de>	1378	Marc Lehmann <schmorp@schmorp.de>
899	http://home.schmorp.de/	1379	http://home.schmorp.de/
900		1380
901	=cut	1381	=cut
902		1382

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.4 by root, Fri May 23 04:10:40 2008 UTC vs. Revision 1.110 by root, Sun Jul 26 00:17:25 2009 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.4 by root, Fri May 23 04:10:40 2008 UTC vs.
Revision 1.110 by root, Sun Jul 26 00:17:25 2009 UTC