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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.3 by root, Fri May 23 03:20:53 2008 UTC vs.
Revision 1.52 by root, Fri May 30 08:17:10 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
16	# none yet
17		24
18	=over 4	25	=over 4
19		26
20	=cut	27	=cut
21		28
22	package AnyEvent::DNS;	29	package AnyEvent::DNS;
23		30
24	no warnings;	31	no warnings;
25	use strict;	32	use strict;
26		33
		34	use Socket qw(AF_INET SOCK_DGRAM SOCK_STREAM);
		35
27	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	#################################################################################
28		284
29	=back	285	=back
30		286
31	=head2 DNS EN-/DECODING FUNCTIONS	287	=head2 LOW-LEVEL DNS EN-/DECODING FUNCTIONS
32		288
33	=over 4	289	=over 4
34		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
35	=cut	298	=cut
		299
		300	our $EDNS0 = $ENV{PERL_ANYEVENT_EDNS0} * 1; # set to 1 to enable (partial) edns0
36		301
37	our %opcode_id = (	302	our %opcode_id = (
38	query => 0,	303	query => 0,
39	iquery => 1,	304	iquery => 1,
40	status => 2,	305	status => 2,
		306	notify => 4,
		307	update => 5,
41	map +($_ => $_), 3..15	308	map +($_ => $_), 3, 6..15
42	);	309	);
43		310
44	our %opcode_str = reverse %opcode_id;	311	our %opcode_str = reverse %opcode_id;
45		312
46	our %rcode_id = (	313	our %rcode_id = (
47	ok => 0,	314	noerror => 0,
48	formerr => 1,	315	formerr => 1,
49	servfail => 2,	316	servfail => 2,
50	nxdomain => 3,	317	nxdomain => 3,
51	notimp => 4,	318	notimp => 4,
52	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]
53	map +($_ => $_), 6..15	332	map +($_ => $_), 11..15
54	);	333	);
55		334
56	our %rcode_str = reverse %rcode_id;	335	our %rcode_str = reverse %rcode_id;
57		336
58	our %type_id = (	337	our %type_id = (
…		…
72	minfo => 14,	351	minfo => 14,
73	mx => 15,	352	mx => 15,
74	txt => 16,	353	txt => 16,
75	aaaa => 28,	354	aaaa => 28,
76	srv => 33,	355	srv => 33,
		356	naptr => 35, # rfc2915
		357	opt => 41,
		358	spf => 99,
		359	tkey => 249,
		360	tsig => 250,
		361	ixfr => 251,
77	axfr => 252,	362	axfr => 252,
78	mailb => 253,	363	mailb => 253,
79	"*" => 255,	364	"*" => 255,
80	);	365	);
81		366
82	our %type_str = reverse %type_id;	367	our %type_str = reverse %type_id;
83		368
84	our %class_id = (	369	our %class_id = (
85	in => 1,	370	in => 1,
86	ch => 3,	371	ch => 3,
87	hs => 4,	372	hs => 4,
		373	none => 254,
88	"*" => 255,	374	"*" => 255,
89	);	375	);
90		376
91	our %class_str = reverse %class_id;	377	our %class_str = reverse %class_id;
92		378
93	# names MUST have a trailing dot
94	sub _enc_qname($) {	379	sub _enc_name($) {
95	pack "(C/a)*", (split /\./, shift), ""	380	pack "(C/a)", (split /\./, shift), ""
96	}	381	}
97		382
98	sub _enc_qd() {	383	sub _enc_qd() {
99	(_enc_qname $_->[0]) . pack "nn",	384	(_enc_name $_->[0]) . pack "nn",
100	($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}),	385	($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}),
101	($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] \|\| "in"})	386	($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] \|\| "in"})
102	}	387	}
103		388
104	sub _enc_rr() {	389	sub _enc_rr() {
105	die "encoding of resource records is not supported";	390	die "encoding of resource records is not supported";
106	}	391	}
107		392
108	=item $pkt = AnyEvent::DNS::dns_pack $dns	393	=item $pkt = AnyEvent::DNS::dns_pack $dns
109		394
110	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
111	recommended, then everything will be totally clear. Or maybe not.	396	recommended, then everything will be totally clear. Or maybe not.
112		397
113	Resource records are not yet encodable.	398	Resource records are not yet encodable.
114		399
115	Examples:	400	Examples:
…		…
128	qr => 1,	413	qr => 1,
129	aa => 0,	414	aa => 0,
130	tc => 0,	415	tc => 0,
131	rd => 0,	416	rd => 0,
132	ra => 0,	417	ra => 0,
		418	ad => 0,
		419	cd => 0,
