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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.2 by root, Fri May 23 02:59:32 2008 UTC vs.
Revision 1.107 by root, Fri Jul 17 23:12:20 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	# none yet
17
18	=over 4	25	=over 4
19		26
20	=cut	27	=cut
21		28
22	package AnyEvent::DNS;	29	package AnyEvent::DNS;
23		30
24	use strict;	31	use Carp ();
		32	use Socket qw(AF_INET SOCK_DGRAM SOCK_STREAM);
25		33
		34	use AnyEvent (); BEGIN { AnyEvent::common_sense }
26	use AnyEvent::Util ();	35	use AnyEvent::Util qw(AF_INET6);
		36
		37	our $VERSION = 4.83;
		38
		39	our @DNS_FALLBACK = (v208.67.220.220, v208.67.222.222);
		40
		41	=item AnyEvent::DNS::a $domain, $cb->(@addrs)
		42
		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).
		48
		49	=item AnyEvent::DNS::mx $domain, $cb->(@hostnames)
		50
		51	Tries to resolve the given domain into a sorted (lower preference value
		52	first) list of domain names.
		53
		54	=item AnyEvent::DNS::ns $domain, $cb->(@hostnames)
		55
		56	Tries to resolve the given domain name into a list of name servers.
		57
		58	=item AnyEvent::DNS::txt $domain, $cb->(@hostnames)
		59
		60	Tries to resolve the given domain name into a list of text records.
		61
		62	=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)
		63
		64	Tries to resolve the given service, protocol and domain name into a list
		65	of service records.
		66
		67	Each C<$srv_rr> is an array reference with the following contents:
		68	C<[$priority, $weight, $transport, $target]>.
		69
		70	They will be sorted with lowest priority first, then randomly
		71	distributed by weight as per RFC 2782.
		72
		73	Example:
		74
		75	AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...
		76	# @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )
		77
		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)
		90
		91	Tries to reverse-resolve the given IPv4 or IPv6 address (in textual form)
		92	into it's hostname(s). Handles V4MAPPED and V4COMPAT IPv6 addresses
		93	transparently.
		94
		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.
		105
		106	Example:
		107
		108	AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };
		109	# => f.root-servers.net
		110
		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
		116
		117	sub resolver;
		118
		119	sub a($$) {
		120	my ($domain, $cb) = @_;
		121
		122	resolver->resolve ($domain => "a", sub {
		123	$cb->(map $_->[3], @_);
		124	});
		125	}
		126
		127	sub aaaa($$) {
		128	my ($domain, $cb) = @_;
		129
		130	resolver->resolve ($domain => "aaaa", sub {
		131	$cb->(map $_->[3], @_);
		132	});
		133	}
		134
		135	sub mx($$) {
		136	my ($domain, $cb) = @_;
		137
		138	resolver->resolve ($domain => "mx", sub {
		139	$cb->(map $_->[4], sort { $a->[3] <=> $b->[3] } @_);
		140	});
		141	}
		142
		143	sub ns($$) {
		144	my ($domain, $cb) = @_;
		145
		146	resolver->resolve ($domain => "ns", sub {
		147	$cb->(map $_->[3], @_);
		148	});
		149	}
		150
		151	sub txt($$) {
		152	my ($domain, $cb) = @_;
		153
		154	resolver->resolve ($domain => "txt", sub {
		155	$cb->(map $_->[3], @_);
		156	});
		157	}
		158
		159	sub srv($$$$) {
		160	my ($service, $proto, $domain, $cb) = @_;
		161
		162	# todo, ask for any and check glue records
		163	resolver->resolve ("_$service._$proto.$domain" => "srv", sub {
		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);
		191	});
		192	}
		193
		194	sub ptr($$) {
		195	my ($domain, $cb) = @_;
		196
		197	resolver->resolve ($domain => "ptr", sub {
		198	$cb->(map $_->[3], @_);
		199	});
		200	}
		201
		202	sub any($$) {
		203	my ($domain, $cb) = @_;
		204
		205	resolver->resolve ($domain => "*", $cb);
		206	}
		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	#################################################################################
27		281
28	=back	282	=back
29		283
30	=head2 DNS EN-/DECODING FUNCTIONS	284	=head2 LOW-LEVEL DNS EN-/DECODING FUNCTIONS
31		285
32	=over 4	286	=over 4
33		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
34	=cut	295	=cut
		296
		297	our $EDNS0 = $ENV{PERL_ANYEVENT_EDNS0}*1; # set to 1 to enable (partial) edns0
