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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.16 by root, Fri May 23 17:47:06 2008 UTC vs.
Revision 1.100 by root, Sun Jul 5 01:38:43 2009 UTC

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

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.16 by root, Fri May 23 17:47:06 2008 UTC vs. Revision 1.100 by root, Sun Jul 5 01:38:43 2009 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.16 by root, Fri May 23 17:47:06 2008 UTC vs.
Revision 1.100 by root, Sun Jul 5 01:38:43 2009 UTC