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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.4 by root, Fri May 23 04:10:40 2008 UTC vs.
Revision 1.56 by root, Fri May 30 21:38:46 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	=over 4	25	=over 4
17		26
18	=cut	27	=cut
…		…
20	package AnyEvent::DNS;	29	package AnyEvent::DNS;
21		30
22	no warnings;	31	no warnings;
23	use strict;	32	use strict;
24		33
		34	use Socket qw(AF_INET SOCK_DGRAM SOCK_STREAM);
		35
25	use AnyEvent::Util ();	36	use AnyEvent ();
		37	use AnyEvent::Handle ();
		38	use AnyEvent::Util qw(AF_INET6);
26		39
27	=item AnyEvent::DNS::addr $node, $service, $family, $type, $cb->(@addrs)	40	our $VERSION = 4.1;
28		41
29	NOT YET IMPLEMENTED	42	our @DNS_FALLBACK = (v208.67.220.220, v208.67.222.222);
30
31	Tries to resolve the given nodename and service name into sockaddr
32	structures usable to connect to this node and service in a
33	protocol-independent way. It works similarly to the getaddrinfo posix
34	function.
35
36	Example:
37
38	AnyEvent::DNS::addr "google.com", "http", AF_UNSPEC, SOCK_STREAM, sub { ... };
39		43
40	=item AnyEvent::DNS::a $domain, $cb->(@addrs)	44	=item AnyEvent::DNS::a $domain, $cb->(@addrs)
41		45
42	Tries to resolve the given domain to IPv4 address(es).	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).
43		51
44	=item AnyEvent::DNS::mx $domain, $cb->(@hostnames)	52	=item AnyEvent::DNS::mx $domain, $cb->(@hostnames)
45		53
46	Tries to resolve the given domain into a sorted (lower preference value	54	Tries to resolve the given domain into a sorted (lower preference value
47	first) list of domain names.	55	first) list of domain names.
…		…
57	=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)	65	=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)
58		66
59	Tries to resolve the given service, protocol and domain name into a list	67	Tries to resolve the given service, protocol and domain name into a list
60	of service records.	68	of service records.
61		69
62	Each srv_rr is an arrayref with the following contents:	70	Each srv_rr is an array reference with the following contents:
63	C<[$priority, $weight, $transport, $target]>.	71	C<[$priority, $weight, $transport, $target]>.
64		72
65	They will be sorted with lowest priority, highest weight first (TODO:	73	They will be sorted with lowest priority first, then randomly
66	should use the rfc algorithm to reorder same-priority records for weight).	74	distributed by weight as per RFC 2782.
67		75
68	Example:	76	Example:
69		77
70	AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...	78	AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...
71	# @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )	79	# @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )
72		80
73	=item AnyEvent::DNS::ptr $ipv4_or_6, $cb->(@hostnames)	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)
74		93
75	Tries to reverse-resolve the given IPv4 or IPv6 address (in textual form)	94	Tries to reverse-resolve the given IPv4 or IPv6 address (in textual form)
76	into it's hostname(s).	95	into it's hostname(s). Handles V4MAPPED and V4COMPAT IPv6 addresses
		96	transparently.
77		97
78	Requires the Socket6 module for IPv6 support.	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.
79		108
80	Example:	109	Example:
81		110
82	AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };	111	AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };
83	# => f.root-servers.net	112	# => f.root-servers.net
84		113
85	=cut	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
86		119
87	sub resolver;	120	sub resolver;
88		121
89	sub a($$) {	122	sub a($$) {
90	my ($domain, $cb) = @_;	123	my ($domain, $cb) = @_;
…		…
92	resolver->resolve ($domain => "a", sub {	125	resolver->resolve ($domain => "a", sub {
93	$cb->(map $_->[3], @_);	126	$cb->(map $_->[3], @_);
94	});	127	});
95	}	128	}
96		129
		130	sub aaaa($$) {
		131	my ($domain, $cb) = @_;
		132
		133	resolver->resolve ($domain => "aaaa", sub {
		134	$cb->(map $_->[3], @_);
		135	});
		136	}
		137
