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

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

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.14 by root, Fri May 23 16:00:36 2008 UTC vs. Revision 1.103 by root, Thu Jul 9 08:31:16 2009 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.14 by root, Fri May 23 16:00:36 2008 UTC vs.
Revision 1.103 by root, Thu Jul 9 08:31:16 2009 UTC