35		298
36	our %opcode_id = (	299	our %opcode_id = (
37	query => 0,	300	query => 0,
38	iquery => 1,	301	iquery => 1,
39	status => 2,	302	status => 2,
		303	notify => 4,
		304	update => 5,
40	map +($_ => $_), 3..15	305	map +($_ => $_), 3, 6..15
41	);	306	);
42		307
43	our %opcode_str = reverse %opcode_id;	308	our %opcode_str = reverse %opcode_id;
44		309
45	our %rcode_id = (	310	our %rcode_id = (
46	ok => 0,	311	noerror => 0,
47	formerr => 1,	312	formerr => 1,
48	servfail => 2,	313	servfail => 2,
49	nxdomain => 3,	314	nxdomain => 3,
50	notimp => 4,	315	notimp => 4,
51	refused => 5,	316	refused => 5,
		317	yxdomain => 6, # Name Exists when it should not [RFC 2136]
		318	yxrrset => 7, # RR Set Exists when it should not [RFC 2136]
		319	nxrrset => 8, # RR Set that should exist does not [RFC 2136]
		320	notauth => 9, # Server Not Authoritative for zone [RFC 2136]
		321	notzone => 10, # Name not contained in zone [RFC 2136]
		322	# EDNS0 16 BADVERS Bad OPT Version [RFC 2671]
		323	# EDNS0 16 BADSIG TSIG Signature Failure [RFC 2845]
		324	# EDNS0 17 BADKEY Key not recognized [RFC 2845]
		325	# EDNS0 18 BADTIME Signature out of time window [RFC 2845]
		326	# EDNS0 19 BADMODE Bad TKEY Mode [RFC 2930]
		327	# EDNS0 20 BADNAME Duplicate key name [RFC 2930]
		328	# EDNS0 21 BADALG Algorithm not supported [RFC 2930]
52	map +($_ => $_), 6..15	329	map +($_ => $_), 11..15
53	);	330	);
54		331
55	our %rcode_str = reverse %rcode_id;	332	our %rcode_str = reverse %rcode_id;
56		333
57	our %type_id = (	334	our %type_id = (
…		…
71	minfo => 14,	348	minfo => 14,
72	mx => 15,	349	mx => 15,
73	txt => 16,	350	txt => 16,
74	aaaa => 28,	351	aaaa => 28,
75	srv => 33,	352	srv => 33,
		353	naptr => 35, # rfc2915
		354	dname => 39, # rfc2672
		355	opt => 41,
		356	spf => 99,
		357	tkey => 249,
		358	tsig => 250,
		359	ixfr => 251,
76	axfr => 252,	360	axfr => 252,
77	mailb => 253,	361	mailb => 253,
78	"*" => 255,	362	"*" => 255,
79	);	363	);
80		364
81	our %type_str = reverse %type_id;	365	our %type_str = reverse %type_id;
82		366
83	our %class_id = (	367	our %class_id = (
84	in => 1,	368	in => 1,
85	ch => 3,	369	ch => 3,
86	hs => 4,	370	hs => 4,
		371	none => 254,
87	"*" => 255,	372	"*" => 255,
88	);	373	);
89		374
90	our %class_str = reverse %class_id;	375	our %class_str = reverse %class_id;
91		376
92	# names MUST have a trailing dot
93	sub _enc_qname($) {	377	sub _enc_name($) {
94	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	};
95	}	386	}
96		387
97	sub _enc_qd() {	388	sub _enc_qd() {
98	(_enc_qname $_->[0]) . pack "nn",	389	(_enc_name $_->[0]) . pack "nn",
99	($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}),	390	($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}),
100	($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] \|\| "in"})	391	($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] \|\| "in"})
101	}	392	}
102		393
103	sub _enc_rr() {	394	sub _enc_rr() {
104	die "encoding of resource records is not supported";	395	die "encoding of resource records is not supported";
105	}	396	}
106		397
107	=item $pkt = AnyEvent::DNS::dns_pack $dns	398	=item $pkt = AnyEvent::DNS::dns_pack $dns
108		399
109	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
110	recommended, then everything will be totally clear. Or maybe not.	401	recommended, then everything will be totally clear. Or maybe not.
111		402
112	Resource records are not yet encodable.	403	Resource records are not yet encodable.
113		404
114	Examples:	405	Examples:
115		406
116	# very simple request, using lots of default values:	407	# very simple request, using lots of default values:
117	{ rd => 1, qd => [ [ "host.domain", "a"] ] }	408	{ rd => 1, qd => [ [ "host.domain", "a"] ] }
118		409
119	# more complex example, showing how flags etc. are named:	410	# more complex example, showing how flags etc. are named:
120		411
121	{	412	{
122	id => 10000,	413	id => 10000,
123	op => "query",	414	op => "query",
124	rc => "nxdomain",	415	rc => "nxdomain",
125		416
126	# flags	417	# flags
127	qr => 1,	418	qr => 1,
128	aa => 0,	419	aa => 0,
129	tc => 0,	420	tc => 0,
130	rd => 0,	421	rd => 0,
131	ra => 0,	422	ra => 0,
132		423	ad => 0,
		424	cd => 0,
		425
133	qd => [@rr], # query section	426	qd => [@rr], # query section
134	an => [@rr], # answer section	427	an => [@rr], # answer section
135	ns => [@rr], # authority section	428	ns => [@rr], # authority section
136	ar => [@rr], # additional records section	429	ar => [@rr], # additional records section
137	}	430	}
138		431
139	=cut	432	=cut
140		433
141	sub dns_pack($) {	434	sub dns_pack($) {
142	my ($req) = @_;	435	my ($req) = @_;
143		436
144	pack "nn nnnn a* a* a* a*",	437	pack "nn nnnn a* a* a* a* a*",
145	$req->{id},	438	$req->{id},
146		439
147	! !$req->{qr} * 0x8000	440	! !$req->{qr} * 0x8000
148	+ $opcode_id{$req->{op}} * 0x0800	441	+ $opcode_id{$req->{op}} * 0x0800
149	+ ! !$req->{aa} * 0x0400	442	+ ! !$req->{aa} * 0x0400
150	+ ! !$req->{tc} * 0x0200	443	+ ! !$req->{tc} * 0x0200
151	+ ! !$req->{rd} * 0x0100	444	+ ! !$req->{rd} * 0x0100
152	+ ! !$req->{ra} * 0x0080	445	+ ! !$req->{ra} * 0x0080
		446	+ ! !$req->{ad} * 0x0020
		447	+ ! !$req->{cd} * 0x0010
153	+ $rcode_id{$req->{rc}} * 0x0001,	448	+ $rcode_id{$req->{rc}} * 0x0001,
154		449
155	scalar @{ $req->{qd} \|\| [] },	450	scalar @{ $req->{qd} \|\| [] },
156	scalar @{ $req->{an} \|\| [] },	451	scalar @{ $req->{an} \|\| [] },
157	scalar @{ $req->{ns} \|\| [] },	452	scalar @{ $req->{ns} \|\| [] },
158	scalar @{ $req->{ar} \|\| [] },	453	$EDNS0 + scalar @{ $req->{ar} \|\| [] }, # EDNS0 option included here
159		454
160	(join "", map _enc_qd, @{ $req->{qd} \|\| [] }),	455	(join "", map _enc_qd, @{ $req->{qd} \|\| [] }),
161	(join "", map _enc_rr, @{ $req->{an} \|\| [] }),	456	(join "", map _enc_rr, @{ $req->{an} \|\| [] }),
162	(join "", map _enc_rr, @{ $req->{ns} \|\| [] }),	457	(join "", map _enc_rr, @{ $req->{ns} \|\| [] }),
163	(join "", map _enc_rr, @{ $req->{ar} \|\| [] });	458	(join "", map _enc_rr, @{ $req->{ar} \|\| [] }),
		459
		460	($EDNS0 ? pack "C nnNn", 0, 41, MAX_PKT, 0, 0 : "") # EDNS0 option
164	}	461	}
165		462
166	our $ofs;	463	our $ofs;
167	our $pkt;	464	our $pkt;
168		465
169	# bitches	466	# bitches
170	sub _dec_qname {	467	sub _dec_name {
171	my @res;	468	my @res;
172	my $redir;	469	my $redir;
173	my $ptr = $ofs;	470	my $ptr = $ofs;
174	my $cnt;	471	my $cnt;
175		472
176	while () {	473	while () {
177	return undef if ++$cnt >= 256; # to avoid DoS attacks	474	return undef if ++$cnt >= 256; # to avoid DoS attacks
178		475
179	my $len = ord substr $pkt, $ptr++, 1;	476	my $len = ord substr $pkt, $ptr++, 1;
180		477
181	if ($len & 0xc0) {	478	if ($len >= 0xc0) {
182	$ptr++;	479	$ptr++;
183	$ofs = $ptr if $ptr > $ofs;	480	$ofs = $ptr if $ptr > $ofs;
184	$ptr = (unpack "n", substr $pkt, $ptr - 2, 2) & 0x3fff;	481	$ptr = (unpack "n", substr $pkt, $ptr - 2, 2) & 0x3fff;
185	} elsif ($len) {	482	} elsif ($len) {
186	push @res, substr $pkt, $ptr, $len;	483	push @res, substr $pkt, $ptr, $len;
…		…
191	}	488	}
192	}	489	}
193	}	490	}
194		491
195	sub _dec_qd {	492	sub _dec_qd {
196	my $qname = _dec_qname;	493	my $qname = _dec_name;
197	my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;	494	my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;
198	[$qname, $type_str{$qt} \|\| $qt, $class_str{$qc} \|\| $qc]	495	[$qname, $type_str{$qt} \|\| $qt, $class_str{$qc} \|\| $qc]
199	}	496	}
200		497
201	our %dec_rr = (	498	our %dec_rr = (
202	1 => sub { Socket::inet_ntoa $_ }, # a	499	1 => sub { join ".", unpack "C4", $_ }, # a
203	2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns	500	2 => sub { local $ofs = $ofs - length; _dec_name }, # ns
204	5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname	501	5 => sub { local $ofs = $ofs - length; _dec_name }, # cname
205	6 => sub {	502	6 => sub {
206	local $ofs = $ofs - length;	503	local $ofs = $ofs - length;
207	my $mname = _dec_qname;	504	my $mname = _dec_name;
208	my $rname = _dec_qname;	505	my $rname = _dec_name;
209	($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)	506	($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)
210	}, # soa	507	}, # soa
211	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
212	12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr	509	12 => sub { local $ofs = $ofs - length; _dec_name }, # ptr
213	13 => sub { unpack "C/a C/a", $_ },	510	13 => sub { unpack "C/a* C/a*", $_ }, # hinfo
214	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
215	16 => sub { unpack "C/a", $_ }, # txt	512	16 => sub { unpack "(C/a)", $_ }, # txt
216	28 => sub { sprintf "%04x:%04x:%04x:%04x:%04x:%04x:%04x:%04x", unpack "n8" }, # aaaa	513	28 => sub { AnyEvent::Socket::format_ipv6 ($_) }, # aaaa
217	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
		522	99 => sub { unpack "(C/a)", $_ }, # spf
218	);	523	);
219		524
220	sub _dec_rr {	525	sub _dec_rr {
221	my $qname = _dec_qname;	526	my $name = _dec_name;
222		527
223	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;
224	local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen;	529	local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen;
225		530
226	[	531	[
227	$qname,	532	$name,
228	$type_str{$rt} \|\| $rt,	533	$type_str{$rt} \|\| $rt,
229	$class_str{$rc} \|\| $rc,	534	$class_str{$rc} \|\| $rc,
230	($dec_rr{$rt} \|\| sub { $_ })->(),	535	($dec_rr{$rt} \|\| sub { $_ })->(),
231	]	536	]
232	}	537	}
…		…
235		540
236	Unpacks a DNS packet into a perl data structure.	541	Unpacks a DNS packet into a perl data structure.
237		542
238	Examples:	543	Examples:
239		544
240	# a non-successful reply	545	# an unsuccessful reply
241	{	546	{
242	'qd' => [	547	'qd' => [
243	[ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]	548	[ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]
244	],	549	],
245	'rc' => 'nxdomain',	550	'rc' => 'nxdomain',
246	'ar' => [],	551	'ar' => [],
247	'ns' => [	552	'ns' => [
248	[	553	[
249	'uni-karlsruhe.de',	554	'uni-karlsruhe.de',
250	'soa',	555	'soa',
251	'in',	556	'in',
252	'netserv.rz.uni-karlsruhe.de',	557	'netserv.rz.uni-karlsruhe.de',
253	'hostmaster.rz.uni-karlsruhe.de',	558	'hostmaster.rz.uni-karlsruhe.de',
254	2008052201,	559	2008052201, 10800, 1800, 2592000, 86400
255	10800,
256	1800,
257	2592000,
258	86400
259	]	560	]
260	],	561	],
261	'tc' => '',	562	'tc' => '',
262	'ra' => 1,	563	'ra' => 1,
263	'qr' => 1,	564	'qr' => 1,
264	'id' => 45915,	565	'id' => 45915,
265	'aa' => '',	566	'aa' => '',
266	'an' => [],	567	'an' => [],
267	'rd' => 1,	568	'rd' => 1,
268	'op' => 'query'	569	'op' => 'query'
269	}	570	}
270		571
271	# a successful reply	572	# a successful reply
272		573
273	{	574	{
274	'qd' => [ [ 'www.google.de', 'a', 'in' ] ],	575	'qd' => [ [ 'www.google.de', 'a', 'in' ] ],
275	'rc' => 0,	576	'rc' => 0,
276	'ar' => [	577	'ar' => [
277	[ 'a.l.google.com', 'a', 'in', '209.85.139.9' ],	578	[ 'a.l.google.com', 'a', 'in', '209.85.139.9' ],
278	[ 'b.l.google.com', 'a', 'in', '64.233.179.9' ],	579	[ 'b.l.google.com', 'a', 'in', '64.233.179.9' ],
279	[ 'c.l.google.com', 'a', 'in', '64.233.161.9' ],	580	[ 'c.l.google.com', 'a', 'in', '64.233.161.9' ],
280	],	581	],
281	'ns' => [	582	'ns' => [
282	[ 'l.google.com', 'ns', 'in', 'a.l.google.com' ],	583	[ 'l.google.com', 'ns', 'in', 'a.l.google.com' ],
283	[ 'l.google.com', 'ns', 'in', 'b.l.google.com' ],	584	[ 'l.google.com', 'ns', 'in', 'b.l.google.com' ],
284	],	585	],
285	'tc' => '',	586	'tc' => '',
286	'ra' => 1,	587	'ra' => 1,
287	'qr' => 1,	588	'qr' => 1,
288	'id' => 64265,	589	'id' => 64265,
289	'aa' => '',	590	'aa' => '',
290	'an' => [	591	'an' => [
291	[ 'www.google.de', 'cname', 'in', 'www.google.com' ],	592	[ 'www.google.de', 'cname', 'in', 'www.google.com' ],
292	[ 'www.google.com', 'cname', 'in', 'www.l.google.com' ],	593	[ 'www.google.com', 'cname', 'in', 'www.l.google.com' ],
293	[ 'www.l.google.com', 'a', 'in', '66.249.93.104' ],	594	[ 'www.l.google.com', 'a', 'in', '66.249.93.104' ],
294	[ 'www.l.google.com', 'a', 'in', '66.249.93.147' ],	595	[ 'www.l.google.com', 'a', 'in', '66.249.93.147' ],
295	],	596	],
296	'rd' => 1,	597	'rd' => 1,
297	'op' => 0	598	'op' => 0
298	}	599	}
299		600
300	=cut	601	=cut
301		602
302	sub dns_unpack($) {	603	sub dns_unpack($) {
303	local $pkt = shift;	604	local $pkt = shift;
…		…
311	qr => ! ! ($flags & 0x8000),	612	qr => ! ! ($flags & 0x8000),
312	aa => ! ! ($flags & 0x0400),	613	aa => ! ! ($flags & 0x0400),
313	tc => ! ! ($flags & 0x0200),	614	tc => ! ! ($flags & 0x0200),
314	rd => ! ! ($flags & 0x0100),	615	rd => ! ! ($flags & 0x0100),
315	ra => ! ! ($flags & 0x0080),	616	ra => ! ! ($flags & 0x0080),
		617	ad => ! ! ($flags & 0x0020),
		618	cd => ! ! ($flags & 0x0010),
316	op => $opcode_str{($flags & 0x001e) >> 11},	619	op => $opcode_str{($flags & 0x001e) >> 11},
317	rc => $rcode_str{($flags & 0x000f)},	620	rc => $rcode_str{($flags & 0x000f)},
318		621
319	qd => [map _dec_qd, 1 .. $qd],	622	qd => [map _dec_qd, 1 .. $qd],
320	an => [map _dec_rr, 1 .. $an],	623	an => [map _dec_rr, 1 .. $an],
…		…
327		630
328	=back	631	=back
329		632
330	=head2 THE AnyEvent::DNS RESOLVER CLASS	633	=head2 THE AnyEvent::DNS RESOLVER CLASS
331		634
332	This is the class which deos the actual protocol work.	635	This is the class which does the actual protocol work.
333		636
334	=over 4	637	=over 4
335		638
336	=cut	639	=cut
337		640
…		…
350	calls.	653	calls.
351		654
352	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
353	resolver object.	656	resolver object.
354		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
355	=cut	667	=cut
356		668
357	our $RESOLVER;	669	our $RESOLVER;
358		670
359	sub resolver() {	671	sub resolver() {
360	$RESOLVER \|\| do {	672	$RESOLVER \|\| do {
361	$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})
362	$RESOLVER->load_resolv_conf;	681	: $RESOLVER->os_config;
		682
363	$RESOLVER	683	$RESOLVER
364	}	684	}
365	}	685	}
366		686
367	=item $resolver = new AnyEvent::DNS key => value...	687	=item $resolver = new AnyEvent::DNS key => value...
368		688
369	Creates and returns a new resolver. It only supports UDP, so make sure	689	Creates and returns a new resolver.
370	your answer sections fit into a DNS packet.
371		690
372	The following options are supported:	691	The following options are supported:
373		692
374	=over 4	693	=over 4
375		694
376	=item server => [...]	695	=item server => [...]
377		696
378	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
379	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).
380		700
381	=item timeout => [...]	701	=item timeout => [...]
382		702
383	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
384	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,
…		…
393	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
394	tries to resolve the name without any suffixes first.	714	tries to resolve the name without any suffixes first.
395		715
396	=item max_outstanding => $integer	716	=item max_outstanding => $integer
397		717
398	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
399	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>
400	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,
401	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.
402		734
403	=back	735	=back
404		736
405	=cut	737	=cut
406		738
407	sub new {	739	sub new {
408	my ($class, %arg) = @_;	740	my ($class, %arg) = @_;
409		741
410	socket my $fh, &Socket::AF_INET, &Socket::SOCK_DGRAM, 0
411	or Carp::croak "socket: $!";
412
413	AnyEvent::Util::fh_nonblocking $fh, 1;
414
415	my $self = bless {	742	my $self = bless {
416	server => [v127.0.0.1],	743	server => [],
417	timeout => [2, 5, 5],	744	timeout => [2, 5, 5],
418	search => [],	745	search => [],
419	ndots => 1,	746	ndots => 1,
420	max_outstanding => 10,	747	max_outstanding => 10,
421	reuse => 300, # reuse id's after 5 minutes only, if possible	748	reuse => 300,
422	%arg,	749	%arg,
423	fh => $fh,
424	reuse_q => [],	750	reuse_q => [],
425	}, $class;	751	}, $class;
426		752
427	# search should default to gethostname's domain	753	# search should default to gethostname's domain
428	# but perl lacks a good posix module	754	# but perl lacks a good posix module
429		755
		756	# try to create an ipv4 and an ipv6 socket
		757	# only fail when we cannot create either
		758	my $got_socket;
		759
430	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;
431	$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";
432		788
433	$self->_compile;	789	$self->_compile;
434		790
435	$self	791	$self
436	}	792	}
437		793
438	=item $resolver->parse_resolv_conv ($string)	794	=item $resolver->parse_resolv_conf ($string)
439		795
440	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
441	directives are supported:	797	directives are supported (but not necessarily implemented).
442		798
443	C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,	799	C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,
444	C<options> (C<timeout>, C<attempts>, C<ndots>).	800	C<options> (C<timeout>, C<attempts>, C<ndots>).
445		801
446	Everything else is silently ignored.	802	Everything else is silently ignored.
…		…
458	for (split /\n/, $resolvconf) {	814	for (split /\n/, $resolvconf) {
459	if (/^\s*#/) {	815	if (/^\s*#/) {
460	# comment	816	# comment
461	} elsif (/^\snameserver\s+(\S+)\s$/i) {	817	} elsif (/^\snameserver\s+(\S+)\s$/i) {
462	my $ip = $1;	818	my $ip = $1;
463	if (AnyEvent::Util::dotted_quad $ip) {	819	if (my $ipn = AnyEvent::Socket::parse_address ($ip)) {
464	push @{ $self->{server} }, AnyEvent::Util::socket_inet_aton $ip;	820	push @{ $self->{server} }, $ipn;
465	} else {	821	} else {
466	warn "nameserver $ip invalid and ignored\n";	822	warn "nameserver $ip invalid and ignored\n";
467	}	823	}
468	} elsif (/^\sdomain\s+(\S)\s+$/i) {	824	} elsif (/^\sdomain\s+(\S)\s+$/i) {
469	$self->{search} = [$1];	825	$self->{search} = [$1];
…		…
490	if $attempts;	846	if $attempts;
491		847
492	$self->_compile;	848	$self->_compile;
493	}	849	}
494		850
495	=item $resolver->load_resolv_conf	851	sub _parse_resolv_conf_file {
		852	my ($self, $resolv_conf) = @_;
496		853
497	Tries to load and parse F</etc/resolv.conf>. If there will ever be windows
498	support, then this function will do the right thing under windows, too.
499
500	=cut
501
502	sub load_resolv_conf {
503	my ($self) = @_;
504
505	open my $fh, "</etc/resolv.conf"	854	open my $fh, "<", $resolv_conf
506	or return;	855	or Carp::croak "$resolv_conf: $!";
507		856
508	local $/;	857	local $/;
509	$self->parse_resolv_conf (<$fh>);	858	$self->parse_resolv_conf (<$fh>);
510	}	859	}
511		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
512	sub _compile {	954	sub _compile {
513	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	}
514		964
515	my @retry;	965	my @retry;
516		966
517	for my $timeout (@{ $self->{timeout} }) {	967	for my $timeout (@{ $self->{timeout} }) {
518	for my $server (@{ $self->{server} }) {	968	for my $server (@{ $self->{server} }) {
…		…
521	}	971	}
522		972
523	$self->{retry} = \@retry;	973	$self->{retry} = \@retry;
524	}	974	}
525		975
		976	sub _feed {
		977	my ($self, $res) = @_;
		978
		979	($res) = $res =~ /^(.*)$/s
		980	if AnyEvent::TAINT && $self->{untaint};
		981
		982	$res = dns_unpack $res
		983	or return;
		984
		985	my $id = $self->{id}{$res->{id}};
		986
		987	return unless ref $id;
		988
		989	$NOW = time;
		990	$id->[1]->($res);
		991	}
		992
526	sub _recv {	993	sub _recv {
527	my ($self) = @_;	994	my ($self, $pkt, $peer) = @_;
528		995
529	while (my $peer = recv $self->{fh}, my $res, 1024, 0) {	996	# we ignore errors (often one gets port unreachable, but there is
		997	# no good way to take advantage of that.
		998
530	my ($port, $host) = Socket::unpack_sockaddr_in $peer;	999	my ($port, $host) = AnyEvent::Socket::unpack_sockaddr ($peer);
531		1000
532	return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };	1001	return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };
533		1002
534	$res = AnyEvent::DNS::dns_unpack $res	1003	$self->_feed ($pkt);
535	or return;
536
537	my $id = $self->{id}{$res->{id}};
538
539	return unless ref $id;
540
541	$NOW = time;
542	$id->[1]->($res);
543	}
544	}	1004	}
545		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
546	sub _exec {	1023	sub _exec {
547	my ($self, $req, $retry) = @_;	1024	my ($self, $req) = @_;
548		1025
		1026	my $retry; # of retries
		1027	my $do_retry;
		1028
		1029	$do_retry = sub {
549	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
550	my ($server, $timeout) = @$retry_cfg;	1037	my ($server, $timeout) = @$retry_cfg;
551		1038
552	$self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {	1039	$self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {
553	$NOW = time;	1040	$NOW = time;
554		1041
555	# timeout, try next	1042	# timeout, try next
556	$self->_exec ($req, $retry + 1);	1043	&$do_retry if $do_retry;
557	}), sub {	1044	}), sub {
558	my ($res) = @_;	1045	my ($res) = @_;
559		1046
		1047	if ($res->{tc}) {
		1048	# success, but truncated, so use tcp
		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
		1052	my ($fh) = @_
		1053	or return &$do_retry;
		1054
		1055	require AnyEvent::Handle;
		1056
		1057	my $handle; $handle = new AnyEvent::Handle
		1058	fh => $fh,
		1059	timeout => $timeout,
		1060	on_error => sub {
		1061	undef $handle;
		1062	return unless $do_retry; # some other request could have invalidated us already
		1063	# failure, try next
		1064	&$do_retry;
		1065	};
		1066
		1067	$handle->push_write (pack "n/a", $req->[0]);
		1068	$handle->push_read (chunk => 2, sub {
		1069	$handle->unshift_read (chunk => (unpack "n", $_[1]), sub {
		1070	undef $handle;
		1071	$self->_feed ($_[1]);
		1072	});
		1073	});
		1074
		1075	}, sub { $timeout });
		1076
		1077	} else {
560	# success	1078	# success
561	$self->{id}{$req->[2]} = 1;	1079	$self->_free_id ($req->[2], $retry > 1);
562	push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];	1080	undef $do_retry; return $req->[1]->($res);
563	--$self->{outstanding};	1081	}
564	$self->_scheduler;
565
566	$req->[1]->($res);
567	}];	1082	}];
		1083
		1084	my $sa = AnyEvent::Socket::pack_sockaddr (DOMAIN_PORT, $server);
