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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.2 by root, Fri May 23 02:59:32 2008 UTC vs.
Revision 1.75 by root, Thu Aug 21 23:48:35 2008 UTC

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

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.2 by root, Fri May 23 02:59:32 2008 UTC vs. Revision 1.75 by root, Thu Aug 21 23:48:35 2008 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.2 by root, Fri May 23 02:59:32 2008 UTC vs.
Revision 1.75 by root, Thu Aug 21 23:48:35 2008 UTC