97	sub mx($$) {	138	sub mx($$) {
98	my ($domain, $cb) = @_;	139	my ($domain, $cb) = @_;
99		140
100	resolver->resolve ($domain => "mx", sub {	141	resolver->resolve ($domain => "mx", sub {
101	$cb->(map $_->[4], sort { $a->[3] <=> $b->[3] } @_);	142	$cb->(map $_->[4], sort { $a->[3] <=> $b->[3] } @_);
…		…
121	sub srv($$$$) {	162	sub srv($$$$) {
122	my ($service, $proto, $domain, $cb) = @_;	163	my ($service, $proto, $domain, $cb) = @_;
123		164
124	# todo, ask for any and check glue records	165	# todo, ask for any and check glue records
125	resolver->resolve ("_$service._$proto.$domain" => "srv", sub {	166	resolver->resolve ("_$service._$proto.$domain" => "srv", sub {
126	$cb->(map [@$_[3,4,5,6]], sort { $a->[3] <=> $b->[3] \|\| $b->[4] <=> $a->[4] } @_);	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);
127	});	194	});
128	}	195	}
129		196
130	sub ptr($$) {	197	sub ptr($$) {
131	my ($ip, $cb) = @_;	198	my ($domain, $cb) = @_;
132		199
133	my $name;
134
135	if (AnyEvent::Util::dotted_quad $ip) {
136	$name = join ".", (reverse split /\./, $ip), "in-addr.arpa.";
137	} else {
138	require Socket6;
139	$name = join ".",
140	(reverse split //,
141	unpack "H*", Socket6::inet_pton (Socket::AF_INET6, $ip)),
142	"ip6.arpa.";
143	}
144
145	resolver->resolve ($name => "ptr", sub {	200	resolver->resolve ($domain => "ptr", sub {
146	$cb->(map $_->[3], @_);	201	$cb->(map $_->[3], @_);
147	});	202	});
148	}	203	}
149		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	#################################################################################
		284
		285	=back
		286
150	=head2 DNS EN-/DECODING FUNCTIONS	287	=head2 LOW-LEVEL DNS EN-/DECODING FUNCTIONS
151		288
152	=over 4	289	=over 4
153		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
154	=cut	298	=cut
		299
		300	our $EDNS0 = $ENV{PERL_ANYEVENT_EDNS0} * 1; # set to 1 to enable (partial) edns0
155		301
156	our %opcode_id = (	302	our %opcode_id = (
157	query => 0,	303	query => 0,
158	iquery => 1,	304	iquery => 1,
159	status => 2,	305	status => 2,
		306	notify => 4,
		307	update => 5,
160	map +($_ => $_), 3..15	308	map +($_ => $_), 3, 6..15
161	);	309	);
162		310
163	our %opcode_str = reverse %opcode_id;	311	our %opcode_str = reverse %opcode_id;
164		312
165	our %rcode_id = (	313	our %rcode_id = (
166	noerror => 0,	314	noerror => 0,
167	formerr => 1,	315	formerr => 1,
168	servfail => 2,	316	servfail => 2,
169	nxdomain => 3,	317	nxdomain => 3,
170	notimp => 4,	318	notimp => 4,
171	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]
172	map +($_ => $_), 6..15	332	map +($_ => $_), 11..15
173	);	333	);
174		334
175	our %rcode_str = reverse %rcode_id;	335	our %rcode_str = reverse %rcode_id;
176		336
177	our %type_id = (	337	our %type_id = (
…		…
191	minfo => 14,	351	minfo => 14,
192	mx => 15,	352	mx => 15,
193	txt => 16,	353	txt => 16,
194	aaaa => 28,	354	aaaa => 28,
195	srv => 33,	355	srv => 33,
		356	naptr => 35, # rfc2915
		357	opt => 41,
		358	spf => 99,
		359	tkey => 249,
		360	tsig => 250,
		361	ixfr => 251,
196	axfr => 252,	362	axfr => 252,
197	mailb => 253,	363	mailb => 253,
198	"*" => 255,	364	"*" => 255,
199	);	365	);
200		366
201	our %type_str = reverse %type_id;	367	our %type_str = reverse %type_id;
202		368
203	our %class_id = (	369	our %class_id = (
204	in => 1,	370	in => 1,
205	ch => 3,	371	ch => 3,
206	hs => 4,	372	hs => 4,
		373	none => 254,
207	"*" => 255,	374	"*" => 255,
208	);	375	);
209		376
210	our %class_str = reverse %class_id;	377	our %class_str = reverse %class_id;
211		378
212	# names MUST have a trailing dot
213	sub _enc_qname($) {	379	sub _enc_name($) {
214	pack "(C/a)*", (split /\./, shift), ""	380	pack "(C/a)", (split /\./, shift), ""
215	}	381	}
216		382
217	sub _enc_qd() {	383	sub _enc_qd() {
218	(_enc_qname $_->[0]) . pack "nn",	384	(_enc_name $_->[0]) . pack "nn",
219	($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}),	385	($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}),
220	($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] \|\| "in"})	386	($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] \|\| "in"})
221	}	387	}
222		388
223	sub _enc_rr() {	389	sub _enc_rr() {
224	die "encoding of resource records is not supported";	390	die "encoding of resource records is not supported";
225	}	391	}
226		392
227	=item $pkt = AnyEvent::DNS::dns_pack $dns	393	=item $pkt = AnyEvent::DNS::dns_pack $dns
228		394
229	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
230	recommended, then everything will be totally clear. Or maybe not.	396	recommended, then everything will be totally clear. Or maybe not.
231		397
232	Resource records are not yet encodable.	398	Resource records are not yet encodable.
233		399
234	Examples:	400	Examples:
…		…
247	qr => 1,	413	qr => 1,
248	aa => 0,	414	aa => 0,
249	tc => 0,	415	tc => 0,
250	rd => 0,	416	rd => 0,
251	ra => 0,	417	ra => 0,
		418	ad => 0,
		419	cd => 0,
