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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.7 by root, Fri May 23 05:30:59 2008 UTC vs.
Revision 1.121 by root, Tue Sep 1 18:27:46 2009 UTC

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

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.7 by root, Fri May 23 05:30:59 2008 UTC vs. Revision 1.121 by root, Tue Sep 1 18:27:46 2009 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.7 by root, Fri May 23 05:30:59 2008 UTC vs.
Revision 1.121 by root, Tue Sep 1 18:27:46 2009 UTC