[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.120 by root, Tue Sep 1 17:36:34 2009 UTC

…		…
2		2
3	AnyEvent::DNS - fully asynchronous DNS resolution	3	AnyEvent::DNS - fully asynchronous DNS resolution
4		4
5	=head1 SYNOPSIS	5	=head1 SYNOPSIS
6		6
7	use AnyEvent::DNS;	7	use AnyEvent::DNS;
		8
		9	my $cv = AnyEvent->condvar;
		10	AnyEvent::DNS::a "www.google.de", $cv;
		11	# ... later
		12	my @addrs = $cv->recv;
8		13
9	=head1 DESCRIPTION	14	=head1 DESCRIPTION
10		15
11	This module offers both a number of DNS convenience functions as well	16	This module offers both a number of DNS convenience functions as well
12	as a fully asynchronous and high-performance pure-perl stub resolver.	17	as a fully asynchronous and high-performance pure-perl stub resolver.
13		18
		19	The stub resolver supports DNS over IPv4 and IPv6, UDP and TCP, optional
		20	EDNS0 support for up to 4kiB datagrams and automatically falls back to
		21	virtual circuit mode for large responses.
		22
14	=head2 CONVENIENCE FUNCTIONS	23	=head2 CONVENIENCE FUNCTIONS
15		24
16	# none yet
17
18	=over 4	25	=over 4
19		26
20	=cut	27	=cut
21		28
22	package AnyEvent::DNS;	29	package AnyEvent::DNS;
23		30
24	use strict;	31	use Carp ();
		32	use Socket qw(AF_INET SOCK_DGRAM SOCK_STREAM);
25		33
		34	use AnyEvent (); BEGIN { AnyEvent::common_sense }
26	use AnyEvent::Util ();	35	use AnyEvent::Util qw(AF_INET6);
		36
		37	our $VERSION = $AnyEvent::VERSION;
		38
		39	# some public dns servers
		40	our @DNS_FALLBACK = (
		41	v209.244.0.3, v209.244.0.4, # level3
		42	v4.2.2.1, v4.2.2.2, v4.2.2.3, v4.2.2.4, v4.2.2.5, v4.2.2.6, # vnsc-pri.sys.gtei.net
		43	);
		44
		45	=item AnyEvent::DNS::a $domain, $cb->(@addrs)
		46
		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).
		52
		53	=item AnyEvent::DNS::mx $domain, $cb->(@hostnames)
		54
		55	Tries to resolve the given domain into a sorted (lower preference value
		56	first) list of domain names.
		57
		58	=item AnyEvent::DNS::ns $domain, $cb->(@hostnames)
		59
		60	Tries to resolve the given domain name into a list of name servers.
		61
		62	=item AnyEvent::DNS::txt $domain, $cb->(@hostnames)
		63
		64	Tries to resolve the given domain name into a list of text records.
		65
		66	=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)
		67
		68	Tries to resolve the given service, protocol and domain name into a list
		69	of service records.
		70
		71	Each C<$srv_rr> is an array reference with the following contents:
		72	C<[$priority, $weight, $transport, $target]>.
		73
		74	They will be sorted with lowest priority first, then randomly
		75	distributed by weight as per RFC 2782.
		76
		77	Example:
		78
		79	AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...
		80	# @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )
		81
		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)
		94
		95	Tries to reverse-resolve the given IPv4 or IPv6 address (in textual form)
		96	into it's hostname(s). Handles V4MAPPED and V4COMPAT IPv6 addresses
		97	transparently.
		98
		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.
		109
		110	Example:
		111
		112	AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };
		113	# => f.root-servers.net
		114
		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
		120
		121	sub resolver;
		122
		123	sub a($$) {
		124	my ($domain, $cb) = @_;
		125
		126	resolver->resolve ($domain => "a", sub {
		127	$cb->(map $_->[3], @_);
		128	});
		129	}
		130
		131	sub aaaa($$) {
		132	my ($domain, $cb) = @_;
		133
		134	resolver->resolve ($domain => "aaaa", sub {
		135	$cb->(map $_->[3], @_);
		136	});
		137	}
		138
		139	sub mx($$) {
		140	my ($domain, $cb) = @_;
		141
		142	resolver->resolve ($domain => "mx", sub {
		143	$cb->(map $_->[4], sort { $a->[3] <=> $b->[3] } @_);
		144	});
		145	}
		146
		147	sub ns($$) {
		148	my ($domain, $cb) = @_;
		149
		150	resolver->resolve ($domain => "ns", sub {
		151	$cb->(map $_->[3], @_);
		152	});
		153	}
		154
		155	sub txt($$) {
		156	my ($domain, $cb) = @_;
		157
		158	resolver->resolve ($domain => "txt", sub {
		159	$cb->(map $_->[3], @_);
		160	});
		161	}
		162
		163	sub srv($$$$) {
		164	my ($service, $proto, $domain, $cb) = @_;
		165
		166	# todo, ask for any and check glue records
		167	resolver->resolve ("_$service._$proto.$domain" => "srv", sub {
		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);
		195	});
		196	}
		197
		198	sub ptr($$) {
		199	my ($domain, $cb) = @_;
		200
		201	resolver->resolve ($domain => "ptr", sub {
		202	$cb->(map $_->[3], @_);
		203	});
		204	}
		205
		206	sub any($$) {
		207	my ($domain, $cb) = @_;
		208
		209	resolver->resolve ($domain => "*", $cb);
		210	}
		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	#################################################################################
