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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.1 by root, Fri May 23 02:47:50 2008 UTC vs.
Revision 1.96 by root, Mon Jun 29 21:00:32 2009 UTC

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

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.1 by root, Fri May 23 02:47:50 2008 UTC vs. Revision 1.96 by root, Mon Jun 29 21:00:32 2009 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.1 by root, Fri May 23 02:47:50 2008 UTC vs.
Revision 1.96 by root, Mon Jun 29 21:00:32 2009 UTC