252		420
253	qd => [@rr], # query section	421	qd => [@rr], # query section
254	an => [@rr], # answer section	422	an => [@rr], # answer section
255	ns => [@rr], # authority section	423	ns => [@rr], # authority section
256	ar => [@rr], # additional records section	424	ar => [@rr], # additional records section
…		…
259	=cut	427	=cut
260		428
261	sub dns_pack($) {	429	sub dns_pack($) {
262	my ($req) = @_;	430	my ($req) = @_;
263		431
264	pack "nn nnnn a* a* a* a*",	432	pack "nn nnnn a* a* a* a* a*",
265	$req->{id},	433	$req->{id},
266		434
267	! !$req->{qr} * 0x8000	435	! !$req->{qr} * 0x8000
268	+ $opcode_id{$req->{op}} * 0x0800	436	+ $opcode_id{$req->{op}} * 0x0800
269	+ ! !$req->{aa} * 0x0400	437	+ ! !$req->{aa} * 0x0400
270	+ ! !$req->{tc} * 0x0200	438	+ ! !$req->{tc} * 0x0200
271	+ ! !$req->{rd} * 0x0100	439	+ ! !$req->{rd} * 0x0100
272	+ ! !$req->{ra} * 0x0080	440	+ ! !$req->{ra} * 0x0080
		441	+ ! !$req->{ad} * 0x0020
		442	+ ! !$req->{cd} * 0x0010
273	+ $rcode_id{$req->{rc}} * 0x0001,	443	+ $rcode_id{$req->{rc}} * 0x0001,
274		444
275	scalar @{ $req->{qd} \|\| [] },	445	scalar @{ $req->{qd} \|\| [] },
276	scalar @{ $req->{an} \|\| [] },	446	scalar @{ $req->{an} \|\| [] },
277	scalar @{ $req->{ns} \|\| [] },	447	scalar @{ $req->{ns} \|\| [] },
278	scalar @{ $req->{ar} \|\| [] },	448	$EDNS0 + scalar @{ $req->{ar} \|\| [] }, # EDNS0 option included here
279		449
280	(join "", map _enc_qd, @{ $req->{qd} \|\| [] }),	450	(join "", map _enc_qd, @{ $req->{qd} \|\| [] }),
281	(join "", map _enc_rr, @{ $req->{an} \|\| [] }),	451	(join "", map _enc_rr, @{ $req->{an} \|\| [] }),
282	(join "", map _enc_rr, @{ $req->{ns} \|\| [] }),	452	(join "", map _enc_rr, @{ $req->{ns} \|\| [] }),
283	(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
284	}	456	}
285		457
286	our $ofs;	458	our $ofs;
287	our $pkt;	459	our $pkt;
288		460
289	# bitches	461	# bitches
290	sub _dec_qname {	462	sub _dec_name {
291	my @res;	463	my @res;
292	my $redir;	464	my $redir;
293	my $ptr = $ofs;	465	my $ptr = $ofs;
294	my $cnt;	466	my $cnt;
295		467
296	while () {	468	while () {
297	return undef if ++$cnt >= 256; # to avoid DoS attacks	469	return undef if ++$cnt >= 256; # to avoid DoS attacks
298		470
299	my $len = ord substr $pkt, $ptr++, 1;	471	my $len = ord substr $pkt, $ptr++, 1;
300		472
301	if ($len & 0xc0) {	473	if ($len >= 0xc0) {
302	$ptr++;	474	$ptr++;
303	$ofs = $ptr if $ptr > $ofs;	475	$ofs = $ptr if $ptr > $ofs;
304	$ptr = (unpack "n", substr $pkt, $ptr - 2, 2) & 0x3fff;	476	$ptr = (unpack "n", substr $pkt, $ptr - 2, 2) & 0x3fff;
305	} elsif ($len) {	477	} elsif ($len) {
306	push @res, substr $pkt, $ptr, $len;	478	push @res, substr $pkt, $ptr, $len;
…		…
311	}	483	}
312	}	484	}
313	}	485	}
314		486
315	sub _dec_qd {	487	sub _dec_qd {
316	my $qname = _dec_qname;	488	my $qname = _dec_name;
317	my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;	489	my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;
318	[$qname, $type_str{$qt} \|\| $qt, $class_str{$qc} \|\| $qc]	490	[$qname, $type_str{$qt} \|\| $qt, $class_str{$qc} \|\| $qc]
319	}	491	}
320		492
321	our %dec_rr = (	493	our %dec_rr = (
322	1 => sub { Socket::inet_ntoa $_ }, # a	494	1 => sub { join ".", unpack "C4", $_ }, # a
323	2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns	495	2 => sub { local $ofs = $ofs - length; _dec_name }, # ns
324	5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname	496	5 => sub { local $ofs = $ofs - length; _dec_name }, # cname
325	6 => sub {	497	6 => sub {
326	local $ofs = $ofs - length;	498	local $ofs = $ofs - length;
327	my $mname = _dec_qname;	499	my $mname = _dec_name;
328	my $rname = _dec_qname;	500	my $rname = _dec_name;
329	($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)	501	($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)
330	}, # soa	502	}, # soa
331	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
332	12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr	504	12 => sub { local $ofs = $ofs - length; _dec_name }, # ptr
333	13 => sub { unpack "C/a C/a", $_ },	505	13 => sub { unpack "C/a* C/a*", $_ }, # hinfo
334	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
335	16 => sub { unpack "C/a", $_ }, # txt	507	16 => sub { unpack "(C/a)", $_ }, # txt
336	28 => sub { sprintf "%04x:%04x:%04x:%04x:%04x:%04x:%04x:%04x", unpack "n8" }, # aaaa	508	28 => sub { AnyEvent::Socket::format_address ($_) }, # aaaa
337	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
338	);	516	);
339		517
340	sub _dec_rr {	518	sub _dec_rr {
341	my $qname = _dec_qname;	519	my $name = _dec_name;
342		520
343	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;
344	local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen;	522	local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen;
345		523
346	[	524	[
347	$qname,	525	$name,
348	$type_str{$rt} \|\| $rt,	526	$type_str{$rt} \|\| $rt,
349	$class_str{$rc} \|\| $rc,	527	$class_str{$rc} \|\| $rc,
350	($dec_rr{$rt} \|\| sub { $_ })->(),	528	($dec_rr{$rt} \|\| sub { $_ })->(),
351	]	529	]
352	}	530	}
…		…
355		533
356	Unpacks a DNS packet into a perl data structure.	534	Unpacks a DNS packet into a perl data structure.
357		535
358	Examples:	536	Examples:
359		537
360	# a non-successful reply	538	# an unsuccessful reply
361	{	539	{
362	'qd' => [	540	'qd' => [
363	[ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]	541	[ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]
364	],	542	],
365	'rc' => 'nxdomain',	543	'rc' => 'nxdomain',
…		…
369	'uni-karlsruhe.de',	547	'uni-karlsruhe.de',
370	'soa',	548	'soa',
371	'in',	549	'in',
372	'netserv.rz.uni-karlsruhe.de',	550	'netserv.rz.uni-karlsruhe.de',
373	'hostmaster.rz.uni-karlsruhe.de',	551	'hostmaster.rz.uni-karlsruhe.de',
374	2008052201,	552	2008052201, 10800, 1800, 2592000, 86400
375	10800,
376	1800,
377	2592000,
378	86400
379	]	553	]
380	],	554	],
381	'tc' => '',	555	'tc' => '',
382	'ra' => 1,	556	'ra' => 1,
383	'qr' => 1,	557	'qr' => 1,
…		…
431	qr => ! ! ($flags & 0x8000),	605	qr => ! ! ($flags & 0x8000),
432	aa => ! ! ($flags & 0x0400),	606	aa => ! ! ($flags & 0x0400),
433	tc => ! ! ($flags & 0x0200),	607	tc => ! ! ($flags & 0x0200),
434	rd => ! ! ($flags & 0x0100),	608	rd => ! ! ($flags & 0x0100),
435	ra => ! ! ($flags & 0x0080),	609	ra => ! ! ($flags & 0x0080),
		610	ad => ! ! ($flags & 0x0020),
		611	cd => ! ! ($flags & 0x0010),