568		1085
569	send $self->{fh}, $req->[0], 0, Socket::pack_sockaddr_in 53, $server;	1086	my $fh = AF_INET == AnyEvent::Socket::sockaddr_family ($sa)
570	} else {	1087	? $self->{fh4} : $self->{fh6}
571	# failure	1088	or return &$do_retry;
572	$self->{id}{$req->[2]} = 1;
573	push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];
574	--$self->{outstanding};
575	$self->_scheduler;
576		1089
577	$req->[1]->();	1090	send $fh, $req->[0], 0, $sa;
578	}	1091	};
		1092
		1093	&$do_retry;
579	}	1094	}
580		1095
581	sub _scheduler {	1096	sub _scheduler {
582	my ($self) = @_;	1097	my ($self) = @_;
583		1098
		1099	no strict 'refs';
		1100
584	$NOW = time;	1101	$NOW = time;
585		1102
586	# first clear id reuse queue	1103	# first clear id reuse queue
587	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }	1104	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }
588	while @{ $self->{reuse_q} } && $self->{reuse_q}[0] <= $NOW;	1105	while @{ $self->{reuse_q} } && $self->{reuse_q}[0][0] <= $NOW;
589		1106
590	while ($self->{outstanding} < $self->{max_outstanding}) {	1107	while ($self->{outstanding} < $self->{max_outstanding}) {
591	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	});
592	or last;	1115	last;
593
594	while () {
595	$req->[2] = int rand 65536;
596	last unless exists $self->{id}{$req->[2]};
597	}	1116	}
598		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};
599	$self->{id}{$req->[2]} = 1;	1126	$self->{id}{$req->[2]} = 1;
600	substr $req->[0], 0, 2, pack "n", $req->[2];	1127	substr $req->[0], 0, 2, pack "n", $req->[2];
601		1128
602	++$self->{outstanding};
603	$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	}
604	}	1139	}
605	}	1140	}
606		1141
607	=item $resolver->request ($req, $cb->($res))	1142	=item $resolver->request ($req, $cb->($res))
608		1143
		1144	This is the main low-level workhorse for sending DNS requests.
		1145