27		285
28	=back	286	=back
29		287
30	=head2 DNS EN-/DECODING FUNCTIONS	288	=head2 LOW-LEVEL DNS EN-/DECODING FUNCTIONS
31		289
32	=over 4	290	=over 4
33		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
34	=cut	299	=cut
		300
		301	our $EDNS0 = $ENV{PERL_ANYEVENT_EDNS0}*1; # set to 1 to enable (partial) edns0
35		302
36	our %opcode_id = (	303	our %opcode_id = (
37	query => 0,	304	query => 0,
38	iquery => 1,	305	iquery => 1,
39	status => 2,	306	status => 2,
		307	notify => 4,
		308	update => 5,
40	map +($_ => $_), 3..15	309	map +($_ => $_), 3, 6..15
41	);	310	);
42		311
43	our %opcode_str = reverse %opcode_id;	312	our %opcode_str = reverse %opcode_id;
44		313
45	our %rcode_id = (	314	our %rcode_id = (
46	ok => 0,	315	noerror => 0,
47	formerr => 1,	316	formerr => 1,
48	servfail => 2,	317	servfail => 2,
49	nxdomain => 3,	318	nxdomain => 3,
50	notimp => 4,	319	notimp => 4,
51	refused => 5,	320	refused => 5,
		321	yxdomain => 6, # Name Exists when it should not [RFC 2136]
		322	yxrrset => 7, # RR Set Exists when it should not [RFC 2136]
		323	nxrrset => 8, # RR Set that should exist does not [RFC 2136]
		324	notauth => 9, # Server Not Authoritative for zone [RFC 2136]
		325	notzone => 10, # Name not contained in zone [RFC 2136]
		326	# EDNS0 16 BADVERS Bad OPT Version [RFC 2671]
		327	# EDNS0 16 BADSIG TSIG Signature Failure [RFC 2845]
		328	# EDNS0 17 BADKEY Key not recognized [RFC 2845]
		329	# EDNS0 18 BADTIME Signature out of time window [RFC 2845]
		330	# EDNS0 19 BADMODE Bad TKEY Mode [RFC 2930]
		331	# EDNS0 20 BADNAME Duplicate key name [RFC 2930]
		332	# EDNS0 21 BADALG Algorithm not supported [RFC 2930]
52	map +($_ => $_), 6..15	333	map +($_ => $_), 11..15
53	);	334	);
54		335
55	our %rcode_str = reverse %rcode_id;	336	our %rcode_str = reverse %rcode_id;
56		337
57	our %type_id = (	338	our %type_id = (
…		…
71	minfo => 14,	352	minfo => 14,
72	mx => 15,	353	mx => 15,
73	txt => 16,	354	txt => 16,
74	aaaa => 28,	355	aaaa => 28,
75	srv => 33,	356	srv => 33,
		357	naptr => 35, # rfc2915
		358	dname => 39, # rfc2672
		359	opt => 41,
		360	spf => 99,
		361	tkey => 249,
		362	tsig => 250,
		363	ixfr => 251,
76	axfr => 252,	364	axfr => 252,
77	mailb => 253,	365	mailb => 253,
78	"*" => 255,	366	"*" => 255,
79	);	367	);
80		368
81	our %type_str = reverse %type_id;	369	our %type_str = reverse %type_id;
82		370
83	our %class_id = (	371	our %class_id = (
84	in => 1,	372	in => 1,
85	ch => 3,	373	ch => 3,
86	hs => 4,	374	hs => 4,
		375	none => 254,
87	"*" => 255,	376	"*" => 255,
88	);	377	);
89		378
90	our %class_str = reverse %class_id;	379	our %class_str = reverse %class_id;
91		380
92	# names MUST have a trailing dot
93	sub _enc_qname($) {	381	sub _enc_name($) {
94	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	};
95	}	390	}
96		391
97	sub _enc_qd() {	392	sub _enc_qd() {
98	(_enc_qname $_->[0]) . pack "nn",	393	(_enc_name $_->[0]) . pack "nn",
99	($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}),	394	($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}),
100	($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] \|\| "in"})	395	($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] \|\| "in"})
101	}	396	}
102		397
103	sub _enc_rr() {	398	sub _enc_rr() {
104	die "encoding of resource records is not supported";	399	die "encoding of resource records is not supported";
105	}	400	}
106		401
107	=item $pkt = AnyEvent::DNS::dns_pack $dns	402	=item $pkt = AnyEvent::DNS::dns_pack $dns
108		403
109	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
110	recommended, then everything will be totally clear. Or maybe not.	405	recommended, then everything will be totally clear. Or maybe not.
111		406
112	Resource records are not yet encodable.	407	Resource records are not yet encodable.
113		408
114	Examples:	409	Examples:
115		410
116	# very simple request, using lots of default values:	411	# very simple request, using lots of default values:
117	{ rd => 1, qd => [ [ "host.domain", "a"] ] }	412	{ rd => 1, qd => [ [ "host.domain", "a"] ] }
118		413
119	# more complex example, showing how flags etc. are named:	414	# more complex example, showing how flags etc. are named:
120		415
121	{	416	{
122	id => 10000,	417	id => 10000,
123	op => "query",	418	op => "query",
124	rc => "nxdomain",	419	rc => "nxdomain",
125		420
126	# flags	421	# flags
127	qr => 1,	422	qr => 1,
128	aa => 0,	423	aa => 0,
129	tc => 0,	424	tc => 0,
130	rd => 0,	425	rd => 0,
131	ra => 0,	426	ra => 0,
132		427	ad => 0,
		428	cd => 0,
		429
133	qd => [@rr], # query section	430	qd => [@rr], # query section
134	an => [@rr], # answer section	431	an => [@rr], # answer section
135	ns => [@rr], # authority section	432	ns => [@rr], # authority section
136	ar => [@rr], # additional records section	433	ar => [@rr], # additional records section
137	}	434	}
138		435
139	=cut	436	=cut
140		437
141	sub dns_pack($) {	438	sub dns_pack($) {
142	my ($req) = @_;	439	my ($req) = @_;
143		440
144	pack "nn nnnn a* a* a* a*",	441	pack "nn nnnn a* a* a* a* a*",
145	$req->{id},	442	$req->{id},
146		443
147	! !$req->{qr} * 0x8000	444	! !$req->{qr} * 0x8000
148	+ $opcode_id{$req->{op}} * 0x0800	445	+ $opcode_id{$req->{op}} * 0x0800
149	+ ! !$req->{aa} * 0x0400	446	+ ! !$req->{aa} * 0x0400
150	+ ! !$req->{tc} * 0x0200	447	+ ! !$req->{tc} * 0x0200
151	+ ! !$req->{rd} * 0x0100	448	+ ! !$req->{rd} * 0x0100
152	+ ! !$req->{ra} * 0x0080	449	+ ! !$req->{ra} * 0x0080
		450	+ ! !$req->{ad} * 0x0020
		451	+ ! !$req->{cd} * 0x0010
153	+ $rcode_id{$req->{rc}} * 0x0001,	452	+ $rcode_id{$req->{rc}} * 0x0001,
154		453
155	scalar @{ $req->{qd} \|\| [] },	454	scalar @{ $req->{qd} \|\| [] },
156	scalar @{ $req->{an} \|\| [] },	455	scalar @{ $req->{an} \|\| [] },
157	scalar @{ $req->{ns} \|\| [] },	456	scalar @{ $req->{ns} \|\| [] },
158	scalar @{ $req->{ar} \|\| [] },	457	$EDNS0 + scalar @{ $req->{ar} \|\| [] }, # EDNS0 option included here
159		458
160	(join "", map _enc_qd, @{ $req->{qd} \|\| [] }),	459	(join "", map _enc_qd, @{ $req->{qd} \|\| [] }),
161	(join "", map _enc_rr, @{ $req->{an} \|\| [] }),	460	(join "", map _enc_rr, @{ $req->{an} \|\| [] }),
162	(join "", map _enc_rr, @{ $req->{ns} \|\| [] }),	461	(join "", map _enc_rr, @{ $req->{ns} \|\| [] }),
163	(join "", map _enc_rr, @{ $req->{ar} \|\| [] });	462	(join "", map _enc_rr, @{ $req->{ar} \|\| [] }),
		463
		464	($EDNS0 ? pack "C nnNn", 0, 41, MAX_PKT, 0, 0 : "") # EDNS0 option
164	}	465	}
165		466
166	our $ofs;	467	our $ofs;
167	our $pkt;	468	our $pkt;
168		469
169	# bitches	470	# bitches
170	sub _dec_qname {	471	sub _dec_name {
171	my @res;	472	my @res;
172	my $redir;	473	my $redir;
173	my $ptr = $ofs;	474	my $ptr = $ofs;
174	my $cnt;	475	my $cnt;
175		476
176	while () {	477	while () {
177	return undef if ++$cnt >= 256; # to avoid DoS attacks	478	return undef if ++$cnt >= 256; # to avoid DoS attacks
178		479
179	my $len = ord substr $pkt, $ptr++, 1;	480	my $len = ord substr $pkt, $ptr++, 1;
180		481
181	if ($len & 0xc0) {	482	if ($len >= 0xc0) {
182	$ptr++;	483	$ptr++;
183	$ofs = $ptr if $ptr > $ofs;	484	$ofs = $ptr if $ptr > $ofs;
184	$ptr = (unpack "n", substr $pkt, $ptr - 2, 2) & 0x3fff;	485	$ptr = (unpack "n", substr $pkt, $ptr - 2, 2) & 0x3fff;
185	} elsif ($len) {	486	} elsif ($len) {
186	push @res, substr $pkt, $ptr, $len;	487	push @res, substr $pkt, $ptr, $len;
…		…
191	}	492	}
192	}	493	}
193	}	494	}
194		495
195	sub _dec_qd {	496	sub _dec_qd {
196	my $qname = _dec_qname;	497	my $qname = _dec_name;
197	my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;	498	my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;
198	[$qname, $type_str{$qt} \|\| $qt, $class_str{$qc} \|\| $qc]	499	[$qname, $type_str{$qt} \|\| $qt, $class_str{$qc} \|\| $qc]
199	}	500	}
200		501
201	our %dec_rr = (	502	our %dec_rr = (
202	1 => sub { Socket::inet_ntoa $_ }, # a	503	1 => sub { join ".", unpack "C4", $_ }, # a
203	2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns	504	2 => sub { local $ofs = $ofs - length; _dec_name }, # ns
204	5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname	505	5 => sub { local $ofs = $ofs - length; _dec_name }, # cname
205	6 => sub {	506	6 => sub {
206	local $ofs = $ofs - length;	507	local $ofs = $ofs - length;
207	my $mname = _dec_qname;	508	my $mname = _dec_name;
208	my $rname = _dec_qname;	509	my $rname = _dec_name;
209	($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)	510	($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)
210	}, # soa	511	}, # soa
211	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
212	12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr	513	12 => sub { local $ofs = $ofs - length; _dec_name }, # ptr
213	13 => sub { unpack "C/a C/a", $_ },	514	13 => sub { unpack "C/a* C/a*", $_ }, # hinfo
214	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
215	16 => sub { unpack "C/a", $_ }, # txt	516	16 => sub { unpack "(C/a)", $_ }, # txt
216	28 => sub { sprintf "%04x:%04x:%04x:%04x:%04x:%04x:%04x:%04x", unpack "n8" }, # aaaa	517	28 => sub { AnyEvent::Socket::format_ipv6 ($_) }, # aaaa
217	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
		526	99 => sub { unpack "(C/a)", $_ }, # spf
218	);	527	);
219		528
220	sub _dec_rr {	529	sub _dec_rr {
221	my $qname = _dec_qname;	530	my $name = _dec_name;
222		531
223	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;
224	local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen;	533	local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen;
225		534
226	[	535	[
227	$qname,	536	$name,
228	$type_str{$rt} \|\| $rt,	537	$type_str{$rt} \|\| $rt,
229	$class_str{$rc} \|\| $rc,	538	$class_str{$rc} \|\| $rc,
230	($dec_rr{$rt} \|\| sub { $_ })->(),	539	($dec_rr{$rt} \|\| sub { $_ })->(),
231	]	540	]
232	}	541	}
…		…
235		544
236	Unpacks a DNS packet into a perl data structure.	545	Unpacks a DNS packet into a perl data structure.
237		546
238	Examples:	547	Examples:
239		548
240	# a non-successful reply	549	# an unsuccessful reply
241	{	550	{
242	'qd' => [	551	'qd' => [
243	[ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]	552	[ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]
244	],	553	],
245	'rc' => 'nxdomain',	554	'rc' => 'nxdomain',
246	'ar' => [],	555	'ar' => [],
247	'ns' => [	556	'ns' => [
248	[	557	[
249	'uni-karlsruhe.de',	558	'uni-karlsruhe.de',
250	'soa',	559	'soa',
251	'in',	560	'in',
252	'netserv.rz.uni-karlsruhe.de',	561	'netserv.rz.uni-karlsruhe.de',
253	'hostmaster.rz.uni-karlsruhe.de',	562	'hostmaster.rz.uni-karlsruhe.de',
254	2008052201,	563	2008052201, 10800, 1800, 2592000, 86400
255	10800,
256	1800,
257	2592000,
258	86400
259	]	564	]
260	],	565	],
261	'tc' => '',	566	'tc' => '',
262	'ra' => 1,	567	'ra' => 1,
263	'qr' => 1,	568	'qr' => 1,
264	'id' => 45915,	569	'id' => 45915,
265	'aa' => '',	570	'aa' => '',
266	'an' => [],	571	'an' => [],
267	'rd' => 1,	572	'rd' => 1,
268	'op' => 'query'	573	'op' => 'query'
269	}	574	}
270		575
271	# a successful reply	576	# a successful reply
272		577
273	{	578	{
274	'qd' => [ [ 'www.google.de', 'a', 'in' ] ],	579	'qd' => [ [ 'www.google.de', 'a', 'in' ] ],
275	'rc' => 0,	580	'rc' => 0,
276	'ar' => [	581	'ar' => [
277	[ 'a.l.google.com', 'a', 'in', '209.85.139.9' ],	582	[ 'a.l.google.com', 'a', 'in', '209.85.139.9' ],
278	[ 'b.l.google.com', 'a', 'in', '64.233.179.9' ],	583	[ 'b.l.google.com', 'a', 'in', '64.233.179.9' ],
279	[ 'c.l.google.com', 'a', 'in', '64.233.161.9' ],	584	[ 'c.l.google.com', 'a', 'in', '64.233.161.9' ],
280	],	585	],
281	'ns' => [	586	'ns' => [
282	[ 'l.google.com', 'ns', 'in', 'a.l.google.com' ],	587	[ 'l.google.com', 'ns', 'in', 'a.l.google.com' ],
283	[ 'l.google.com', 'ns', 'in', 'b.l.google.com' ],	588	[ 'l.google.com', 'ns', 'in', 'b.l.google.com' ],
284	],	589	],
285	'tc' => '',	590	'tc' => '',
286	'ra' => 1,	591	'ra' => 1,
287	'qr' => 1,	592	'qr' => 1,
288	'id' => 64265,	593	'id' => 64265,
289	'aa' => '',	594	'aa' => '',
290	'an' => [	595	'an' => [
291	[ 'www.google.de', 'cname', 'in', 'www.google.com' ],	596	[ 'www.google.de', 'cname', 'in', 'www.google.com' ],
292	[ 'www.google.com', 'cname', 'in', 'www.l.google.com' ],	597	[ 'www.google.com', 'cname', 'in', 'www.l.google.com' ],
293	[ 'www.l.google.com', 'a', 'in', '66.249.93.104' ],	598	[ 'www.l.google.com', 'a', 'in', '66.249.93.104' ],
294	[ 'www.l.google.com', 'a', 'in', '66.249.93.147' ],	599	[ 'www.l.google.com', 'a', 'in', '66.249.93.147' ],
295	],	600	],
296	'rd' => 1,	601	'rd' => 1,
297	'op' => 0	602	'op' => 0
298	}	603	}
299		604
300	=cut	605	=cut
301		606
302	sub dns_unpack($) {	607	sub dns_unpack($) {
303	local $pkt = shift;	608	local $pkt = shift;
…		…
311	qr => ! ! ($flags & 0x8000),	616	qr => ! ! ($flags & 0x8000),
312	aa => ! ! ($flags & 0x0400),	617	aa => ! ! ($flags & 0x0400),
313	tc => ! ! ($flags & 0x0200),	618	tc => ! ! ($flags & 0x0200),
314	rd => ! ! ($flags & 0x0100),	619	rd => ! ! ($flags & 0x0100),
315	ra => ! ! ($flags & 0x0080),	620	ra => ! ! ($flags & 0x0080),
		621	ad => ! ! ($flags & 0x0020),
		622	cd => ! ! ($flags & 0x0010),
316	op => $opcode_str{($flags & 0x001e) >> 11},	623	op => $opcode_str{($flags & 0x001e) >> 11},
317	rc => $rcode_str{($flags & 0x000f)},	624	rc => $rcode_str{($flags & 0x000f)},
318		625
319	qd => [map _dec_qd, 1 .. $qd],	626	qd => [map _dec_qd, 1 .. $qd],
320	an => [map _dec_rr, 1 .. $an],	627	an => [map _dec_rr, 1 .. $an],
…		…
327		634
328	=back	635	=back
329		636
330	=head2 THE AnyEvent::DNS RESOLVER CLASS	637	=head2 THE AnyEvent::DNS RESOLVER CLASS
331		638
332	This is the class which deos the actual protocol work.	639	This is the class which does the actual protocol work.
333		640
334	=over 4	641	=over 4
335		642
336	=cut	643	=cut
337		644
…		…
350	calls.	657	calls.
351		658
352	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
353	resolver object.	660	resolver object.
354		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
355	=cut	671	=cut
356		672
357	our $RESOLVER;	673	our $RESOLVER;
358		674
359	sub resolver() {	675	sub resolver() {
360	$RESOLVER \|\| do {	676	$RESOLVER \|\| do {
361	$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})
362	$RESOLVER->load_resolv_conf;	685	: $RESOLVER->os_config;
		686
363	$RESOLVER	687	$RESOLVER
364	}	688	}
365	}	689	}
366		690
367	=item $resolver = new AnyEvent::DNS key => value...	691	=item $resolver = new AnyEvent::DNS key => value...
368		692
369	Creates and returns a new resolver. It only supports UDP, so make sure	693	Creates and returns a new resolver.
370	your answer sections fit into a DNS packet.
371		694
372	The following options are supported:	695	The following options are supported:
373		696
374	=over 4	697	=over 4
375		698
376	=item server => [...]	699	=item server => [...]
377		700
378	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
379	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).
380		704
381	=item timeout => [...]	705	=item timeout => [...]
382		706
383	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
384	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,
…		…
393	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
394	tries to resolve the name without any suffixes first.	718	tries to resolve the name without any suffixes first.
395		719
396	=item max_outstanding => $integer	720	=item max_outstanding => $integer
397		721
398	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
399	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>
400	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,
401	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.
402		738
403	=back	739	=back
404		740
405	=cut	741	=cut
406		742
407	sub new {	743	sub new {
408	my ($class, %arg) = @_;	744	my ($class, %arg) = @_;
409		745
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 {	746	my $self = bless {
416	server => [v127.0.0.1],	747	server => [],
417	timeout => [2, 5, 5],	748	timeout => [2, 5, 5],
418	search => [],	749	search => [],
419	ndots => 1,	750	ndots => 1,
420	max_outstanding => 10,	751	max_outstanding => 10,
421	reuse => 300, # reuse id's after 5 minutes only, if possible	752	reuse => 300,
422	%arg,	753	%arg,
423	fh => $fh,
424	reuse_q => [],	754	reuse_q => [],
425	}, $class;	755	}, $class;
426		756
427	# search should default to gethostname's domain	757	# search should default to gethostname's domain
428	# but perl lacks a good posix module	758	# but perl lacks a good posix module
429		759
		760	# try to create an ipv4 and an ipv6 socket
		761	# only fail when we cannot create either
		762	my $got_socket;
		763
430	Scalar::Util::weaken (my $wself = $self);	764	Scalar::Util::weaken (my $wself = $self);
431	$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";
432		792
433	$self->_compile;	793	$self->_compile;
434		794
435	$self	795	$self
436	}	796	}
437		797
438	=item $resolver->parse_resolv_conv ($string)	798	=item $resolver->parse_resolv_conf ($string)
439		799
440	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
441	directives are supported:	801	directives are supported (but not necessarily implemented).
442		802
443	C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,	803	C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,
444	C<options> (C<timeout>, C<attempts>, C<ndots>).	804	C<options> (C<timeout>, C<attempts>, C<ndots>).
445		805
446	Everything else is silently ignored.	806	Everything else is silently ignored.
…		…
454	$self->{search} = [];	814	$self->{search} = [];
455		815
456	my $attempts;	816	my $attempts;
457		817
458	for (split /\n/, $resolvconf) {	818	for (split /\n/, $resolvconf) {
459	if (/^\s*#/) {	819	s/#.*$//; # not quite legal, but many people insist
460	# comment	820
461	} elsif (/^\snameserver\s+(\S+)\s$/i) {	821	if (/^\snameserver\s+(\S+)\s$/i) {
462	my $ip = $1;	822	my $ip = $1;
463	if (AnyEvent::Util::dotted_quad $ip) {	823	if (my $ipn = AnyEvent::Socket::parse_address ($ip)) {
464	push @{ $self->{server} }, AnyEvent::Util::socket_inet_aton $ip;	824	push @{ $self->{server} }, $ipn;
465	} else {	825	} else {
466	warn "nameserver $ip invalid and ignored\n";	826	warn "nameserver $ip invalid and ignored\n";
467	}	827	}
468	} elsif (/^\sdomain\s+(\S)\s+$/i) {	828	} elsif (/^\sdomain\s+(\S)\s+$/i) {
469	$self->{search} = [$1];	829	$self->{search} = [$1];
…		…
490	if $attempts;	850	if $attempts;
491		851
492	$self->_compile;	852	$self->_compile;
493	}	853	}
494		854
495	=item $resolver->load_resolv_conf	855	sub _parse_resolv_conf_file {
		856	my ($self, $resolv_conf) = @_;
496		857
497	Tries to load and parse F</etc/resolv.conf>. If there will ever be windows
498	support, then this function will do the right thing under windows, too.
499
500	=cut
501
502	sub load_resolv_conf {
503	my ($self) = @_;
504
505	open my $fh, "</etc/resolv.conf"	858	open my $fh, "<", $resolv_conf
506	or return;	859	or Carp::croak "$resolv_conf: $!";
507		860
508	local $/;	861	local $/;
509	$self->parse_resolv_conf (<$fh>);	862	$self->parse_resolv_conf (<$fh>);
510	}	863	}
511		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
512	sub _compile {	958	sub _compile {
513	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	}
514		968
515	my @retry;	969	my @retry;
516		970
517	for my $timeout (@{ $self->{timeout} }) {	971	for my $timeout (@{ $self->{timeout} }) {
518	for my $server (@{ $self->{server} }) {	972	for my $server (@{ $self->{server} }) {
…		…
521	}	975	}
522		976
523	$self->{retry} = \@retry;	977	$self->{retry} = \@retry;
524	}	978	}
525		979
		980	sub _feed {
		981	my ($self, $res) = @_;
		982
		983	($res) = $res =~ /^(.*)$/s
		984	if AnyEvent::TAINT && $self->{untaint};
		985
		986	$res = dns_unpack $res
		987	or return;
		988
		989	my $id = $self->{id}{$res->{id}};
		990
		991	return unless ref $id;
		992
		993	$NOW = time;
		994	$id->[1]->($res);
		995	}
		996
526	sub _recv {	997	sub _recv {
527	my ($self) = @_;	998	my ($self, $pkt, $peer) = @_;
528		999
529	while (my $peer = recv $self->{fh}, my $res, 1024, 0) {	1000	# we ignore errors (often one gets port unreachable, but there is
		1001	# no good way to take advantage of that.
		1002
530	my ($port, $host) = Socket::unpack_sockaddr_in $peer;	1003	my ($port, $host) = AnyEvent::Socket::unpack_sockaddr ($peer);
531		1004
532	return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };	1005	return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };
533		1006
534	$res = AnyEvent::DNS::dns_unpack $res	1007	$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	}	1008	}
545		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
546	sub _exec {	1027	sub _exec {
547	my ($self, $req, $retry) = @_;	1028	my ($self, $req) = @_;
548		1029
		1030	my $retry; # of retries
		1031	my $do_retry;
		1032
		1033	$do_retry = sub {
549	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
550	my ($server, $timeout) = @$retry_cfg;	1041	my ($server, $timeout) = @$retry_cfg;
551		1042
552	$self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {	1043	$self->{id}{$req->[2]} = [(AE::timer $timeout, 0, sub {
553	$NOW = time;	1044	$NOW = time;
554		1045
555	# timeout, try next	1046	# timeout, try next
556	$self->_exec ($req, $retry + 1);	1047	&$do_retry if $do_retry;
557	}), sub {	1048	}), sub {
558	my ($res) = @_;	1049	my ($res) = @_;
559		1050
		1051	if ($res->{tc}) {
		1052	# success, but truncated, so use tcp
		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
		1056	my ($fh) = @_
		1057	or return &$do_retry;
		1058
		1059	require AnyEvent::Handle;
		1060
		1061	my $handle; $handle = new AnyEvent::Handle
		1062	fh => $fh,
		1063	timeout => $timeout,
		1064	on_error => sub {
		1065	undef $handle;
		1066	return unless $do_retry; # some other request could have invalidated us already
		1067	# failure, try next
		1068	&$do_retry;
		1069	};
		1070
		1071	$handle->push_write (pack "n/a", $req->[0]);
		1072	$handle->push_read (chunk => 2, sub {
		1073	$handle->unshift_read (chunk => (unpack "n", $_[1]), sub {
		1074	undef $handle;
		1075	$self->_feed ($_[1]);
		1076	});
		1077	});
		1078
		1079	}, sub { $timeout });
		1080
		1081	} else {
560	# success	1082	# success
561	$self->{id}{$req->[2]} = 1;	1083	$self->_free_id ($req->[2], $retry > 1);
562	push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];	1084	undef $do_retry; return $req->[1]->($res);
563	--$self->{outstanding};	1085	}
564	$self->_scheduler;
565
566	$req->[1]->($res);
567	}];	1086	}];
		1087
		1088	my $sa = AnyEvent::Socket::pack_sockaddr (DOMAIN_PORT, $server);