436	op => $opcode_str{($flags & 0x001e) >> 11},	612	op => $opcode_str{($flags & 0x001e) >> 11},
437	rc => $rcode_str{($flags & 0x000f)},	613	rc => $rcode_str{($flags & 0x000f)},
438		614
439	qd => [map _dec_qd, 1 .. $qd],	615	qd => [map _dec_qd, 1 .. $qd],
440	an => [map _dec_rr, 1 .. $an],	616	an => [map _dec_rr, 1 .. $an],
…		…
447		623
448	=back	624	=back
449		625
450	=head2 THE AnyEvent::DNS RESOLVER CLASS	626	=head2 THE AnyEvent::DNS RESOLVER CLASS
451		627
452	This is the class which deos the actual protocol work.	628	This is the class which does the actual protocol work.
453		629
454	=over 4	630	=over 4
455		631
456	=cut	632	=cut
457		633
…		…
477	our $RESOLVER;	653	our $RESOLVER;
478		654
479	sub resolver() {	655	sub resolver() {
480	$RESOLVER \|\| do {	656	$RESOLVER \|\| do {
481	$RESOLVER = new AnyEvent::DNS;	657	$RESOLVER = new AnyEvent::DNS;
482	$RESOLVER->load_resolv_conf;	658	$RESOLVER->os_config;
483	$RESOLVER	659	$RESOLVER
484	}	660	}
485	}	661	}
486		662
487	=item $resolver = new AnyEvent::DNS key => value...	663	=item $resolver = new AnyEvent::DNS key => value...
488		664
489	Creates and returns a new resolver. It only supports UDP, so make sure	665	Creates and returns a new resolver.
490	your answer sections fit into a DNS packet.
491		666
492	The following options are supported:	667	The following options are supported:
493		668
494	=over 4	669	=over 4
495		670
496	=item server => [...]	671	=item server => [...]
497		672
498	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
499	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).
500		676
501	=item timeout => [...]	677	=item timeout => [...]
502		678
503	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
504	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,
…		…
513	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
514	tries to resolve the name without any suffixes first.	690	tries to resolve the name without any suffixes first.
515		691
516	=item max_outstanding => $integer	692	=item max_outstanding => $integer
517		693
518	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
519	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>
520	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,
521	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 was no time-out then query ids can be reused
		704	immediately.
