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

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

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.3 by root, Fri May 23 03:20:53 2008 UTC vs. Revision 1.115 by root, Thu Aug 6 13:31:01 2009 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.3 by root, Fri May 23 03:20:53 2008 UTC vs.
Revision 1.115 by root, Thu Aug 6 13:31:01 2009 UTC