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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.33 by root, Mon May 26 05:09:53 2008 UTC vs.
Revision 1.100 by root, Sun Jul 5 01:38:43 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", $cv;	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
…		…
31	no warnings;	31	no warnings;
32	use strict;	32	use strict;
33		33
34	use Socket qw(AF_INET SOCK_DGRAM SOCK_STREAM);	34	use Socket qw(AF_INET SOCK_DGRAM SOCK_STREAM);
35		35
36	use AnyEvent qw(WIN32);	36	use AnyEvent ();
37	use AnyEvent::Handle ();	37	use AnyEvent::Util qw(AF_INET6);
		38
		39	our $VERSION = 4.452;
38		40
39	our @DNS_FALLBACK = (v208.67.220.220, v208.67.222.222);	41	our @DNS_FALLBACK = (v208.67.220.220, v208.67.222.222);
40
41	=item AnyEvent::DNS::addr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...)
42
43	Tries to resolve the given nodename and service name into protocol families
44	and sockaddr structures usable to connect to this node and service in a
45	protocol-independent way. It works remotely similar to the getaddrinfo
46	posix function.
47
48	C<$node> is either an IPv4 or IPv6 address or a hostname, C<$service> is
49	either a service name (port name from F</etc/services>) or a numerical
50	port number. If both C<$node> and C<$service> are names, then SRV records
51	will be consulted to find the real service, otherwise they will be
52	used as-is. If you know that the service name is not in your services
53	database, then you can specify the service in the format C<name=port>
54	(e.g. C<http=80>).
55
56	C<$proto> must be a protocol name, currently C<tcp>, C<udp> or
57	C<sctp>. The default is C<tcp>.
58
59	C<$family> must be either C<0> (meaning any protocol is OK), C<4> (use
60	only IPv4) or C<6> (use only IPv6). This setting might be influenced by
61	C<$ENV{PERL_ANYEVENT_PROTOCOLS}>.
62
63	C<$type> must be C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_SEQPACKET> (or
64	C<undef> in which case it gets automatically chosen).
65
66	The callback will receive zero or more array references that contain
67	C<$family, $type, $proto> for use in C<socket> and a binary
68	C<$sockaddr> for use in C<connect> (or C<bind>).
69
70	The application should try these in the order given.
71
72	Example:
73
74	AnyEvent::DNS::addr "google.com", "http", 0, undef, undef, sub { ... };
75		42
76	=item AnyEvent::DNS::a $domain, $cb->(@addrs)	43	=item AnyEvent::DNS::a $domain, $cb->(@addrs)
77		44
78	Tries to resolve the given domain to IPv4 address(es).	45	Tries to resolve the given domain to IPv4 address(es).
79		46
…		…
97	=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)	64	=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)
98		65
99	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
100	of service records.	67	of service records.
101		68
102	Each srv_rr is an array reference with the following contents:	69	Each C<$srv_rr> is an array reference with the following contents:
103	C<[$priority, $weight, $transport, $target]>.	70	C<[$priority, $weight, $transport, $target]>.
104		71
105	They will be sorted with lowest priority, highest weight first (TODO:	72	They will be sorted with lowest priority first, then randomly
106	should use the RFC algorithm to reorder same-priority records for weight).	73	distributed by weight as per RFC 2782.
107		74
108	Example:	75	Example:
109		76
110	AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...	77	AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...
111	# @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )	78	# @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )
112		79
113	=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)
114		92
115	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)
116	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.
117		107
118	Example:	108	Example:
119		109
120	AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };	110	AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };
121	# => f.root-servers.net	111	# => f.root-servers.net
122		112
123	=item AnyEvent::DNS::any $domain, $cb->(@rrs)
124
125	Tries to resolve the given domain and passes all resource records found to
126	the callback.
127
128	=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
129		118
130	sub resolver;	119	sub resolver;
131		120
132	sub a($$) {	121	sub a($$) {
133	my ($domain, $cb) = @_;	122	my ($domain, $cb) = @_;
…		…
172	sub srv($$$$) {	161	sub srv($$$$) {
173	my ($service, $proto, $domain, $cb) = @_;	162	my ($service, $proto, $domain, $cb) = @_;
174		163
175	# todo, ask for any and check glue records	164	# todo, ask for any and check glue records
176	resolver->resolve ("_$service._$proto.$domain" => "srv", sub {	165	resolver->resolve ("_$service._$proto.$domain" => "srv", sub {
177	$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);
178	});	193	});
179	}	194	}
180		195
181	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($$) {
182	my ($ip, $cb) = @_;	238	my ($ip, $cb) = @_;
183		239
184	$ip = AnyEvent::Socket::parse_ip ($ip)	240	$ip = _munge_ptr AnyEvent::Socket::parse_address ($ip)
185	or return $cb->();	241	or return $cb->();
186
187	if (4 == length $ip) {
188	$ip = join ".", (reverse split /\./, $ip), "in-addr.arpa.";
189	} else {
190	$ip = join ".", (reverse split //, unpack "H*", $ip), "ip6.arpa.";
191	}
192		242
193	resolver->resolve ($ip => "ptr", sub {	243	resolver->resolve ($ip => "ptr", sub {
194	$cb->(map $_->[3], @_);	244	$cb->(map $_->[3], @_);
195	});	245	});
196	}	246	}
197		247
198	sub any($$) {	248	sub reverse_verify($$) {
199	my ($domain, $cb) = @_;	249	my ($ip, $cb) = @_;
200		250
201	resolver->resolve ($domain => "*", $cb);	251	my $ipn = AnyEvent::Socket::parse_address ($ip)
202	}
203
204	#############################################################################
205
206	sub addr($$$$$$) {
207	my ($node, $service, $proto, $family, $type, $cb) = @_;
208
209	unless (&AnyEvent::Util::AF_INET6) {
210	$family != 6
211	or return $cb->();	252	or return $cb->();
212		253
213	$family \|\|= 4;	254	my $af = AnyEvent::Socket::address_family ($ipn);
214	}
215		255
216	$cb->() if $family == 4 && !$AnyEvent::PROTOCOL{ipv4};
217	$cb->() if $family == 6 && !$AnyEvent::PROTOCOL{ipv6};
218
219	$family \|\|=4 unless $AnyEvent::PROTOCOL{ipv6};
220	$family \|\|=6 unless $AnyEvent::PROTOCOL{ipv4};
221
222	$proto \|\|= "tcp";
223	$type \|\|= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;
224
225	my $proton = (getprotobyname $proto)[2]
226	or Carp::croak "$proto: protocol unknown";
227
228	my $port;
229
230	if ($service =~ /^(\S+)=(\d+)$/) {
231	($service, $port) = ($1, $2);
232	} elsif ($service =~ /^\d+$/) {
233	($service, $port) = (undef, $service);
234	} else {
235	$port = (getservbyname $service, $proto)[2]
236	or Carp::croak "$service/$proto: service unknown";
237	}
238
239	my @target = [$node, $port];
240
241	# resolve a records / provide sockaddr structures
242	my $resolve = sub {
243	my @res;	256	my @res;
244	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;
245	$cb->(	267
246	map $_->[2],	268	# () around AF_INET to work around bug in 5.8
		269	resolver->resolve ("$name." => ($af == (AF_INET) ? "a" : "aaaa"), sub {
247	sort {	270	for (@_) {
248	$AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]}	271	push @res, $name
249	or $a->[0] <=> $b->[0]	272	if $_->[3] eq $ip;
250	}	273	}
251	@res	274	$cb->(@res) unless --$cnt;
252	)	275	});
253	});
254
255	$cv->begin;
256	for my $idx (0 .. $#target) {
257	my ($node, $port) = @{ $target[$idx] };
258
259	if (my $noden = AnyEvent::Socket::parse_ip ($node)) {
260	if (4 == length $noden && $family != 6) {
261	push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
262	AnyEvent::Socket::pack_sockaddr ($port, $noden)]]
263	}
264
265	if (16 == length $noden && $family != 4) {
266	push @res, [$idx, "ipv6", [&AnyEvent::Util::AF_INET6, $type, $proton,
267	AnyEvent::Socket::pack_sockaddr ( $port, $noden)]]
268	}
269	} else {
270	# ipv4
271	if ($family != 6) {
272	$cv->begin;
273	a $node, sub {
274	push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
275	AnyEvent::Socket::pack_sockaddr ($port, AnyEvent::Socket::parse_ipv4 ($_))]]
276	for @_;
277	$cv->end;
278	};
279	}
280
281	# ipv6
282	if ($family != 4) {
283	$cv->begin;
284	aaaa $node, sub {
285	push @res, [$idx, "ipv6", [&AnyEvent::Socket::AF_INET6, $type, $proton,
286	AnyEvent::Socket::pack_sockaddr ($port, AnyEvent::Socket::parse_ipv6 ($_))]]
287	for @_;
288	$cv->end;
289	};
290	}
291	}
292	}	276	}
293	$cv->end;	277
		278	$cb->() unless $cnt;