568		1089
569	send $self->{fh}, $req->[0], 0, Socket::pack_sockaddr_in 53, $server;	1090	my $fh = AF_INET == AnyEvent::Socket::sockaddr_family ($sa)
570	} else {	1091	? $self->{fh4} : $self->{fh6}
571	# failure	1092	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		1093
577	$req->[1]->();	1094	send $fh, $req->[0], 0, $sa;
578	}	1095	};
		1096
		1097	&$do_retry;
579	}	1098	}
580		1099
581	sub _scheduler {	1100	sub _scheduler {
582	my ($self) = @_;	1101	my ($self) = @_;
583		1102
		1103	no strict 'refs';
		1104
584	$NOW = time;	1105	$NOW = time;
585		1106
586	# first clear id reuse queue	1107	# first clear id reuse queue
587	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }	1108	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }
588	while @{ $self->{reuse_q} } && $self->{reuse_q}[0] <= $NOW;	1109	while @{ $self->{reuse_q} } && $self->{reuse_q}[0][0] <= $NOW;
589		1110
590	while ($self->{outstanding} < $self->{max_outstanding}) {	1111	while ($self->{outstanding} < $self->{max_outstanding}) {
591	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	};
592	or last;	1119	last;
593
594	while () {
595	$req->[2] = int rand 65536;
596	last unless exists $self->{id}{$req->[2]};
597	}	1120	}
598		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};
599	$self->{id}{$req->[2]} = 1;	1130	$self->{id}{$req->[2]} = 1;
600	substr $req->[0], 0, 2, pack "n", $req->[2];	1131	substr $req->[0], 0, 2, pack "n", $req->[2];
601		1132
602	++$self->{outstanding};
603	$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	}
604	}	1143	}
605	}	1144	}
606		1145
607	=item $resolver->request ($req, $cb->($res))	1146	=item $resolver->request ($req, $cb->($res))
608		1147
		1148	This is the main low-level workhorse for sending DNS requests.
		1149