133		420
134	qd => [@rr], # query section	421	qd => [@rr], # query section
135	an => [@rr], # answer section	422	an => [@rr], # answer section
136	ns => [@rr], # authority section	423	ns => [@rr], # authority section
137	ar => [@rr], # additional records section	424	ar => [@rr], # additional records section
…		…
140	=cut	427	=cut
141		428
142	sub dns_pack($) {	429	sub dns_pack($) {
143	my ($req) = @_;	430	my ($req) = @_;
144		431
145	pack "nn nnnn a* a* a* a*",	432	pack "nn nnnn a* a* a* a* a*",
146	$req->{id},	433	$req->{id},
147		434
148	! !$req->{qr} * 0x8000	435	! !$req->{qr} * 0x8000
149	+ $opcode_id{$req->{op}} * 0x0800	436	+ $opcode_id{$req->{op}} * 0x0800
150	+ ! !$req->{aa} * 0x0400	437	+ ! !$req->{aa} * 0x0400
151	+ ! !$req->{tc} * 0x0200	438	+ ! !$req->{tc} * 0x0200
152	+ ! !$req->{rd} * 0x0100	439	+ ! !$req->{rd} * 0x0100
153	+ ! !$req->{ra} * 0x0080	440	+ ! !$req->{ra} * 0x0080
		441	+ ! !$req->{ad} * 0x0020
		442	+ ! !$req->{cd} * 0x0010
154	+ $rcode_id{$req->{rc}} * 0x0001,	443	+ $rcode_id{$req->{rc}} * 0x0001,
155		444
156	scalar @{ $req->{qd} \|\| [] },	445	scalar @{ $req->{qd} \|\| [] },
157	scalar @{ $req->{an} \|\| [] },	446	scalar @{ $req->{an} \|\| [] },
158	scalar @{ $req->{ns} \|\| [] },	447	scalar @{ $req->{ns} \|\| [] },
159	scalar @{ $req->{ar} \|\| [] },	448	$EDNS0 + scalar @{ $req->{ar} \|\| [] }, # EDNS0 option included here
160		449
161	(join "", map _enc_qd, @{ $req->{qd} \|\| [] }),	450	(join "", map _enc_qd, @{ $req->{qd} \|\| [] }),
162	(join "", map _enc_rr, @{ $req->{an} \|\| [] }),	451	(join "", map _enc_rr, @{ $req->{an} \|\| [] }),
163	(join "", map _enc_rr, @{ $req->{ns} \|\| [] }),	452	(join "", map _enc_rr, @{ $req->{ns} \|\| [] }),
164	(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
165	}	456	}
166		457
167	our $ofs;	458	our $ofs;
168	our $pkt;	459	our $pkt;
169		460
170	# bitches	461	# bitches
171	sub _dec_qname {	462	sub _dec_name {
172	my @res;	463	my @res;
173	my $redir;	464	my $redir;
174	my $ptr = $ofs;	465	my $ptr = $ofs;
175	my $cnt;	466	my $cnt;
176		467
177	while () {	468	while () {
178	return undef if ++$cnt >= 256; # to avoid DoS attacks	469	return undef if ++$cnt >= 256; # to avoid DoS attacks
179		470
180	my $len = ord substr $pkt, $ptr++, 1;	471	my $len = ord substr $pkt, $ptr++, 1;
181		472
182	if ($len & 0xc0) {	473	if ($len >= 0xc0) {
183	$ptr++;	474	$ptr++;
184	$ofs = $ptr if $ptr > $ofs;	475	$ofs = $ptr if $ptr > $ofs;
185	$ptr = (unpack "n", substr $pkt, $ptr - 2, 2) & 0x3fff;	476	$ptr = (unpack "n", substr $pkt, $ptr - 2, 2) & 0x3fff;
186	} elsif ($len) {	477	} elsif ($len) {
187	push @res, substr $pkt, $ptr, $len;	478	push @res, substr $pkt, $ptr, $len;
…		…
192	}	483	}
193	}	484	}
194	}	485	}
195		486
196	sub _dec_qd {	487	sub _dec_qd {
197	my $qname = _dec_qname;	488	my $qname = _dec_name;
198	my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;	489	my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;
199	[$qname, $type_str{$qt} \|\| $qt, $class_str{$qc} \|\| $qc]	490	[$qname, $type_str{$qt} \|\| $qt, $class_str{$qc} \|\| $qc]
200	}	491	}
201		492
202	our %dec_rr = (	493	our %dec_rr = (
203	1 => sub { Socket::inet_ntoa $_ }, # a	494	1 => sub { join ".", unpack "C4", $_ }, # a
204	2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns	495	2 => sub { local $ofs = $ofs - length; _dec_name }, # ns
205	5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname	496	5 => sub { local $ofs = $ofs - length; _dec_name }, # cname
206	6 => sub {	497	6 => sub {
207	local $ofs = $ofs - length;	498	local $ofs = $ofs - length;
208	my $mname = _dec_qname;	499	my $mname = _dec_name;
209	my $rname = _dec_qname;	500	my $rname = _dec_name;
210	($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)	501	($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)
211	}, # soa	502	}, # soa
212	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
213	12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr	504	12 => sub { local $ofs = $ofs - length; _dec_name }, # ptr
214	13 => sub { unpack "C/a C/a", $_ },	505	13 => sub { unpack "C/a* C/a*", $_ }, # hinfo
215	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
216	16 => sub { unpack "C/a", $_ }, # txt	507	16 => sub { unpack "(C/a)", $_ }, # txt
217	28 => sub { sprintf "%04x:%04x:%04x:%04x:%04x:%04x:%04x:%04x", unpack "n8" }, # aaaa	508	28 => sub { AnyEvent::Socket::format_address ($_) }, # aaaa
218	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
219	);	516	);
220		517
221	sub _dec_rr {	518	sub _dec_rr {
222	my $qname = _dec_qname;	519	my $name = _dec_name;
223		520
224	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;
225	local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen;	522	local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen;
226		523
227	[	524	[
228	$qname,	525	$name,
229	$type_str{$rt} \|\| $rt,	526	$type_str{$rt} \|\| $rt,
230	$class_str{$rc} \|\| $rc,	527	$class_str{$rc} \|\| $rc,
231	($dec_rr{$rt} \|\| sub { $_ })->(),	528	($dec_rr{$rt} \|\| sub { $_ })->(),
232	]	529	]
233	}	530	}
…		…
236		533
237	Unpacks a DNS packet into a perl data structure.	534	Unpacks a DNS packet into a perl data structure.
238		535
239	Examples:	536	Examples:
240		537
241	# a non-successful reply	538	# an unsuccessful reply
242	{	539	{
243	'qd' => [	540	'qd' => [
244	[ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]	541	[ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]
245	],	542	],
246	'rc' => 'nxdomain',	543	'rc' => 'nxdomain',
…		…
250	'uni-karlsruhe.de',	547	'uni-karlsruhe.de',
251	'soa',	548	'soa',
252	'in',	549	'in',
253	'netserv.rz.uni-karlsruhe.de',	550	'netserv.rz.uni-karlsruhe.de',
254	'hostmaster.rz.uni-karlsruhe.de',	551	'hostmaster.rz.uni-karlsruhe.de',
255	2008052201,	552	2008052201, 10800, 1800, 2592000, 86400
256	10800,
257	1800,
258	2592000,
259	86400
260	]	553	]
261	],	554	],
262	'tc' => '',	555	'tc' => '',
263	'ra' => 1,	556	'ra' => 1,
264	'qr' => 1,	557	'qr' => 1,
…		…
312	qr => ! ! ($flags & 0x8000),	605	qr => ! ! ($flags & 0x8000),
313	aa => ! ! ($flags & 0x0400),	606	aa => ! ! ($flags & 0x0400),
314	tc => ! ! ($flags & 0x0200),	607	tc => ! ! ($flags & 0x0200),
315	rd => ! ! ($flags & 0x0100),	608	rd => ! ! ($flags & 0x0100),
316	ra => ! ! ($flags & 0x0080),	609	ra => ! ! ($flags & 0x0080),
		610	ad => ! ! ($flags & 0x0020),
		611	cd => ! ! ($flags & 0x0010),
