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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.6 by root, Fri May 23 05:16:57 2008 UTC vs.
Revision 1.106 by root, Fri Jul 17 18:08:35 2009 UTC

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

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.6 by root, Fri May 23 05:16:57 2008 UTC vs. Revision 1.106 by root, Fri Jul 17 18:08:35 2009 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.6 by root, Fri May 23 05:16:57 2008 UTC vs.
Revision 1.106 by root, Fri Jul 17 18:08:35 2009 UTC