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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.24 by root, Sat May 24 02:50:45 2008 UTC vs.
Revision 1.99 by root, Sat Jul 4 23:58:52 2009 UTC

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

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.24 by root, Sat May 24 02:50:45 2008 UTC vs. Revision 1.99 by root, Sat Jul 4 23:58:52 2009 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.24 by root, Sat May 24 02:50:45 2008 UTC vs.
Revision 1.99 by root, Sat Jul 4 23:58:52 2009 UTC