317	op => $opcode_str{($flags & 0x001e) >> 11},	612	op => $opcode_str{($flags & 0x001e) >> 11},
318	rc => $rcode_str{($flags & 0x000f)},	613	rc => $rcode_str{($flags & 0x000f)},
319		614
320	qd => [map _dec_qd, 1 .. $qd],	615	qd => [map _dec_qd, 1 .. $qd],
321	an => [map _dec_rr, 1 .. $an],	616	an => [map _dec_rr, 1 .. $an],
…		…
328		623
329	=back	624	=back
330		625
331	=head2 THE AnyEvent::DNS RESOLVER CLASS	626	=head2 THE AnyEvent::DNS RESOLVER CLASS
332		627
333	This is the class which deos the actual protocol work.	628	This is the class which does the actual protocol work.
334		629
335	=over 4	630	=over 4
336		631
337	=cut	632	=cut
338		633
…		…
358	our $RESOLVER;	653	our $RESOLVER;
359		654
360	sub resolver() {	655	sub resolver() {
361	$RESOLVER \|\| do {	656	$RESOLVER \|\| do {
362	$RESOLVER = new AnyEvent::DNS;	657	$RESOLVER = new AnyEvent::DNS;
363	$RESOLVER->load_resolv_conf;	658	$RESOLVER->os_config;
364	$RESOLVER	659	$RESOLVER
365	}	660	}
366	}	661	}
367		662
368	=item $resolver = new AnyEvent::DNS key => value...	663	=item $resolver = new AnyEvent::DNS key => value...
369		664
370	Creates and returns a new resolver. It only supports UDP, so make sure	665	Creates and returns a new resolver.
371	your answer sections fit into a DNS packet.
372		666
373	The following options are supported:	667	The following options are supported:
374		668
375	=over 4	669	=over 4
376		670
377	=item server => [...]	671	=item server => [...]
378		672
379	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
380	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).
381		676
382	=item timeout => [...]	677	=item timeout => [...]
383		678
384	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
385	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,
…		…
394	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
395	tries to resolve the name without any suffixes first.	690	tries to resolve the name without any suffixes first.
396		691
397	=item max_outstanding => $integer	692	=item max_outstanding => $integer
398		693
399	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
400	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>
401	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,
402	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.
403		705
404	=back	706	=back
405		707
406	=cut	708	=cut
407		709
408	sub new {	710	sub new {
409	my ($class, %arg) = @_;	711	my ($class, %arg) = @_;
410		712
		713	# try to create a ipv4 and an ipv6 socket
		714	# only fail when we cnanot create either
		715
411	socket my $fh, &Socket::AF_INET, &Socket::SOCK_DGRAM, 0	716	socket my $fh4, AF_INET , &Socket::SOCK_DGRAM, 0;
412	or Carp::croak "socket: $!";	717	socket my $fh6, AF_INET6, &Socket::SOCK_DGRAM, 0;
413		718
414	AnyEvent::Util::fh_nonblocking $fh, 1;	719	$fh4 \|\| $fh6
		720	or Carp::croak "unable to create either an IPv6 or an IPv4 socket";
415		721
416	my $self = bless {	722	my $self = bless {
417	server => [v127.0.0.1],	723	server => [],
418	timeout => [2, 5, 5],	724	timeout => [2, 5, 5],
419	search => [],	725	search => [],
420	ndots => 1,	726	ndots => 1,
421	max_outstanding => 10,	727	max_outstanding => 10,
422	reuse => 300, # reuse id's after 5 minutes only, if possible	728	reuse => 300, # reuse id's after 5 minutes only, if possible
423	%arg,	729	%arg,
424	fh => $fh,
425	reuse_q => [],	730	reuse_q => [],
426	}, $class;	731	}, $class;
427		732
428	# search should default to gethostname's domain	733	# search should default to gethostname's domain
429	# but perl lacks a good posix module	734	# but perl lacks a good posix module
430		735
431	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;
432	$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	}
433		757
434	$self->_compile;	758	$self->_compile;
435		759
436	$self	760	$self
437	}	761	}
438		762
439	=item $resolver->parse_resolv_conv ($string)	763	=item $resolver->parse_resolv_conv ($string)
440		764
441	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
442	directives are supported:	766	directives are supported (but not necessarily implemented).
443		767
444	C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,	768	C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,
445	C<options> (C<timeout>, C<attempts>, C<ndots>).	769	C<options> (C<timeout>, C<attempts>, C<ndots>).
446		770
447	Everything else is silently ignored.	771	Everything else is silently ignored.
…		…
459	for (split /\n/, $resolvconf) {	783	for (split /\n/, $resolvconf) {
460	if (/^\s*#/) {	784	if (/^\s*#/) {
461	# comment	785	# comment
462	} elsif (/^\snameserver\s+(\S+)\s$/i) {	786	} elsif (/^\snameserver\s+(\S+)\s$/i) {
463	my $ip = $1;	787	my $ip = $1;
464	if (AnyEvent::Util::dotted_quad $ip) {	788	if (my $ipn = AnyEvent::Socket::parse_address ($ip)) {
465	push @{ $self->{server} }, AnyEvent::Util::socket_inet_aton $ip;	789	push @{ $self->{server} }, $ipn;
466	} else {	790	} else {
467	warn "nameserver $ip invalid and ignored\n";	791	warn "nameserver $ip invalid and ignored\n";
468	}	792	}
469	} elsif (/^\sdomain\s+(\S)\s+$/i) {	793	} elsif (/^\sdomain\s+(\S)\s+$/i) {
470	$self->{search} = [$1];	794	$self->{search} = [$1];
…		…
491	if $attempts;	815	if $attempts;
492		816
493	$self->_compile;	817	$self->_compile;
494	}	818	}
495		819
496	=item $resolver->load_resolv_conf	820	=item $resolver->os_config
497		821
498	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
499	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.
500		824
501	=cut	825	=cut
502		826
503	sub load_resolv_conf {	827	sub os_config {
504	my ($self) = @_;	828	my ($self) = @_;
505		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
506	open my $fh, "</etc/resolv.conf"	879	if (open my $fh, "</etc/resolv.conf") {
507	or return;
508
509	local $/;	880	local $/;
510	$self->parse_resolv_conf (<$fh>);	881	$self->parse_resolv_conf (<$fh>);
		882	}
		883	}
511	}	884	}
512		885
513	sub _compile {	886	sub _compile {
514	my $self = shift;	887	my $self = shift;
		888
		889	my %search; $self->{search} = [grep 0 < length, grep !$search{$_}++, @{ $self->{search} }];
		890	my %server; $self->{server} = [grep 0 < length, grep !$server{$_}++, @{ $self->{server} }];
		891
		892	unless (@{ $self->{server} }) {
		893	# use 127.0.0.1 by default, and one opendns nameserver as fallback
		894	$self->{server} = [v127.0.0.1, $DNS_FALLBACK[rand @DNS_FALLBACK]];
		895	}
515		896
516	my @retry;	897	my @retry;
517		898
518	for my $timeout (@{ $self->{timeout} }) {	899	for my $timeout (@{ $self->{timeout} }) {
519	for my $server (@{ $self->{server} }) {	900	for my $server (@{ $self->{server} }) {
…		…
522	}	903	}
523		904
524	$self->{retry} = \@retry;	905	$self->{retry} = \@retry;
525	}	906	}
526		907
		908	sub _feed {
		909	my ($self, $res) = @_;
		910
		911	$res = dns_unpack $res
		912	or return;
		913
		914	my $id = $self->{id}{$res->{id}};
		915
		916	return unless ref $id;
		917
		918	$NOW = time;
		919	$id->[1]->($res);
		920	}
		921
527	sub _recv {	922	sub _recv {
528	my ($self) = @_;	923	my ($self, $pkt, $peer) = @_;
529		924
530	while (my $peer = recv $self->{fh}, my $res, 1024, 0) {	925	# we ignore errors (often one gets port unreachable, but there is
		926	# no good way to take advantage of that.
		927
531	my ($port, $host) = Socket::unpack_sockaddr_in $peer;	928	my ($port, $host) = AnyEvent::Socket::unpack_sockaddr ($peer);
532		929
533	return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };	930	return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };
534		931
535	$res = dns_unpack $res	932	$self->_feed ($pkt);
536	or return;	933	}
537		934
538	my $id = $self->{id}{$res->{id}};	935	sub _free_id {
		936	my ($self, $id, $timeout) = @_;
539		937
540	return unless ref $id;	938	if ($timeout) {
541		939	# we need to block the id for a while
542	$NOW = time;	940	$self->{id}{$id} = 1;
543	$id->[1]->($res);	941	push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $id];
		942	} else {
		943	# we can quickly recycle the id
		944	delete $self->{id}{$id};
544	}	945	}
545	}
546		946
		947	--$self->{outstanding};
		948	$self->_scheduler;
		949	}
		950
		951	# execute a single request, involves sending it with timeouts to multiple servers