294	};	279	};
295
296	# try srv records, if applicable
297	if ($node eq "localhost") {
298	@target = (["127.0.0.1", $port], ["::1", $port]);
299	&$resolve;
300	} elsif (defined $service && !AnyEvent::Socket::parse_ip ($node)) {
301	srv $service, $proto, $node, sub {
302	my (@srv) = @_;
303
304	# no srv records, continue traditionally
305	@srv
306	or return &$resolve;
307
308	# only srv record has "." => abort
309	$srv[0][2] ne "." \|\| $#srv
310	or return $cb->();
311
312	# use srv records then
313	@target = map ["$_->[3].", $_->[2]],
314	grep $_->[3] ne ".",
315	@srv;
316
317	&$resolve;
318	};
319	} else {
320	&$resolve;
321	}
322	}	280	}
323		281
324	#############################################################################	282	#################################################################################
325		283
326	=back	284	=back
327		285
328	=head2 LOW-LEVEL DNS EN-/DECODING FUNCTIONS	286	=head2 LOW-LEVEL DNS EN-/DECODING FUNCTIONS
329		287
…		…
331		289
332	=item $AnyEvent::DNS::EDNS0	290	=item $AnyEvent::DNS::EDNS0
333		291
334	This variable decides whether dns_pack automatically enables EDNS0	292	This variable decides whether dns_pack automatically enables EDNS0
335	support. By default, this is disabled (C<0>), unless overridden by	293	support. By default, this is disabled (C<0>), unless overridden by
336	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
337	EDNS0 in all requests.	295	EDNS0 in all requests.
338		296
339	=cut	297	=cut
340		298
341	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
342		300
343	our %opcode_id = (	301	our %opcode_id = (
344	query => 0,	302	query => 0,
345	iquery => 1,	303	iquery => 1,
346	status => 2,	304	status => 2,
…		…
392	minfo => 14,	350	minfo => 14,
393	mx => 15,	351	mx => 15,
394	txt => 16,	352	txt => 16,
395	aaaa => 28,	353	aaaa => 28,
396	srv => 33,	354	srv => 33,
		355	naptr => 35, # rfc2915
		356	dname => 39, # rfc2672
397	opt => 41,	357	opt => 41,
398	spf => 99,	358	spf => 99,
399	tkey => 249,	359	tkey => 249,
400	tsig => 250,	360	tsig => 250,
401	ixfr => 251,	361	ixfr => 251,
…		…
414	"*" => 255,	374	"*" => 255,
415	);	375	);
416		376
417	our %class_str = reverse %class_id;	377	our %class_str = reverse %class_id;
418		378
419	# names MUST have a trailing dot
420	sub _enc_qname($) {	379	sub _enc_name($) {
421	pack "(C/a)", (split /\./, shift), ""	380	pack "(C/a)", (split /\./, shift), ""
422	}	381	}
423		382
424	sub _enc_qd() {	383	sub _enc_qd() {
425	(_enc_qname $_->[0]) . pack "nn",	384	(_enc_name $_->[0]) . pack "nn",
426	($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}),	385	($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}),
427	($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] \|\| "in"})	386	($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] \|\| "in"})
428	}	387	}
429		388
430	sub _enc_rr() {	389	sub _enc_rr() {
431	die "encoding of resource records is not supported";	390	die "encoding of resource records is not supported";
432	}	391	}
433		392
434	=item $pkt = AnyEvent::DNS::dns_pack $dns	393	=item $pkt = AnyEvent::DNS::dns_pack $dns
435		394
436	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
437	recommended, then everything will be totally clear. Or maybe not.	396	recommended, then everything will be totally clear. Or maybe not.
438		397
439	Resource records are not yet encodable.	398	Resource records are not yet encodable.
440		399
441	Examples:	400	Examples:
442		401
443	# very simple request, using lots of default values:	402	# very simple request, using lots of default values:
444	{ rd => 1, qd => [ [ "host.domain", "a"] ] }	403	{ rd => 1, qd => [ [ "host.domain", "a"] ] }
445		404
446	# more complex example, showing how flags etc. are named:	405	# more complex example, showing how flags etc. are named:
447		406
448	{	407	{
449	id => 10000,	408	id => 10000,
450	op => "query",	409	op => "query",
451	rc => "nxdomain",	410	rc => "nxdomain",
452		411
453	# flags	412	# flags
454	qr => 1,	413	qr => 1,
455	aa => 0,	414	aa => 0,
456	tc => 0,	415	tc => 0,
457	rd => 0,	416	rd => 0,
458	ra => 0,	417	ra => 0,
459	ad => 0,	418	ad => 0,
460	cd => 0,	419	cd => 0,
461		420
462	qd => [@rr], # query section	421	qd => [@rr], # query section
463	an => [@rr], # answer section	422	an => [@rr], # answer section
464	ns => [@rr], # authority section	423	ns => [@rr], # authority section
465	ar => [@rr], # additional records section	424	ar => [@rr], # additional records section
466	}	425	}
467		426
468	=cut	427	=cut
469		428
470	sub dns_pack($) {	429	sub dns_pack($) {
471	my ($req) = @_;	430	my ($req) = @_;
…		…
484	+ $rcode_id{$req->{rc}} * 0x0001,	443	+ $rcode_id{$req->{rc}} * 0x0001,
485		444
486	scalar @{ $req->{qd} \|\| [] },	445	scalar @{ $req->{qd} \|\| [] },
487	scalar @{ $req->{an} \|\| [] },	446	scalar @{ $req->{an} \|\| [] },
488	scalar @{ $req->{ns} \|\| [] },	447	scalar @{ $req->{ns} \|\| [] },
489	$EDNS0 + scalar @{ $req->{ar} \|\| [] }, # include EDNS0 option here	448	$EDNS0 + scalar @{ $req->{ar} \|\| [] }, # EDNS0 option included here
490		449
491	(join "", map _enc_qd, @{ $req->{qd} \|\| [] }),	450	(join "", map _enc_qd, @{ $req->{qd} \|\| [] }),
492	(join "", map _enc_rr, @{ $req->{an} \|\| [] }),	451	(join "", map _enc_rr, @{ $req->{an} \|\| [] }),
493	(join "", map _enc_rr, @{ $req->{ns} \|\| [] }),	452	(join "", map _enc_rr, @{ $req->{ns} \|\| [] }),
494	(join "", map _enc_rr, @{ $req->{ar} \|\| [] }),	453	(join "", map _enc_rr, @{ $req->{ar} \|\| [] }),
495		454
496	($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
497	}	456	}
498		457
499	our $ofs;	458	our $ofs;
500	our $pkt;	459	our $pkt;
501		460
502	# bitches	461	# bitches
503	sub _dec_qname {	462	sub _dec_name {
504	my @res;	463	my @res;
505	my $redir;	464	my $redir;
506	my $ptr = $ofs;	465	my $ptr = $ofs;
507	my $cnt;	466	my $cnt;
508		467
509	while () {	468	while () {
510	return undef if ++$cnt >= 256; # to avoid DoS attacks	469	return undef if ++$cnt >= 256; # to avoid DoS attacks
511		470
512	my $len = ord substr $pkt, $ptr++, 1;	471	my $len = ord substr $pkt, $ptr++, 1;
513		472
514	if ($len & 0xc0) {	473	if ($len >= 0xc0) {
515	$ptr++;	474	$ptr++;
516	$ofs = $ptr if $ptr > $ofs;	475	$ofs = $ptr if $ptr > $ofs;
517	$ptr = (unpack "n", substr $pkt, $ptr - 2, 2) & 0x3fff;	476	$ptr = (unpack "n", substr $pkt, $ptr - 2, 2) & 0x3fff;
518	} elsif ($len) {	477	} elsif ($len) {
519	push @res, substr $pkt, $ptr, $len;	478	push @res, substr $pkt, $ptr, $len;
…		…
524	}	483	}
525	}	484	}
526	}	485	}
527		486
528	sub _dec_qd {	487	sub _dec_qd {
529	my $qname = _dec_qname;	488	my $qname = _dec_name;
530	my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;	489	my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;
531	[$qname, $type_str{$qt} \|\| $qt, $class_str{$qc} \|\| $qc]	490	[$qname, $type_str{$qt} \|\| $qt, $class_str{$qc} \|\| $qc]
532	}	491	}
533		492
534	our %dec_rr = (	493	our %dec_rr = (
535	1 => sub { join ".", unpack "C4", $_ }, # a	494	1 => sub { join ".", unpack "C4", $_ }, # a
536	2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns	495	2 => sub { local $ofs = $ofs - length; _dec_name }, # ns
537	5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname	496	5 => sub { local $ofs = $ofs - length; _dec_name }, # cname
538	6 => sub {	497	6 => sub {
539	local $ofs = $ofs - length;	498	local $ofs = $ofs - length;
540	my $mname = _dec_qname;	499	my $mname = _dec_name;
541	my $rname = _dec_qname;	500	my $rname = _dec_name;
542	($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)	501	($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)
543	}, # soa	502	}, # soa
544	11 => sub { ((join ".", unpack "C4", $_), unpack "C a*", substr $_, 4) }, # wks	503	11 => sub { ((join ".", unpack "C4", $_), unpack "C a*", substr $_, 4) }, # wks
545	12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr	504	12 => sub { local $ofs = $ofs - length; _dec_name }, # ptr
546	13 => sub { unpack "C/a* C/a*", $_ }, # hinfo	505	13 => sub { unpack "C/a* C/a*", $_ }, # hinfo
547	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
548	16 => sub { unpack "(C/a)", $_ }, # txt	507	16 => sub { unpack "(C/a)", $_ }, # txt
549	28 => sub { AnyEvent::Socket::format_ip ($_) }, # aaaa	508	28 => sub { AnyEvent::Socket::format_ipv6 ($_) }, # aaaa
550	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
551	99 => sub { unpack "(C/a)", $_ }, # spf	517	99 => sub { unpack "(C/a)", $_ }, # spf
552	);	518	);
553		519
554	sub _dec_rr {	520	sub _dec_rr {
555	my $qname = _dec_qname;	521	my $name = _dec_name;
556		522
557	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;
558	local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen;	524	local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen;
559		525
560	[	526	[
561	$qname,	527	$name,
562	$type_str{$rt} \|\| $rt,	528	$type_str{$rt} \|\| $rt,
563	$class_str{$rc} \|\| $rc,	529	$class_str{$rc} \|\| $rc,
564	($dec_rr{$rt} \|\| sub { $_ })->(),	530	($dec_rr{$rt} \|\| sub { $_ })->(),
565	]	531	]
566	}	532	}
…		…
569		535
570	Unpacks a DNS packet into a perl data structure.	536	Unpacks a DNS packet into a perl data structure.
571		537
572	Examples:	538	Examples:
573		539
574	# an unsuccessful reply	540	# an unsuccessful reply
575	{	541	{
576	'qd' => [	542	'qd' => [
577	[ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]	543	[ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]
578	],	544	],
579	'rc' => 'nxdomain',	545	'rc' => 'nxdomain',
580	'ar' => [],	546	'ar' => [],
581	'ns' => [	547	'ns' => [
582	[	548	[
583	'uni-karlsruhe.de',	549	'uni-karlsruhe.de',
584	'soa',	550	'soa',
585	'in',	551	'in',
586	'netserv.rz.uni-karlsruhe.de',	552	'netserv.rz.uni-karlsruhe.de',
587	'hostmaster.rz.uni-karlsruhe.de',	553	'hostmaster.rz.uni-karlsruhe.de',
588	2008052201, 10800, 1800, 2592000, 86400	554	2008052201, 10800, 1800, 2592000, 86400
589	]	555	]
590	],	556	],
591	'tc' => '',	557	'tc' => '',
592	'ra' => 1,	558	'ra' => 1,
593	'qr' => 1,	559	'qr' => 1,
594	'id' => 45915,	560	'id' => 45915,
595	'aa' => '',	561	'aa' => '',
596	'an' => [],	562	'an' => [],
597	'rd' => 1,	563	'rd' => 1,
598	'op' => 'query'	564	'op' => 'query'
599	}	565	}
600		566
601	# a successful reply	567	# a successful reply
602		568
603	{	569	{
604	'qd' => [ [ 'www.google.de', 'a', 'in' ] ],	570	'qd' => [ [ 'www.google.de', 'a', 'in' ] ],
605	'rc' => 0,	571	'rc' => 0,
606	'ar' => [	572	'ar' => [
607	[ 'a.l.google.com', 'a', 'in', '209.85.139.9' ],	573	[ 'a.l.google.com', 'a', 'in', '209.85.139.9' ],
608	[ 'b.l.google.com', 'a', 'in', '64.233.179.9' ],	574	[ 'b.l.google.com', 'a', 'in', '64.233.179.9' ],
609	[ 'c.l.google.com', 'a', 'in', '64.233.161.9' ],	575	[ 'c.l.google.com', 'a', 'in', '64.233.161.9' ],
610	],	576	],
611	'ns' => [	577	'ns' => [
612	[ 'l.google.com', 'ns', 'in', 'a.l.google.com' ],	578	[ 'l.google.com', 'ns', 'in', 'a.l.google.com' ],
613	[ 'l.google.com', 'ns', 'in', 'b.l.google.com' ],	579	[ 'l.google.com', 'ns', 'in', 'b.l.google.com' ],
614	],	580	],
615	'tc' => '',	581	'tc' => '',
616	'ra' => 1,	582	'ra' => 1,
617	'qr' => 1,	583	'qr' => 1,
618	'id' => 64265,	584	'id' => 64265,
619	'aa' => '',	585	'aa' => '',
620	'an' => [	586	'an' => [
621	[ 'www.google.de', 'cname', 'in', 'www.google.com' ],	587	[ 'www.google.de', 'cname', 'in', 'www.google.com' ],
622	[ 'www.google.com', 'cname', 'in', 'www.l.google.com' ],	588	[ 'www.google.com', 'cname', 'in', 'www.l.google.com' ],
623	[ 'www.l.google.com', 'a', 'in', '66.249.93.104' ],	589	[ 'www.l.google.com', 'a', 'in', '66.249.93.104' ],
624	[ 'www.l.google.com', 'a', 'in', '66.249.93.147' ],	590	[ 'www.l.google.com', 'a', 'in', '66.249.93.147' ],
625	],	591	],
626	'rd' => 1,	592	'rd' => 1,
627	'op' => 0	593	'op' => 0
628	}	594	}
629		595
630	=cut	596	=cut
631		597
632	sub dns_unpack($) {	598	sub dns_unpack($) {
633	local $pkt = shift;	599	local $pkt = shift;
…		…
688		654
689	our $RESOLVER;	655	our $RESOLVER;
690		656
691	sub resolver() {	657	sub resolver() {
692	$RESOLVER \|\| do {	658	$RESOLVER \|\| do {
693	$RESOLVER = new AnyEvent::DNS;	659	$RESOLVER = new AnyEvent::DNS untaint => 1;
694	$RESOLVER->os_config;	660	$RESOLVER->os_config;
695	$RESOLVER	661	$RESOLVER
696	}	662	}
697	}	663	}
698		664
…		…
704		670
705	=over 4	671	=over 4
706		672
707	=item server => [...]	673	=item server => [...]
708		674
709	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
710	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).
711		678
712	=item timeout => [...]	679	=item timeout => [...]
713		680
714	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
715	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,
…		…
724	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
725	tries to resolve the name without any suffixes first.	692	tries to resolve the name without any suffixes first.
726		693
727	=item max_outstanding => $integer	694	=item max_outstanding => $integer
728		695
729	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
730	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>
731	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,
732	until some other requests have been resolved.	699	then the additional requests will be queued until some other requests have
		700	been resolved.
733		701
734	=item reuse => $seconds	702	=item reuse => $seconds
735		703
736	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
737	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
738	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.
739		712
740	=back	713	=back
741		714
742	=cut	715	=cut
743		716
744	sub new {	717	sub new {
745	my ($class, %arg) = @_;	718	my ($class, %arg) = @_;
746
747	socket my $fh, AF_INET, &Socket::SOCK_DGRAM, 0
748	or Carp::croak "socket: $!";
749
750	AnyEvent::Util::fh_nonblocking $fh, 1;
751		719
752	my $self = bless {	720	my $self = bless {
753	server => [],	721	server => [],
754	timeout => [2, 5, 5],	722	timeout => [2, 5, 5],
755	search => [],	723	search => [],
756	ndots => 1,	724	ndots => 1,
757	max_outstanding => 10,	725	max_outstanding => 10,
758	reuse => 300, # reuse id's after 5 minutes only, if possible	726	reuse => 300,
759	%arg,	727	%arg,
760	fh => $fh,
761	reuse_q => [],	728	reuse_q => [],
762	}, $class;	729	}, $class;
763		730
764	# search should default to gethostname's domain	731	# search should default to gethostname's domain
765	# but perl lacks a good posix module	732	# but perl lacks a good posix module
766		733
		734	# try to create an ipv4 and an ipv6 socket
		735	# only fail when we cannot create either
		736	my $got_socket;
		737
767	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;
768	$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";
769		766
770	$self->_compile;	767	$self->_compile;
771		768
772	$self	769	$self
773	}	770	}
…		…
795	for (split /\n/, $resolvconf) {	792	for (split /\n/, $resolvconf) {
796	if (/^\s*#/) {	793	if (/^\s*#/) {
797	# comment	794	# comment
798	} elsif (/^\snameserver\s+(\S+)\s$/i) {	795	} elsif (/^\snameserver\s+(\S+)\s$/i) {
799	my $ip = $1;	796	my $ip = $1;
800	if (my $ipn = AnyEvent::Socket::parse_ip ($ip)) {	797	if (my $ipn = AnyEvent::Socket::parse_address ($ip)) {
801	push @{ $self->{server} }, $ipn;	798	push @{ $self->{server} }, $ipn;
802	} else {	799	} else {
803	warn "nameserver $ip invalid and ignored\n";	800	warn "nameserver $ip invalid and ignored\n";
804	}	801	}
805	} elsif (/^\sdomain\s+(\S)\s+$/i) {	802	} elsif (/^\sdomain\s+(\S)\s+$/i) {
…		…
829	$self->_compile;	826	$self->_compile;
830	}	827	}
831		828
832	=item $resolver->os_config	829	=item $resolver->os_config
833		830
834	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
835	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.
836		834
837	=cut	835	=cut
838		836
839	sub os_config {	837	sub os_config {
840	my ($self) = @_;	838	my ($self) = @_;
841		839
842	$self->{server} = [];	840	$self->{server} = [];
843	$self->{search} = [];	841	$self->{search} = [];
844		842
845	if (WIN32 \|\| $^O =~ /cygwin/i) {	843	if (AnyEvent::WIN32 \|\| $^O =~ /cygwin/i) {
846	no strict 'refs';	844	no strict 'refs';
847		845
848	# there are many options to find the current nameservers etc. on windows	846	# there are many options to find the current nameservers etc. on windows
849	# all of them don't work consistently:	847	# all of them don't work consistently:
850	# - the registry thing needs separate code on win32 native vs. cygwin	848	# - the registry thing needs separate code on win32 native vs. cygwin
851	# - the registry layout differs between windows versions	849	# - the registry layout differs between windows versions
852	# - calling windows api functions doesn't work on cygwin	850	# - calling windows api functions doesn't work on cygwin
853	# - ipconfig uses locale-specific messages	851	# - ipconfig uses locale-specific messages
854		852
855	# we use ipconfig parsing because, despite all it's brokenness,	853	# we use ipconfig parsing because, despite all its brokenness,
856	# it seems most stable in practise.	854	# it seems most stable in practise.
857	# for good measure, we append a fallback nameserver to our list.	855	# for good measure, we append a fallback nameserver to our list.
858		856
859	if (open my $fh, "ipconfig /all \|") {	857	if (open my $fh, "ipconfig /all \|") {
860	# parsing strategy: we go through the output and look for	858	# parsing strategy: we go through the output and look for
…		…
869	} elsif (/^\S/ \|\| /^\s[^:]{16,}: /) {	867	} elsif (/^\S/ \|\| /^\s[^:]{16,}: /) {
870	$dns = 0;	868	$dns = 0;
871	}	869	}
872	if ($dns && /^\s(\S+)\s$/) {	870	if ($dns && /^\s(\S+)\s$/) {
873	my $s = $1;	871	my $s = $1;
874	$s =~ s/%\d+(?!\S)//; # get rid of scope id	872	$s =~ s/%\d+(?!\S)//; # get rid of ipv6 scope id
875	if (my $ipn = AnyEvent::Socket::parse_ip ($s)) {	873	if (my $ipn = AnyEvent::Socket::parse_address ($s)) {
876	push @{ $self->{server} }, $ipn;	874	push @{ $self->{server} }, $ipn;
877	} else {	875	} else {
878	push @{ $self->{search} }, $s;	876	push @{ $self->{search} }, $s;
879	}	877	}
880	}	878	}
…		…
893	$self->parse_resolv_conf (<$fh>);	891	$self->parse_resolv_conf (<$fh>);
894	}	892	}
895	}	893	}
896	}	894	}
897		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
898	sub _compile {	924	sub _compile {
899	my $self = shift;	925	my $self = shift;
900		926
901	# we currently throw away all ipv6 nameservers, we do not yet support those
902
903	my %search; $self->{search} = [grep 0 < length, grep !$search{$_}++, @{ $self->{search} }];	927	my %search; $self->{search} = [grep 0 < length, grep !$search{$_}++, @{ $self->{search} }];
904	my %server; $self->{server} = [grep 4 == length, grep !$server{$_}++, @{ $self->{server} }];	928	my %server; $self->{server} = [grep 0 < length, grep !$server{$_}++, @{ $self->{server} }];
905		929
906	unless (@{ $self->{server} }) {	930	unless (@{ $self->{server} }) {
907	# use 127.0.0.1 by default, and one opendns nameserver as fallback	931	# use 127.0.0.1 by default, and one opendns nameserver as fallback
908	$self->{server} = [v127.0.0.1, $DNS_FALLBACK[rand @DNS_FALLBACK]];	932	$self->{server} = [v127.0.0.1, $DNS_FALLBACK[rand @DNS_FALLBACK]];
909	}	933	}
…		…
920	}	944	}
921		945
922	sub _feed {	946	sub _feed {
923	my ($self, $res) = @_;	947	my ($self, $res) = @_;
924		948
		949	($res) = $res =~ /^(.*)$/s
		950	if AnyEvent::TAINT && $self->{untaint};
		951
925	$res = dns_unpack $res	952	$res = dns_unpack $res
926	or return;	953	or return;
927		954
928	my $id = $self->{id}{$res->{id}};	955	my $id = $self->{id}{$res->{id}};
929		956
…		…
932	$NOW = time;	959	$NOW = time;
933	$id->[1]->($res);	960	$id->[1]->($res);
934	}	961	}
935		962
936	sub _recv {	963	sub _recv {
937	my ($self) = @_;	964	my ($self, $pkt, $peer) = @_;
938		965
939	# we ignore errors (often one gets port unreachable, but there is	966	# we ignore errors (often one gets port unreachable, but there is
940	# no good way to take advantage of that.	967	# no good way to take advantage of that.
941	while (my $peer = recv $self->{fh}, my $res, 4096, 0) {	968
942	my ($port, $host) = AnyEvent::Socket::unpack_sockaddr ($peer);	969	my ($port, $host) = AnyEvent::Socket::unpack_sockaddr ($peer);
943		970
944	return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };	971	return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };
945		972
946	$self->_feed ($res);	973	$self->_feed ($pkt);
947	}
948	}	974	}
949		975
950	sub _free_id {	976	sub _free_id {
951	my ($self, $id, $timeout) = @_;	977	my ($self, $id, $timeout) = @_;
952		978
…		…
982		1008
983	$self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {	1009	$self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {
984	$NOW = time;	1010	$NOW = time;
985		1011
986	# timeout, try next	1012	# timeout, try next
987	&$do_retry;	1013	&$do_retry if $do_retry;
988	}), sub {	1014	}), sub {
989	my ($res) = @_;	1015	my ($res) = @_;
990		1016
991	if ($res->{tc}) {	1017	if ($res->{tc}) {
992	# success, but truncated, so use tcp	1018	# success, but truncated, so use tcp
993	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
994	my ($fh) = @_	1022	my ($fh) = @_
995	or return &$do_retry;	1023	or return &$do_retry;
996		1024
		1025	require AnyEvent::Handle;
		1026
997	my $handle = new AnyEvent::Handle	1027	my $handle; $handle = new AnyEvent::Handle
998	fh => $fh,	1028	fh => $fh,
		1029	timeout => $timeout,
999	on_error => sub {	1030	on_error => sub {
		1031	undef $handle;
		1032	return unless $do_retry; # some other request could have invalidated us already
1000	# failure, try next	1033	# failure, try next
1001	&$do_retry;	1034	&$do_retry;
1002	};	1035	};
1003		1036
1004	$handle->push_write (pack "n/a", $req->[0]);	1037	$handle->push_write (pack "n/a", $req->[0]);
1005	$handle->push_read (chunk => 2, sub {	1038	$handle->push_read (chunk => 2, sub {
1006	$handle->unshift_read (chunk => (unpack "n", $_[1]), sub {	1039	$handle->unshift_read (chunk => (unpack "n", $_[1]), sub {
		1040	undef $handle;
1007	$self->_feed ($_[1]);	1041	$self->_feed ($_[1]);
1008	});	1042	});
1009	});	1043	});
1010	shutdown $fh, 1;
1011		1044
1012	}, sub { $timeout });	1045	}, sub { $timeout });
1013		1046
1014	} else {	1047	} else {
1015	# success	1048	# success
1016	$self->_free_id ($req->[2], $retry > 1);	1049	$self->_free_id ($req->[2], $retry > 1);
1017	undef $do_retry; return $req->[1]->($res);	1050	undef $do_retry; return $req->[1]->($res);
1018	}	1051	}
1019	}];	1052	}];
		1053
		1054	my $sa = AnyEvent::Socket::pack_sockaddr (DOMAIN_PORT, $server);