522		705
523	=back	706	=back
524		707
525	=cut	708	=cut
526		709
527	sub new {	710	sub new {
528	my ($class, %arg) = @_;	711	my ($class, %arg) = @_;
529		712
		713	# try to create a ipv4 and an ipv6 socket
		714	# only fail when we cnanot create either
		715
530	socket my $fh, &Socket::AF_INET, &Socket::SOCK_DGRAM, 0	716	socket my $fh4, AF_INET , &Socket::SOCK_DGRAM, 0;
531	or Carp::croak "socket: $!";	717	socket my $fh6, AF_INET6, &Socket::SOCK_DGRAM, 0;
532		718
533	AnyEvent::Util::fh_nonblocking $fh, 1;	719	$fh4 \|\| $fh6
		720	or Carp::croak "unable to create either an IPv6 or an IPv4 socket";
534		721
535	my $self = bless {	722	my $self = bless {
536	server => [v127.0.0.1],	723	server => [],
537	timeout => [2, 5, 5],	724	timeout => [2, 5, 5],
538	search => [],	725	search => [],
539	ndots => 1,	726	ndots => 1,
540	max_outstanding => 10,	727	max_outstanding => 10,
541	reuse => 300, # reuse id's after 5 minutes only, if possible	728	reuse => 300,
542	%arg,	729	%arg,
543	fh => $fh,
544	reuse_q => [],	730	reuse_q => [],
545	}, $class;	731	}, $class;
546		732
547	# search should default to gethostname's domain	733	# search should default to gethostname's domain
548	# but perl lacks a good posix module	734	# but perl lacks a good posix module
549		735
550	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;
551	$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	}
552		757
553	$self->_compile;	758	$self->_compile;
554		759
555	$self	760	$self
556	}	761	}
557		762
558	=item $resolver->parse_resolv_conv ($string)	763	=item $resolver->parse_resolv_conv ($string)
559		764
560	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
561	directives are supported:	766	directives are supported (but not necessarily implemented).
562		767
563	C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,	768	C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,
564	C<options> (C<timeout>, C<attempts>, C<ndots>).	769	C<options> (C<timeout>, C<attempts>, C<ndots>).
565		770
566	Everything else is silently ignored.	771	Everything else is silently ignored.
…		…
578	for (split /\n/, $resolvconf) {	783	for (split /\n/, $resolvconf) {
579	if (/^\s*#/) {	784	if (/^\s*#/) {
580	# comment	785	# comment
581	} elsif (/^\snameserver\s+(\S+)\s$/i) {	786	} elsif (/^\snameserver\s+(\S+)\s$/i) {
582	my $ip = $1;	787	my $ip = $1;
583	if (AnyEvent::Util::dotted_quad $ip) {	788	if (my $ipn = AnyEvent::Socket::parse_address ($ip)) {
584	push @{ $self->{server} }, AnyEvent::Util::socket_inet_aton $ip;	789	push @{ $self->{server} }, $ipn;
585	} else {	790	} else {
586	warn "nameserver $ip invalid and ignored\n";	791	warn "nameserver $ip invalid and ignored\n";
587	}	792	}
588	} elsif (/^\sdomain\s+(\S)\s+$/i) {	793	} elsif (/^\sdomain\s+(\S)\s+$/i) {
589	$self->{search} = [$1];	794	$self->{search} = [$1];
…		…
610	if $attempts;	815	if $attempts;
611		816
612	$self->_compile;	817	$self->_compile;
613	}	818	}
614		819
615	=item $resolver->load_resolv_conf	820	=item $resolver->os_config
616		821
617	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
618	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.
619		824
620	=cut	825	=cut
621		826
622	sub load_resolv_conf {	827	sub os_config {
623	my ($self) = @_;	828	my ($self) = @_;
624		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 its 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 ipv6 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
625	open my $fh, "</etc/resolv.conf"	879	if (open my $fh, "</etc/resolv.conf") {
626	or return;
627
628	local $/;	880	local $/;
629	$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 itself, 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;
630	}	912	}
631		913
632	sub _compile {	914	sub _compile {
633	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	}
634		924
635	my @retry;	925	my @retry;
636		926
637	for my $timeout (@{ $self->{timeout} }) {	927	for my $timeout (@{ $self->{timeout} }) {
638	for my $server (@{ $self->{server} }) {	928	for my $server (@{ $self->{server} }) {
…		…
641	}	931	}
642		932
643	$self->{retry} = \@retry;	933	$self->{retry} = \@retry;
644	}	934	}
645		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
646	sub _recv {	950	sub _recv {
647	my ($self) = @_;	951	my ($self, $pkt, $peer) = @_;
648		952
649	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
650	my ($port, $host) = Socket::unpack_sockaddr_in $peer;	956	my ($port, $host) = AnyEvent::Socket::unpack_sockaddr ($peer);
651		957
652	return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };	958	return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };
653		959
654	$res = dns_unpack $res	960	$self->_feed ($pkt);
655	or return;	961	}
656		962
657	my $id = $self->{id}{$res->{id}};	963	sub _free_id {
		964	my ($self, $id, $timeout) = @_;
658		965
659	return unless ref $id;	966	if ($timeout) {
660		967	# we need to block the id for a while
661	$NOW = time;	968	$self->{id}{$id} = 1;
662	$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};
663	}	973	}
664	}
665		974
		975	--$self->{outstanding};
		976	$self->_scheduler;
		977	}
		978
		979	# execute a single request, involves sending it with timeouts to multiple servers