547	sub _exec {	952	sub _exec {
548	my ($self, $req, $retry) = @_;	953	my ($self, $req) = @_;
549		954
		955	my $retry; # of retries
		956	my $do_retry;
		957
		958	$do_retry = sub {
550	if (my $retry_cfg = $self->{retry}[$retry]) {	959	my $retry_cfg = $self->{retry}[$retry++]
		960	or do {
		961	# failure
		962	$self->_free_id ($req->[2], $retry > 1);
		963	undef $do_retry; return $req->[1]->();
		964	};
		965
551	my ($server, $timeout) = @$retry_cfg;	966	my ($server, $timeout) = @$retry_cfg;
552		967
553	$self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {	968	$self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {
554	$NOW = time;	969	$NOW = time;
555		970
556	# timeout, try next	971	# timeout, try next
557	$self->_exec ($req, $retry + 1);	972	&$do_retry;
558	}), sub {	973	}), sub {
559	my ($res) = @_;	974	my ($res) = @_;
560		975
		976	if ($res->{tc}) {
		977	# success, but truncated, so use tcp
		978	AnyEvent::Socket::tcp_connect (AnyEvent::Socket::format_address ($server), DOMAIN_PORT, sub {
		979	return unless $do_retry; # some other request could have invalidated us already
		980
		981	my ($fh) = @_
		982	or return &$do_retry;
		983
		984	my $handle; $handle = new AnyEvent::Handle
		985	fh => $fh,
		986	timeout => $timeout,
		987	on_error => sub {
		988	undef $handle;
		989	return unless $do_retry; # some other request could have invalidated us already
		990	# failure, try next
		991	&$do_retry;
		992	};
		993
		994	$handle->push_write (pack "n/a", $req->[0]);
		995	$handle->push_read (chunk => 2, sub {
		996	$handle->unshift_read (chunk => (unpack "n", $_[1]), sub {
		997	undef $handle;
		998	$self->_feed ($_[1]);
		999	});
		1000	});
		1001
		1002	}, sub { $timeout });
		1003
		1004	} else {
561	# success	1005	# success
562	$self->{id}{$req->[2]} = 1;	1006	$self->_free_id ($req->[2], $retry > 1);
563	push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];	1007	undef $do_retry; return $req->[1]->($res);
564	--$self->{outstanding};	1008	}
565	$self->_scheduler;
566
567	$req->[1]->($res);
568	}];	1009	}];
		1010
		1011	my $sa = AnyEvent::Socket::pack_sockaddr (DOMAIN_PORT, $server);