1020		1055
1021	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;
1022	};	1061	};
1023		1062
1024	&$do_retry;	1063	&$do_retry;
1025	}	1064	}
1026		1065
1027	sub _scheduler {	1066	sub _scheduler {
1028	my ($self) = @_;	1067	my ($self) = @_;
		1068
		1069	no strict 'refs';
1029		1070
1030	$NOW = time;	1071	$NOW = time;
1031		1072
1032	# first clear id reuse queue	1073	# first clear id reuse queue
1033	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }	1074	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }
…		…
1042	$self->_scheduler;	1083	$self->_scheduler;
1043	});	1084	});
1044	last;	1085	last;
1045	}	1086	}
1046		1087
1047	my $req = shift @{ $self->{queue} }	1088	if (my $req = shift @{ $self->{queue} }) {
1048	or last;	1089	# found a request in the queue, execute it
1049
1050	while () {	1090	while () {
1051	$req->[2] = int rand 65536;	1091	$req->[2] = int rand 65536;
1052	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;
1053	}	1108	}
1054
1055	++$self->{outstanding};
1056	$self->{id}{$req->[2]} = 1;
1057	substr $req->[0], 0, 2, pack "n", $req->[2];
1058
1059	$self->_exec ($req);
1060	}	1109	}
1061	}	1110	}
1062		1111
1063	=item $resolver->request ($req, $cb->($res))	1112	=item $resolver->request ($req, $cb->($res))
1064		1113
		1114	This is the main low-level workhorse for sending DNS requests.
		1115
