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

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.112 by root, Tue Jul 28 11:02:19 2009 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.112 by root, Tue Jul 28 11:02:19 2009 UTC