569		1012
570	send $self->{fh}, $req->[0], 0, Socket::pack_sockaddr_in 53, $server;	1013	my $fh = AF_INET == Socket::sockaddr_family ($sa)
571	} else {	1014	? $self->{fh4} : $self->{fh6}
572	# failure	1015	or return &$do_retry;
573	$self->{id}{$req->[2]} = 1;
574	push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];
575	--$self->{outstanding};
576	$self->_scheduler;
577		1016
578	$req->[1]->();	1017	send $fh, $req->[0], 0, $sa;
579	}	1018	};
		1019
		1020	&$do_retry;
580	}	1021	}
581		1022
582	sub _scheduler {	1023	sub _scheduler {
583	my ($self) = @_;	1024	my ($self) = @_;
584		1025
		1026	no strict 'refs';
		1027
585	$NOW = time;	1028	$NOW = time;
586		1029
587	# first clear id reuse queue	1030	# first clear id reuse queue
588	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }	1031	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }
589	while @{ $self->{reuse_q} } && $self->{reuse_q}[0] <= $NOW;	1032	while @{ $self->{reuse_q} } && $self->{reuse_q}[0][0] <= $NOW;
590		1033
591	while ($self->{outstanding} < $self->{max_outstanding}) {	1034	while ($self->{outstanding} < $self->{max_outstanding}) {
592	my $req = shift @{ $self->{queue} }	1035
		1036	if (@{ $self->{reuse_q} } >= 30000) {
		1037	# we ran out of ID's, wait a bit
		1038	$self->{reuse_to} \|\|= AnyEvent->timer (after => $self->{reuse_q}[0][0] - $NOW, cb => sub {
		1039	delete $self->{reuse_to};
		1040	$self->_scheduler;
		1041	});
593	or last;	1042	last;
594
595	while () {
596	$req->[2] = int rand 65536;
597	last unless exists $self->{id}{$req->[2]};
598	}	1043	}
599		1044
		1045	if (my $req = shift @{ $self->{queue} }) {
		1046	# found a request in the queue, execute it
		1047	while () {
		1048	$req->[2] = int rand 65536;
		1049	last unless exists $self->{id}{$req->[2]};
		1050	}
		1051
		1052	++$self->{outstanding};
600	$self->{id}{$req->[2]} = 1;	1053	$self->{id}{$req->[2]} = 1;
601	substr $req->[0], 0, 2, pack "n", $req->[2];	1054	substr $req->[0], 0, 2, pack "n", $req->[2];
602		1055
603	++$self->{outstanding};
604	$self->_exec ($req, 0);	1056	$self->_exec ($req);
		1057
		1058	} elsif (my $cb = shift @{ $self->{wait} }) {
		1059	# found a wait_for_slot callback, call that one first
		1060	$cb->($self);
		1061
		1062	} else {
		1063	# nothing to do, just exit
		1064	last;
		1065	}
605	}	1066	}
606	}	1067	}
607		1068
608	=item $resolver->request ($req, $cb->($res))	1069	=item $resolver->request ($req, $cb->($res))
609		1070
…		…
621	$self->_scheduler;	1082	$self->_scheduler;
622	}	1083	}
623		1084
624	=item $resolver->resolve ($qname, $qtype, %options, $cb->($rcode, @rr))	1085	=item $resolver->resolve ($qname, $qtype, %options, $cb->($rcode, @rr))
625		1086
626	Queries the DNS for the given domain name C<$qname> of type C<$qtype> (a	1087	Queries the DNS for the given domain name C<$qname> of type C<$qtype>.
627	qtype of "*" is supported and means "any").	1088
		1089	A C<$qtype> is either a numerical query type (e.g. C<1> for A recods) or
		1090	a lowercase name (you have to look at the source to see which aliases are
		1091	supported, but all types from RFC 1035, C<aaaa>, C<srv>, C<spf> and a few
		1092	more are known to this module). A qtype of "*" is supported and means
		1093	"any" record type.