609	Sends a single request (a hash-ref formated as specified for	1146	This function sends a single request (a hash-ref formated as specified
610	C<AnyEvent::DNS::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
611	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
612	was received, or no arguments on timeout.	1152	received, or no arguments in case none of the servers answered.
613		1153
614	=cut	1154	=cut
615		1155
616	sub request($$) {	1156	sub request($$) {
617	my ($self, $req, $cb) = @_;	1157	my ($self, $req, $cb) = @_;
618		1158
619	push @{ $self->{queue} }, [(AnyEvent::DNS::dns_pack $req), $cb];	1159	push @{ $self->{queue} }, [dns_pack $req, $cb];
620	$self->_scheduler;	1160	$self->_scheduler;
621	}	1161	}
622		1162
623	=item $resolver->resolve ($qname, $qtype, %options, $cb->($rcode, @rr))	1163	=item $resolver->resolve ($qname, $qtype, %options, $cb->(@rr))
624		1164
625	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>.
626	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.
627		1172
628	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
629	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.
630		1175
631	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.
		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
		1189	Note that this resolver is just a stub resolver: it requires a name server
		1190	supporting recursive queries, will not do any recursive queries itself and
		1191	is not secure when used against an untrusted name server.
632		1192
633	The following options are supported:	1193	The following options are supported:
634		1194
635	=over 4	1195	=over 4
636		1196
637	=item search => [$suffix...]	1197	=item search => [$suffix...]
638		1198
639	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
640	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
641	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
642	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.
643		1204
644	=item accept => [$type...]	1205	=item accept => [$type...]
645		1206
646	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
647	accepted and returned. The default includes the C<$qtype> and nothing	1208	accepted and returned. The default includes the C<$qtype> and nothing
648	else.	1209	else. If this list includes C<cname>, then CNAME-chains will not be
		1210	followed (because you asked for the CNAME record).
649		1211
650	=item class => "class"	1212	=item class => "class"
651		1213
652	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
653	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.
654		1216
655	=back	1217	=back
656		1218
657	Examples:	1219	Examples:
658		1220
659	$res->resolve ("ruth.plan9.de", "a", sub {	1221	# full example, you can paste this into perl:
660	warn Dumper [@_];	1222	use Data::Dumper;
661	});	1223	use AnyEvent::DNS;
		1224	AnyEvent::DNS::resolver->resolve (
		1225	"google.com", "*", my $cv = AnyEvent->condvar);
		1226	warn Dumper [$cv->recv];
662		1227
		1228	# shortened result:
663	[	1229	# [
		1230	# [ 'google.com', 'soa', 'in', 'ns1.google.com', 'dns-admin.google.com',
		1231	# 2008052701, 7200, 1800, 1209600, 300 ],
664	[	1232	# [
665	'ruth.schmorp.de',	1233	# 'google.com', 'txt', 'in',
666	'a',	1234	# 'v=spf1 include:_netblocks.google.com ~all'
667	'in',	1235	# ],
668	'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' ],
669	]	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' ]
670	]	1247	# ]
671		1248
		1249	# resolve any records, but return only a and aaaa records:
672	$res->resolve ("test1.laendle", "*",	1250	$res->resolve ("test1.laendle", "*",
673	accept => ["a", "aaaa"],	1251	accept => ["a", "aaaa"],
674	sub {	1252	sub {
675	warn Dumper [@_];	1253	warn Dumper [@_];
676	}	1254	}
677	);	1255	);
678		1256
679	[	1257	# result:
680	[	1258	# [
681	'test1.laendle',	1259	# [ 'test1.laendle', 'a', 'in', '10.0.0.255' ],
682	'a',	1260	# [ 'test1.laendle', 'aaaa', 'in', '3ffe:1900:4545:0002:0240:0000:0000:f7e1' ]
683	'in',
684	'10.0.0.255'
685	],
686	[
687	'test1.laendle',
688	'aaaa',
689	'in',
690	'3ffe:1900:4545:0002:0240:0000:0000:f7e1'
691	]	1261	# ]
692	]
693		1262
694	=cut	1263	=cut
695		1264
696	sub resolve($%) {	1265	sub resolve($%) {
697	my $cb = pop;	1266	my $cb = pop;
…		…
710	my %atype = $opt{accept}	1279	my %atype = $opt{accept}
711	? map +($_ => 1), @{ $opt{accept} }	1280	? map +($_ => 1), @{ $opt{accept} }
712	: ($qtype => 1);	1281	: ($qtype => 1);
713		1282
714	# advance in searchlist	1283	# advance in searchlist
715	my $do_search; $do_search = sub {	1284	my ($do_search, $do_req);
		1285
		1286	$do_search = sub {
716	@search	1287	@search
717	or return $cb->();	1288	or (undef $do_search), (undef $do_req), return $cb->();
718		1289
719	(my $name = "$qname." . shift @search) =~ s/\.$//;	1290	(my $name = lc "$qname." . shift @search) =~ s/\.$//;
720	my $depth = 2;	1291	my $depth = 10;
721		1292
722	# advance in cname-chain	1293	# advance in cname-chain
723	my $do_req; $do_req = sub {	1294	$do_req = sub {
724	$self->request ({	1295	$self->request ({
725	rd => 1,	1296	rd => 1,
726	qd => [[$name, $qtype, $class]],	1297	qd => [[$name, $qtype, $class]],
727	}, sub {	1298	}, sub {
728	my ($res) = @_	1299	my ($res) = @_
…		…
730		1301
731	my $cname;	1302	my $cname;
732		1303
733	while () {	1304	while () {
734	# results found?	1305	# results found?
735	my @rr = grep $_->[0] eq $name && ($atype{"*"} \|\| $atype{$_->[1]}), @{ $res->{an} };	1306	my @rr = grep $name eq lc $_->[0] && ($atype{"*"} \|\| $atype{$_->[1]}), @{ $res->{an} };
736		1307
737	return $cb->(@rr)	1308	(undef $do_search), (undef $do_req), return $cb->(@rr)
738	if @rr;	1309	if @rr;
739		1310
740	# see if there is a cname we can follow	1311	# see if there is a cname we can follow
741	my @rr = grep $_->[0] eq $name && $_->[1] eq "cname", @{ $res->{an} };	1312	my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} };
742		1313
743	if (@rr) {	1314	if (@rr) {
744	$depth--	1315	$depth--
745	or return $do_search->(); # cname chain too long	1316	or return $do_search->(); # cname chain too long
746		1317
747	$cname = 1;	1318	$cname = 1;
748	$name = $rr[0][3];	1319	$name = lc $rr[0][3];
749		1320
750	} elsif ($cname) {	1321	} elsif ($cname) {
751	# follow the cname	1322	# follow the cname
752	return $do_req->();	1323	return $do_req->();
753		1324
…		…
763	};	1334	};
764		1335
765	$do_search->();	1336	$do_search->();
766	}	1337	}
767		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
768	1;	1372	1;
769		1373
770	=back	1374	=back
771		1375
772	=head1 AUTHOR	1376	=head1 AUTHOR
773		1377
774	Marc Lehmann <schmorp@schmorp.de>	1378	Marc Lehmann <schmorp@schmorp.de>
775	http://home.schmorp.de/	1379	http://home.schmorp.de/
776		1380
777	=cut	1381	=cut
778		1382

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.2 by root, Fri May 23 02:59:32 2008 UTC vs. Revision 1.107 by root, Fri Jul 17 23:12:20 2009 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.2 by root, Fri May 23 02:59:32 2008 UTC vs.
Revision 1.107 by root, Fri Jul 17 23:12:20 2009 UTC