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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.4 by root, Fri May 23 04:10:40 2008 UTC vs.
Revision 1.98 by root, Fri Jul 3 21:44:14 2009 UTC

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

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.4 by root, Fri May 23 04:10:40 2008 UTC vs. Revision 1.98 by root, Fri Jul 3 21:44:14 2009 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.4 by root, Fri May 23 04:10:40 2008 UTC vs.
Revision 1.98 by root, Fri Jul 3 21:44:14 2009 UTC