628		1094
629	The callback will be invoked with a list of matching result records or	1095	The callback will be invoked with a list of matching result records or
630	none on any error or if the name could not be found.	1096	none on any error or if the name could not be found.
631		1097
632	CNAME chains (although illegal) are followed up to a length of 8.	1098	CNAME chains (although illegal) are followed up to a length of 8.
633		1099
		1100	The callback will be invoked with an result code in string form (noerror,
		1101	formerr, servfail, nxdomain, notimp, refused and so on), or numerical
		1102	form if the result code is not supported. The remaining arguments are
		1103	arraryefs of the form C<[$name, $type, $class, @data>], where C<$name> is
		1104	the domain name, C<$type> a type string or number, C<$class> a class name
		1105	and @data is resource-record-dependent data. For C<a> records, this will
		1106	be the textual IPv4 addresses, for C<ns> or C<cname> records this will be
		1107	a domain name, for C<txt> records these are all the strings and so on.
		1108
		1109	All types mentioned in RFC 1035, C<aaaa>, C<srv> and C<spf> are
		1110	decoded. All resource records not known to this module will just return
		1111	the raw C<rdata> field as fourth entry.
		1112
634	Note that this resolver is just a stub resolver: it requires a nameserver	1113	Note that this resolver is just a stub resolver: it requires a name server
635	supporting recursive queries, will not do any recursive queries itself and	1114	supporting recursive queries, will not do any recursive queries itself and
636	is not secure when used against an untrusted name server.	1115	is not secure when used against an untrusted name server.
637		1116
638	The following options are supported:	1117	The following options are supported:
639		1118
…		…
648		1127
649	=item accept => [$type...]	1128	=item accept => [$type...]
650		1129
651	Lists the acceptable result types: only result types in this set will be	1130	Lists the acceptable result types: only result types in this set will be
652	accepted and returned. The default includes the C<$qtype> and nothing	1131	accepted and returned. The default includes the C<$qtype> and nothing
653	else.	1132	else. If this list includes C<cname>, then CNAME-chains will not be
		1133	followed (because you asked for the CNAME record).
