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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.1 by root, Fri May 23 02:47:50 2008 UTC vs.
Revision 1.53 by root, Fri May 30 09:40:41 2008 UTC

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

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.1 by root, Fri May 23 02:47:50 2008 UTC vs. Revision 1.53 by root, Fri May 30 09:40:41 2008 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.1 by root, Fri May 23 02:47:50 2008 UTC vs.
Revision 1.53 by root, Fri May 30 09:40:41 2008 UTC