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

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

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.28 by root, Sun May 25 01:05:27 2008 UTC vs. Revision 1.98 by root, Fri Jul 3 21:44:14 2009 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.28 by root, Sun May 25 01:05:27 2008 UTC vs.
Revision 1.98 by root, Fri Jul 3 21:44:14 2009 UTC