654		1134
655	=item class => "class"	1135	=item class => "class"
656		1136
657	Specify the query class ("in" for internet, "ch" for chaosnet and "hs" for	1137	Specify the query class ("in" for internet, "ch" for chaosnet and "hs" for
658	hesiod are the only ones making sense). The default is "in", of course.	1138	hesiod are the only ones making sense). The default is "in", of course.
659		1139
660	=back	1140	=back
661		1141
662	Examples:	1142	Examples:
663		1143
664	$res->resolve ("ruth.plan9.de", "a", sub {	1144	# full example, you can paste this into perl:
665	warn Dumper [@_];	1145	use Data::Dumper;
666	});	1146	use AnyEvent::DNS;
		1147	AnyEvent::DNS::resolver->resolve (
		1148	"google.com", "*", my $cv = AnyEvent->condvar);
		1149	warn Dumper [$cv->recv];
667		1150
		1151	# shortened result:
668	[	1152	# [
		1153	# [ 'google.com', 'soa', 'in', 'ns1.google.com', 'dns-admin.google.com',
		1154	# 2008052701, 7200, 1800, 1209600, 300 ],
669	[	1155	# [
670	'ruth.schmorp.de',	1156	# 'google.com', 'txt', 'in',
671	'a',	1157	# 'v=spf1 include:_netblocks.google.com ~all'
672	'in',	1158	# ],
673	'129.13.162.95'	1159	# [ 'google.com', 'a', 'in', '64.233.187.99' ],
		1160	# [ 'google.com', 'mx', 'in', 10, 'smtp2.google.com' ],
		1161	# [ 'google.com', 'ns', 'in', 'ns2.google.com' ],
674	]	1162	# ]
		1163
		1164	# resolve a records:
		1165	$res->resolve ("ruth.plan9.de", "a", sub { warn Dumper [@_] });
		1166
		1167	# result:
		1168	# [
		1169	# [ 'ruth.schmorp.de', 'a', 'in', '129.13.162.95' ]
675	]	1170	# ]
676		1171
		1172	# resolve any records, but return only a and aaaa records:
