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

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

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.26 by root, Sat May 24 18:50:40 2008 UTC vs. Revision 1.108 by root, Sat Jul 18 05:19:09 2009 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.26 by root, Sat May 24 18:50:40 2008 UTC vs.
Revision 1.108 by root, Sat Jul 18 05:19:09 2009 UTC