666	sub _exec {	980	sub _exec {
667	my ($self, $req, $retry) = @_;	981	my ($self, $req) = @_;
668		982
		983	my $retry; # of retries
		984	my $do_retry;
		985
		986	$do_retry = sub {
669	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
670	my ($server, $timeout) = @$retry_cfg;	994	my ($server, $timeout) = @$retry_cfg;
671		995
672	$self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {	996	$self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {
673	$NOW = time;	997	$NOW = time;
674		998
675	# timeout, try next	999	# timeout, try next
676	$self->_exec ($req, $retry + 1);	1000	&$do_retry;
677	}), sub {	1001	}), sub {
678	my ($res) = @_;	1002	my ($res) = @_;
679		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 {
680	# success	1033	# success
681	$self->{id}{$req->[2]} = 1;	1034	$self->_free_id ($req->[2], $retry > 1);
682	push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];	1035	undef $do_retry; return $req->[1]->($res);
683	--$self->{outstanding};	1036	}
684	$self->_scheduler;
685
686	$req->[1]->($res);
687	}];	1037	}];
		1038
		1039	my $sa = AnyEvent::Socket::pack_sockaddr (DOMAIN_PORT, $server);
688		1040
689	send $self->{fh}, $req->[0], 0, Socket::pack_sockaddr_in 53, $server;	1041	my $fh = AF_INET == Socket::sockaddr_family ($sa)
690	} else {	1042	? $self->{fh4} : $self->{fh6}
691	# failure	1043	or return &$do_retry;
692	$self->{id}{$req->[2]} = 1;
693	push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];
694	--$self->{outstanding};
695	$self->_scheduler;
696		1044
697	$req->[1]->();	1045	send $fh, $req->[0], 0, $sa;
698	}	1046	};
		1047
		1048	&$do_retry;
699	}	1049	}
700		1050
701	sub _scheduler {	1051	sub _scheduler {
702	my ($self) = @_;	1052	my ($self) = @_;
703		1053
		1054	no strict 'refs';
		1055
704	$NOW = time;	1056	$NOW = time;
705		1057
706	# first clear id reuse queue	1058	# first clear id reuse queue
707	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }	1059	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }
708	while @{ $self->{reuse_q} } && $self->{reuse_q}[0] <= $NOW;	1060	while @{ $self->{reuse_q} } && $self->{reuse_q}[0][0] <= $NOW;
709		1061
710	while ($self->{outstanding} < $self->{max_outstanding}) {	1062	while ($self->{outstanding} < $self->{max_outstanding}) {
711	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	});
712	or last;	1070	last;
713
714	while () {
715	$req->[2] = int rand 65536;
716	last unless exists $self->{id}{$req->[2]};
717	}	1071	}
718		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};
719	$self->{id}{$req->[2]} = 1;	1081	$self->{id}{$req->[2]} = 1;
720	substr $req->[0], 0, 2, pack "n", $req->[2];	1082	substr $req->[0], 0, 2, pack "n", $req->[2];
721		1083
722	++$self->{outstanding};
723	$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	}
724	}	1094	}
725	}	1095	}
726		1096
727	=item $resolver->request ($req, $cb->($res))	1097	=item $resolver->request ($req, $cb->($res))
728		1098
		1099	This is the main low-level workhorse for sending DNS requests.
		1100
729	Sends a single request (a hash-ref formated as specified for	1101	This function sends a single request (a hash-ref formated as specified
730	C<dns_pack>) to the configured nameservers including	1102	for C<dns_pack>) to the configured nameservers in turn until it gets a
		1103	response. It handles timeouts, retries and automatically falls back to
		1104	virtual circuit mode (TCP) when it receives a truncated reply.
		1105
731	retries. Calls the callback with the decoded response packet if a reply	1106	Calls the callback with the decoded response packet if a reply was
732	was received, or no arguments on timeout.	1107	received, or no arguments in case none of the servers answered.
733		1108
734	=cut	1109	=cut
735		1110
736	sub request($$) {	1111	sub request($$) {
737	my ($self, $req, $cb) = @_;	1112	my ($self, $req, $cb) = @_;
…		…
740	$self->_scheduler;	1115	$self->_scheduler;
741	}	1116	}
742		1117
743	=item $resolver->resolve ($qname, $qtype, %options, $cb->($rcode, @rr))	1118	=item $resolver->resolve ($qname, $qtype, %options, $cb->($rcode, @rr))
744		1119
745	Queries the DNS for the given domain name C<$qname> of type C<$qtype> (a	1120	Queries the DNS for the given domain name C<$qname> of type C<$qtype>.
746	qtype of "*" is supported and means "any").	1121
		1122	A C<$qtype> is either a numerical query type (e.g. C<1> for A records) or
		1123	a lowercase name (you have to look at the source to see which aliases are
		1124	supported, but all types from RFC 1035, C<aaaa>, C<srv>, C<spf> and a few
		1125	more are known to this module). A C<$qtype> of "*" is supported and means
		1126	"any" record type.