677	$res->resolve ("test1.laendle", "*",	1173	$res->resolve ("test1.laendle", "*",
678	accept => ["a", "aaaa"],	1174	accept => ["a", "aaaa"],
679	sub {	1175	sub {
680	warn Dumper [@_];	1176	warn Dumper [@_];
681	}	1177	}
682	);	1178	);
683		1179
684	[	1180	# result:
685	[	1181	# [
686	'test1.laendle',	1182	# [ 'test1.laendle', 'a', 'in', '10.0.0.255' ],
687	'a',	1183	# [ 'test1.laendle', 'aaaa', 'in', '3ffe:1900:4545:0002:0240:0000:0000:f7e1' ]
688	'in',
689	'10.0.0.255'
690	],
691	[
692	'test1.laendle',
693	'aaaa',
694	'in',
695	'3ffe:1900:4545:0002:0240:0000:0000:f7e1'
696	]	1184	# ]
697	]
698		1185
699	=cut	1186	=cut
700		1187
701	sub resolve($%) {	1188	sub resolve($%) {
702	my $cb = pop;	1189	my $cb = pop;
…		…
715	my %atype = $opt{accept}	1202	my %atype = $opt{accept}
716	? map +($_ => 1), @{ $opt{accept} }	1203	? map +($_ => 1), @{ $opt{accept} }
717	: ($qtype => 1);	1204	: ($qtype => 1);
718		1205
719	# advance in searchlist	1206	# advance in searchlist
720	my $do_search; $do_search = sub {	1207	my ($do_search, $do_req);
		1208
		1209	$do_search = sub {
721	@search	1210	@search
722	or return $cb->();	1211	or (undef $do_search), (undef $do_req), return $cb->();
723		1212
724	(my $name = "$qname." . shift @search) =~ s/\.$//;	1213	(my $name = lc "$qname." . shift @search) =~ s/\.$//;
725	my $depth = 2;	1214	my $depth = 2;
726		1215
727	# advance in cname-chain	1216	# advance in cname-chain
728	my $do_req; $do_req = sub {	1217	$do_req = sub {
729	$self->request ({	1218	$self->request ({
730	rd => 1,	1219	rd => 1,
731	qd => [[$name, $qtype, $class]],	1220	qd => [[$name, $qtype, $class]],
732	}, sub {	1221	}, sub {
733	my ($res) = @_	1222	my ($res) = @_
…		…
735		1224
736	my $cname;	1225	my $cname;
737		1226
738	while () {	1227	while () {
739	# results found?	1228	# results found?
740	my @rr = grep $_->[0] eq $name && ($atype{"*"} \|\| $atype{$_->[1]}), @{ $res->{an} };	1229	my @rr = grep $name eq lc $_->[0] && ($atype{"*"} \|\| $atype{$_->[1]}), @{ $res->{an} };
741		1230
742	return $cb->(@rr)	1231	(undef $do_search), (undef $do_req), return $cb->(@rr)
743	if @rr;	1232	if @rr;
744		1233
745	# see if there is a cname we can follow	1234	# see if there is a cname we can follow
746	my @rr = grep $_->[0] eq $name && $_->[1] eq "cname", @{ $res->{an} };	1235	my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} };
747		1236
748	if (@rr) {	1237	if (@rr) {
749	$depth--	1238	$depth--
750	or return $do_search->(); # cname chain too long	1239	or return $do_search->(); # cname chain too long
751		1240
…		…
768	};	1257	};
769		1258
770	$do_search->();	1259	$do_search->();
771	}	1260	}
772		1261
		1262	=item $resolver->wait_for_slot ($cb->($resolver))
		1263
		1264	Wait until a free request slot is available and call the callback with the
		1265	resolver object.
		1266
		1267	A request slot is used each time a request is actually sent to the
		1268	nameservers: There are never more than C<max_outstanding> of them.
		1269
		1270	Although you can submit more requests (they will simply be queued until
		1271	a request slot becomes available), sometimes, usually for rate-limiting
		1272	purposes, it is useful to instead wait for a slot before generating the
		1273	request (or simply to know when the request load is low enough so one can
		1274	submit requests again).
		1275
		1276	This is what this method does: The callback will be called when submitting
		1277	a DNS request will not result in that request being queued. The callback
		1278	may or may not generate any requests in response.
		1279
		1280	Note that the callback will only be invoked when the request queue is
		1281	empty, so this does not play well if somebody else keeps the request queue
		1282	full at all times.
		1283
		1284	=cut
		1285
		1286	sub wait_for_slot {
		1287	my ($self, $cb) = @_;
		1288
		1289	push @{ $self->{wait} }, $cb;
		1290	$self->_scheduler;
		1291	}
		1292
		1293	use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end
		1294
773	1;	1295	1;
774		1296
775	=back	1297	=back
776		1298
777	=head1 AUTHOR	1299	=head1 AUTHOR

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.3 by root, Fri May 23 03:20:53 2008 UTC vs. Revision 1.52 by root, Fri May 30 08:17:10 2008 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.3 by root, Fri May 23 03:20:53 2008 UTC vs.
Revision 1.52 by root, Fri May 30 08:17:10 2008 UTC