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

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.104 by root, Fri Jul 10 22:35:27 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.104 by root, Fri Jul 10 22:35:27 2009 UTC