747		1127
748	The callback will be invoked with a list of matching result records or	1128	The callback will be invoked with a list of matching result records or
749	none on any error or if the name could not be found.	1129	none on any error or if the name could not be found.
750		1130
751	CNAME chains (although illegal) are followed up to a length of 8.	1131	CNAME chains (although illegal) are followed up to a length of 8.
752		1132
		1133	The callback will be invoked with an result code in string form (noerror,
		1134	formerr, servfail, nxdomain, notimp, refused and so on), or numerical
		1135	form if the result code is not supported. The remaining arguments are
		1136	arraryefs of the form C<[$name, $type, $class, @data>], where C<$name> is
		1137	the domain name, C<$type> a type string or number, C<$class> a class name
		1138	and @data is resource-record-dependent data. For C<a> records, this will
		1139	be the textual IPv4 addresses, for C<ns> or C<cname> records this will be
		1140	a domain name, for C<txt> records these are all the strings and so on.
		1141
		1142	All types mentioned in RFC 1035, C<aaaa>, C<srv>, C<naptr> and C<spf> are
		1143	decoded. All resource records not known to this module will have
		1144	the raw C<rdata> field as fourth entry.
		1145
753	Note that this resolver is just a stub resolver: it requires a nameserver	1146	Note that this resolver is just a stub resolver: it requires a name server
754	supporting recursive queries, will not do any recursive queries itself and	1147	supporting recursive queries, will not do any recursive queries itself and
755	is not secure when used against an untrusted name server.	1148	is not secure when used against an untrusted name server.
756		1149
757	The following options are supported:	1150	The following options are supported:
758		1151
…		…
760		1153
761	=item search => [$suffix...]	1154	=item search => [$suffix...]
762		1155
763	Use the given search list (which might be empty), by appending each one	1156	Use the given search list (which might be empty), by appending each one
764	in turn to the C<$qname>. If this option is missing then the configured	1157	in turn to the C<$qname>. If this option is missing then the configured
765	C<ndots> and C<search> define its value. If the C<$qname> ends in a dot,	1158	C<ndots> and C<search> values define its value (depending on C<ndots>, the
766	then the searchlist will be ignored.	1159	empty suffix will be prepended or appended to that C<search> value). If
		1160	the C<$qname> ends in a dot, then the searchlist will be ignored.
767		1161
768	=item accept => [$type...]	1162	=item accept => [$type...]
769		1163
770	Lists the acceptable result types: only result types in this set will be	1164	Lists the acceptable result types: only result types in this set will be
771	accepted and returned. The default includes the C<$qtype> and nothing	1165	accepted and returned. The default includes the C<$qtype> and nothing
772	else.	1166	else. If this list includes C<cname>, then CNAME-chains will not be
		1167	followed (because you asked for the CNAME record).
773		1168
774	=item class => "class"	1169	=item class => "class"
775		1170
776	Specify the query class ("in" for internet, "ch" for chaosnet and "hs" for	1171	Specify the query class ("in" for internet, "ch" for chaosnet and "hs" for
777	hesiod are the only ones making sense). The default is "in", of course.	1172	hesiod are the only ones making sense). The default is "in", of course.
778		1173
779	=back	1174	=back
780		1175
781	Examples:	1176	Examples:
782		1177
783	$res->resolve ("ruth.plan9.de", "a", sub {	1178	# full example, you can paste this into perl:
784	warn Dumper [@_];	1179	use Data::Dumper;
785	});	1180	use AnyEvent::DNS;
		1181	AnyEvent::DNS::resolver->resolve (
		1182	"google.com", "*", my $cv = AnyEvent->condvar);
		1183	warn Dumper [$cv->recv];
786		1184
		1185	# shortened result:
787	[	1186	# [
		1187	# [ 'google.com', 'soa', 'in', 'ns1.google.com', 'dns-admin.google.com',
		1188	# 2008052701, 7200, 1800, 1209600, 300 ],
788	[	1189	# [
789	'ruth.schmorp.de',	1190	# 'google.com', 'txt', 'in',
790	'a',	1191	# 'v=spf1 include:_netblocks.google.com ~all'
791	'in',	1192	# ],
792	'129.13.162.95'	1193	# [ 'google.com', 'a', 'in', '64.233.187.99' ],
		1194	# [ 'google.com', 'mx', 'in', 10, 'smtp2.google.com' ],
		1195	# [ 'google.com', 'ns', 'in', 'ns2.google.com' ],
793	]	1196	# ]
		1197
		1198	# resolve a records:
		1199	$res->resolve ("ruth.plan9.de", "a", sub { warn Dumper [@_] });
		1200
		1201	# result:
		1202	# [
		1203	# [ 'ruth.schmorp.de', 'a', 'in', '129.13.162.95' ]
794	]	1204	# ]
795		1205
		1206	# resolve any records, but return only a and aaaa records:
