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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.7 by root, Fri May 23 05:30:59 2008 UTC vs.
Revision 1.65 by root, Thu Jun 5 18:30:08 2008 UTC

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

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.7 by root, Fri May 23 05:30:59 2008 UTC vs. Revision 1.65 by root, Thu Jun 5 18:30:08 2008 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.7 by root, Fri May 23 05:30:59 2008 UTC vs.
Revision 1.65 by root, Thu Jun 5 18:30:08 2008 UTC