609	Sends a single request (a hash-ref formated as specified for	1150	This function sends a single request (a hash-ref formated as specified
610	C<AnyEvent::DNS::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
611	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
612	was received, or no arguments on timeout.	1156	received, or no arguments in case none of the servers answered.
613		1157
614	=cut	1158	=cut
615		1159
616	sub request($$) {	1160	sub request($$) {
617	my ($self, $req, $cb) = @_;	1161	my ($self, $req, $cb) = @_;
618		1162
619	push @{ $self->{queue} }, [(AnyEvent::DNS::dns_pack $req), $cb];	1163	push @{ $self->{queue} }, [dns_pack $req, $cb];
620	$self->_scheduler;	1164	$self->_scheduler;
621	}	1165	}
622		1166
623	=item $resolver->resolve ($qname, $qtype, %options, $cb->($rcode, @rr))	1167	=item $resolver->resolve ($qname, $qtype, %options, $cb->(@rr))
624		1168
625	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>.
626	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.
627		1176
628	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
629	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.
630		1179
631	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.
		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
		1193	Note that this resolver is just a stub resolver: it requires a name server
		1194	supporting recursive queries, will not do any recursive queries itself and
		1195	is not secure when used against an untrusted name server.
632		1196
633	The following options are supported:	1197	The following options are supported:
634		1198
635	=over 4	1199	=over 4
636		1200
637	=item search => [$suffix...]	1201	=item search => [$suffix...]
638		1202
639	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
640	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
641	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
642	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.
643		1208
644	=item accept => [$type...]	1209	=item accept => [$type...]
645		1210
646	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
647	accepted and returned. The default includes the C<$qtype> and nothing	1212	accepted and returned. The default includes the C<$qtype> and nothing
648	else.	1213	else. If this list includes C<cname>, then CNAME-chains will not be
		1214	followed (because you asked for the CNAME record).
649		1215
650	=item class => "class"	1216	=item class => "class"
651		1217
652	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
653	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.
654		1220
655	=back	1221	=back
656		1222
657	Examples:	1223	Examples:
658		1224
659	$res->resolve ("ruth.plan9.de", "a", sub {	1225	# full example, you can paste this into perl:
660	warn Dumper [@_];	1226	use Data::Dumper;
661	});	1227	use AnyEvent::DNS;
		1228	AnyEvent::DNS::resolver->resolve (
		1229	"google.com", "*", my $cv = AnyEvent->condvar);
		1230	warn Dumper [$cv->recv];
662		1231
		1232	# shortened result:
663	[	1233	# [
		1234	# [ 'google.com', 'soa', 'in', 'ns1.google.com', 'dns-admin.google.com',
		1235	# 2008052701, 7200, 1800, 1209600, 300 ],
664	[	1236	# [
665	'ruth.schmorp.de',	1237	# 'google.com', 'txt', 'in',
666	'a',	1238	# 'v=spf1 include:_netblocks.google.com ~all'
667	'in',	1239	# ],
668	'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' ],
669	]	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' ]
670	]	1251	# ]
671		1252
		1253	# resolve any records, but return only a and aaaa records:
672	$res->resolve ("test1.laendle", "*",	1254	$res->resolve ("test1.laendle", "*",
673	accept => ["a", "aaaa"],	1255	accept => ["a", "aaaa"],
674	sub {	1256	sub {
675	warn Dumper [@_];	1257	warn Dumper [@_];
676	}	1258	}
677	);	1259	);
678		1260
679	[	1261	# result:
680	[	1262	# [
681	'test1.laendle',	1263	# [ 'test1.laendle', 'a', 'in', '10.0.0.255' ],
682	'a',	1264	# [ '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	]	1265	# ]
692	]
693		1266
694	=cut	1267	=cut
695		1268
696	sub resolve($%) {	1269	sub resolve($%) {
697	my $cb = pop;	1270	my $cb = pop;
…		…
710	my %atype = $opt{accept}	1283	my %atype = $opt{accept}
711	? map +($_ => 1), @{ $opt{accept} }	1284	? map +($_ => 1), @{ $opt{accept} }
712	: ($qtype => 1);	1285	: ($qtype => 1);
713		1286
714	# advance in searchlist	1287	# advance in searchlist
715	my $do_search; $do_search = sub {	1288	my ($do_search, $do_req);
		1289
		1290	$do_search = sub {
716	@search	1291	@search
717	or return $cb->();	1292	or (undef $do_search), (undef $do_req), return $cb->();
718		1293
719	(my $name = "$qname." . shift @search) =~ s/\.$//;	1294	(my $name = lc "$qname." . shift @search) =~ s/\.$//;
720	my $depth = 2;	1295	my $depth = 10;
721		1296
722	# advance in cname-chain	1297	# advance in cname-chain
723	my $do_req; $do_req = sub {	1298	$do_req = sub {
724	$self->request ({	1299	$self->request ({
725	rd => 1,	1300	rd => 1,
726	qd => [[$name, $qtype, $class]],	1301	qd => [[$name, $qtype, $class]],
727	}, sub {	1302	}, sub {
728	my ($res) = @_	1303	my ($res) = @_
…		…
730		1305
731	my $cname;	1306	my $cname;
732		1307
733	while () {	1308	while () {
734	# results found?	1309	# results found?
735	my @rr = grep $_->[0] eq $name && ($atype{"*"} \|\| $atype{$_->[1]}), @{ $res->{an} };	1310	my @rr = grep $name eq lc $_->[0] && ($atype{"*"} \|\| $atype{$_->[1]}), @{ $res->{an} };
736		1311
737	return $cb->(@rr)	1312	(undef $do_search), (undef $do_req), return $cb->(@rr)
738	if @rr;	1313	if @rr;
739		1314
740	# see if there is a cname we can follow	1315	# see if there is a cname we can follow
741	my @rr = grep $_->[0] eq $name && $_->[1] eq "cname", @{ $res->{an} };	1316	my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} };
742		1317
743	if (@rr) {	1318	if (@rr) {
744	$depth--	1319	$depth--
745	or return $do_search->(); # cname chain too long	1320	or return $do_search->(); # cname chain too long
746		1321
747	$cname = 1;	1322	$cname = 1;
748	$name = $rr[0][3];	1323	$name = lc $rr[0][3];
749		1324
750	} elsif ($cname) {	1325	} elsif ($cname) {
751	# follow the cname	1326	# follow the cname
752	return $do_req->();	1327	return $do_req->();
753		1328
…		…
763	};	1338	};
764		1339
765	$do_search->();	1340	$do_search->();
766	}	1341	}
767		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
768	1;	1376	1;
769		1377
770	=back	1378	=back
771		1379
772	=head1 AUTHOR	1380	=head1 AUTHOR
773		1381
774	Marc Lehmann <schmorp@schmorp.de>	1382	Marc Lehmann <schmorp@schmorp.de>
775	http://home.schmorp.de/	1383	http://home.schmorp.de/
776		1384
777	=cut	1385	=cut
778		1386

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.120 by root, Tue Sep 1 17:36:34 2009 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.2 by root, Fri May 23 02:59:32 2008 UTC vs.
Revision 1.120 by root, Tue Sep 1 17:36:34 2009 UTC