796	$res->resolve ("test1.laendle", "*",	1207	$res->resolve ("test1.laendle", "*",
797	accept => ["a", "aaaa"],	1208	accept => ["a", "aaaa"],
798	sub {	1209	sub {
799	warn Dumper [@_];	1210	warn Dumper [@_];
800	}	1211	}
801	);	1212	);
802		1213
803	[	1214	# result:
804	[	1215	# [
805	'test1.laendle',	1216	# [ 'test1.laendle', 'a', 'in', '10.0.0.255' ],
806	'a',	1217	# [ 'test1.laendle', 'aaaa', 'in', '3ffe:1900:4545:0002:0240:0000:0000:f7e1' ]
807	'in',
808	'10.0.0.255'
809	],
810	[
811	'test1.laendle',
812	'aaaa',
813	'in',
814	'3ffe:1900:4545:0002:0240:0000:0000:f7e1'
815	]	1218	# ]
816	]
817		1219
818	=cut	1220	=cut
819		1221
820	sub resolve($%) {	1222	sub resolve($%) {
821	my $cb = pop;	1223	my $cb = pop;
…		…
834	my %atype = $opt{accept}	1236	my %atype = $opt{accept}
835	? map +($_ => 1), @{ $opt{accept} }	1237	? map +($_ => 1), @{ $opt{accept} }
836	: ($qtype => 1);	1238	: ($qtype => 1);
837		1239
838	# advance in searchlist	1240	# advance in searchlist
839	my $do_search; $do_search = sub {	1241	my ($do_search, $do_req);
		1242
		1243	$do_search = sub {
840	@search	1244	@search
841	or return $cb->();	1245	or (undef $do_search), (undef $do_req), return $cb->();
842		1246
843	(my $name = lc "$qname." . shift @search) =~ s/\.$//;	1247	(my $name = lc "$qname." . shift @search) =~ s/\.$//;
844	my $depth = 2;	1248	my $depth = 2;
845		1249
846	# advance in cname-chain	1250	# advance in cname-chain
847	my $do_req; $do_req = sub {	1251	$do_req = sub {
848	$self->request ({	1252	$self->request ({
849	rd => 1,	1253	rd => 1,
850	qd => [[$name, $qtype, $class]],	1254	qd => [[$name, $qtype, $class]],
851	}, sub {	1255	}, sub {
852	my ($res) = @_	1256	my ($res) = @_
…		…
856		1260
857	while () {	1261	while () {
858	# results found?	1262	# results found?
859	my @rr = grep $name eq lc $_->[0] && ($atype{"*"} \|\| $atype{$_->[1]}), @{ $res->{an} };	1263	my @rr = grep $name eq lc $_->[0] && ($atype{"*"} \|\| $atype{$_->[1]}), @{ $res->{an} };
860		1264
861	return $cb->(@rr)	1265	(undef $do_search), (undef $do_req), return $cb->(@rr)
862	if @rr;	1266	if @rr;
863		1267
864	# see if there is a cname we can follow	1268	# see if there is a cname we can follow
865	my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} };	1269	my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} };
866		1270
…		…
887	};	1291	};
888		1292
889	$do_search->();	1293	$do_search->();
890	}	1294	}
891		1295
		1296	=item $resolver->wait_for_slot ($cb->($resolver))
		1297
		1298	Wait until a free request slot is available and call the callback with the
		1299	resolver object.
		1300
		1301	A request slot is used each time a request is actually sent to the
		1302	nameservers: There are never more than C<max_outstanding> of them.
		1303
		1304	Although you can submit more requests (they will simply be queued until
		1305	a request slot becomes available), sometimes, usually for rate-limiting
		1306	purposes, it is useful to instead wait for a slot before generating the
		1307	request (or simply to know when the request load is low enough so one can
		1308	submit requests again).
		1309
		1310	This is what this method does: The callback will be called when submitting
		1311	a DNS request will not result in that request being queued. The callback
		1312	may or may not generate any requests in response.
		1313
		1314	Note that the callback will only be invoked when the request queue is
		1315	empty, so this does not play well if somebody else keeps the request queue
		1316	full at all times.
		1317
		1318	=cut
		1319
		1320	sub wait_for_slot {
		1321	my ($self, $cb) = @_;
		1322
		1323	push @{ $self->{wait} }, $cb;
		1324	$self->_scheduler;
		1325	}
		1326
		1327	use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end
		1328
892	1;	1329	1;
893		1330
894	=back	1331	=back
895		1332
896	=head1 AUTHOR	1333	=head1 AUTHOR

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.4 by root, Fri May 23 04:10:40 2008 UTC vs. Revision 1.56 by root, Fri May 30 21:38:46 2008 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.4 by root, Fri May 23 04:10:40 2008 UTC vs.
Revision 1.56 by root, Fri May 30 21:38:46 2008 UTC