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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.18 by root, Fri May 23 22:52:31 2008 UTC vs.
Revision 1.60 by root, Tue Jun 3 09:02:46 2008 UTC

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

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.18 by root, Fri May 23 22:52:31 2008 UTC vs. Revision 1.60 by root, Tue Jun 3 09:02:46 2008 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.18 by root, Fri May 23 22:52:31 2008 UTC vs.
Revision 1.60 by root, Tue Jun 3 09:02:46 2008 UTC