1065	Sends a single request (a hash-ref formated as specified for	1116	This function sends a single request (a hash-ref formated as specified
1066	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
1067	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
1068	was received, or no arguments on timeout.	1122	received, or no arguments in case none of the servers answered.
1069		1123
1070	=cut	1124	=cut
1071		1125
1072	sub request($$) {	1126	sub request($$) {
1073	my ($self, $req, $cb) = @_;	1127	my ($self, $req, $cb) = @_;
1074		1128
1075	push @{ $self->{queue} }, [dns_pack $req, $cb];	1129	push @{ $self->{queue} }, [dns_pack $req, $cb];
1076	$self->_scheduler;	1130	$self->_scheduler;
1077	}	1131	}
1078		1132
1079	=item $resolver->resolve ($qname, $qtype, %options, $cb->($rcode, @rr))	1133	=item $resolver->resolve ($qname, $qtype, %options, $cb->(@rr))
1080		1134
1081	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>.
1082	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.
1083		1142
1084	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
1085	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.
1086		1145
1087	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.
1088		1158
1089	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
1090	supporting recursive queries, will not do any recursive queries itself and	1160	supporting recursive queries, will not do any recursive queries itself and
1091	is not secure when used against an untrusted name server.	1161	is not secure when used against an untrusted name server.
1092		1162
…		…
1096		1166
1097	=item search => [$suffix...]	1167	=item search => [$suffix...]
1098		1168
1099	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
1100	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
1101	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
1102	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.
1103		1174
1104	=item accept => [$type...]	1175	=item accept => [$type...]
1105		1176
1106	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
1107	accepted and returned. The default includes the C<$qtype> and nothing	1178	accepted and returned. The default includes the C<$qtype> and nothing
1108	else.	1179	else. If this list includes C<cname>, then CNAME-chains will not be
		1180	followed (because you asked for the CNAME record).
1109		1181
1110	=item class => "class"	1182	=item class => "class"
1111		1183
1112	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
1113	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.
1114		1186
1115	=back	1187	=back
1116		1188
1117	Examples:	1189	Examples:
1118		1190
1119	$res->resolve ("ruth.plan9.de", "a", sub {	1191	# full example, you can paste this into perl:
1120	warn Dumper [@_];	1192	use Data::Dumper;
1121	});	1193	use AnyEvent::DNS;
		1194	AnyEvent::DNS::resolver->resolve (
		1195	"google.com", "*", my $cv = AnyEvent->condvar);
		1196	warn Dumper [$cv->recv];
1122		1197
		1198	# shortened result:
1123	[	1199	# [
		1200	# [ 'google.com', 'soa', 'in', 'ns1.google.com', 'dns-admin.google.com',
		1201	# 2008052701, 7200, 1800, 1209600, 300 ],
1124	[	1202	# [
1125	'ruth.schmorp.de',	1203	# 'google.com', 'txt', 'in',
1126	'a',	1204	# 'v=spf1 include:_netblocks.google.com ~all'
1127	'in',	1205	# ],
1128	'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' ],
1129	]	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' ]
1130	]	1217	# ]
1131		1218
		1219	# resolve any records, but return only a and aaaa records:
1132	$res->resolve ("test1.laendle", "*",	1220	$res->resolve ("test1.laendle", "*",
1133	accept => ["a", "aaaa"],	1221	accept => ["a", "aaaa"],
1134	sub {	1222	sub {
1135	warn Dumper [@_];	1223	warn Dumper [@_];
1136	}	1224	}
1137	);	1225	);
1138		1226
1139	[	1227	# result:
1140	[	1228	# [
1141	'test1.laendle',	1229	# [ 'test1.laendle', 'a', 'in', '10.0.0.255' ],
1142	'a',	1230	# [ 'test1.laendle', 'aaaa', 'in', '3ffe:1900:4545:0002:0240:0000:0000:f7e1' ]
1143	'in',
1144	'10.0.0.255'
1145	],
1146	[
1147	'test1.laendle',
1148	'aaaa',
1149	'in',
1150	'3ffe:1900:4545:0002:0240:0000:0000:f7e1'
1151	]	1231	# ]
1152	]
1153		1232
1154	=cut	1233	=cut
1155		1234
1156	sub resolve($%) {	1235	sub resolve($%) {
1157	my $cb = pop;	1236	my $cb = pop;
…		…
1177	$do_search = sub {	1256	$do_search = sub {
1178	@search	1257	@search
1179	or (undef $do_search), (undef $do_req), return $cb->();	1258	or (undef $do_search), (undef $do_req), return $cb->();
1180		1259
1181	(my $name = lc "$qname." . shift @search) =~ s/\.$//;	1260	(my $name = lc "$qname." . shift @search) =~ s/\.$//;
1182	my $depth = 2;	1261	my $depth = 10;
1183		1262
1184	# advance in cname-chain	1263	# advance in cname-chain
1185	$do_req = sub {	1264	$do_req = sub {
1186	$self->request ({	1265	$self->request ({
1187	rd => 1,	1266	rd => 1,
…		…
1205	if (@rr) {	1284	if (@rr) {
1206	$depth--	1285	$depth--
1207	or return $do_search->(); # cname chain too long	1286	or return $do_search->(); # cname chain too long
1208		1287
1209	$cname = 1;	1288	$cname = 1;
1210	$name = $rr[0][3];	1289	$name = lc $rr[0][3];
1211		1290
1212	} elsif ($cname) {	1291	} elsif ($cname) {
1213	# follow the cname	1292	# follow the cname
1214	return $do_req->();	1293	return $do_req->();
1215		1294
…		…
1225	};	1304	};
1226		1305
1227	$do_search->();	1306	$do_search->();
1228	}	1307	}
1229		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
1230	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
1231		1341
1232	1;	1342	1;
1233		1343
1234	=back	1344	=back
1235		1345
1236	=head1 AUTHOR	1346	=head1 AUTHOR
1237		1347
1238	Marc Lehmann <schmorp@schmorp.de>	1348	Marc Lehmann <schmorp@schmorp.de>
1239	http://home.schmorp.de/	1349	http://home.schmorp.de/
1240		1350
1241	=cut	1351	=cut
1242		1352

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.33 by root, Mon May 26 05:09:53 2008 UTC vs. Revision 1.100 by root, Sun Jul 5 01:38:43 2009 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.33 by root, Mon May 26 05:09:53 2008 UTC vs.
Revision 1.100 by root, Sun Jul 5 01:38:43 2009 UTC