[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.89 by root, Sun Apr 26 18:12:53 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
		36	use AnyEvent ();
29	use AnyEvent::Handle ();	37	use AnyEvent::Handle ();
		38	use AnyEvent::Util qw(AF_INET6);
30		39
31	=item AnyEvent::DNS::addr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...)	40	our $VERSION = 4.4;
32		41
33	Tries to resolve the given nodename and service name into protocol families	42	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		43
66	=item AnyEvent::DNS::a $domain, $cb->(@addrs)	44	=item AnyEvent::DNS::a $domain, $cb->(@addrs)
67		45
68	Tries to resolve the given domain to IPv4 address(es).	46	Tries to resolve the given domain to IPv4 address(es).
69		47
…		…
87	=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)	65	=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)
88		66
89	Tries to resolve the given service, protocol and domain name into a list	67	Tries to resolve the given service, protocol and domain name into a list
90	of service records.	68	of service records.
91		69
92	Each srv_rr is an array reference with the following contents:	70	Each C<$srv_rr> is an array reference with the following contents:
93	C<[$priority, $weight, $transport, $target]>.	71	C<[$priority, $weight, $transport, $target]>.
94		72
95	They will be sorted with lowest priority, highest weight first (TODO:	73	They will be sorted with lowest priority first, then randomly
96	should use the RFC algorithm to reorder same-priority records for weight).	74	distributed by weight as per RFC 2782.
97		75
98	Example:	76	Example:
99		77
100	AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...	78	AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...
101	# @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )	79	# @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )
102		80
103	=item AnyEvent::DNS::ptr $ipv4_or_6, $cb->(@hostnames)	81	=item AnyEvent::DNS::ptr $domain, $cb->(@hostnames)
		82
		83	Tries to make a PTR lookup on the given domain. See C<reverse_lookup>
		84	and C<reverse_verify> if you want to resolve an IP address to a hostname
		85	instead.
		86
		87	=item AnyEvent::DNS::any $domain, $cb->(@rrs)
		88
		89	Tries to resolve the given domain and passes all resource records found to
		90	the callback.
		91
		92	=item AnyEvent::DNS::reverse_lookup $ipv4_or_6, $cb->(@hostnames)
104		93
105	Tries to reverse-resolve the given IPv4 or IPv6 address (in textual form)	94	Tries to reverse-resolve the given IPv4 or IPv6 address (in textual form)
106	into it's hostname(s).	95	into it's hostname(s). Handles V4MAPPED and V4COMPAT IPv6 addresses
		96	transparently.
		97
		98	=item AnyEvent::DNS::reverse_verify $ipv4_or_6, $cb->(@hostnames)
		99
		100	The same as C<reverse_lookup>, but does forward-lookups to verify that
		101	the resolved hostnames indeed point to the address, which makes spoofing
		102	harder.
		103
		104	If you want to resolve an address into a hostname, this is the preferred
		105	method: The DNS records could still change, but at least this function
		106	verified that the hostname, at one point in the past, pointed at the IP
		107	address you originally resolved.
107		108
108	Example:	109	Example:
109		110
110	AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };	111	AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };
111	# => f.root-servers.net	112	# => f.root-servers.net
112		113
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	114	=cut
		115
		116	sub MAX_PKT() { 4096 } # max packet size we advertise and accept
		117
		118	sub DOMAIN_PORT() { 53 } # if this changes drop me a note
119		119
120	sub resolver;	120	sub resolver;
121		121
122	sub a($$) {	122	sub a($$) {
123	my ($domain, $cb) = @_;	123	my ($domain, $cb) = @_;
…		…
162	sub srv($$$$) {	162	sub srv($$$$) {
163	my ($service, $proto, $domain, $cb) = @_;	163	my ($service, $proto, $domain, $cb) = @_;
164		164
165	# todo, ask for any and check glue records	165	# todo, ask for any and check glue records
166	resolver->resolve ("_$service._$proto.$domain" => "srv", sub {	166	resolver->resolve ("_$service._$proto.$domain" => "srv", sub {
167	$cb->(map [@$_[3,4,5,6]], sort { $a->[3] <=> $b->[3] \|\| $b->[4] <=> $a->[4] } @_);	167	my @res;
		168
		169	# classify by priority
		170	my %pri;
		171	push @{ $pri{$_->[3]} }, [ @$_[3,4,5,6] ]
		172	for @_;
		173
		174	# order by priority
		175	for my $pri (sort { $a <=> $b } keys %pri) {
		176	# order by weight
		177	my @rr = sort { $a->[1] <=> $b->[1] } @{ delete $pri{$pri} };
		178
		179	my $sum; $sum += $_->[1] for @rr;
		180
		181	while (@rr) {
		182	my $w = int rand $sum + 1;
		183	for (0 .. $#rr) {
		184	if (($w -= $rr[$_][1]) <= 0) {
		185	$sum -= $rr[$_][1];
		186	push @res, splice @rr, $_, 1, ();
		187	last;
		188	}
		189	}
		190	}
		191	}
		192
		193	$cb->(@res);
168	});	194	});
169	}	195	}
170		196
171	sub ptr($$) {	197	sub ptr($$) {
		198	my ($domain, $cb) = @_;
		199
		200	resolver->resolve ($domain => "ptr", sub {
		201	$cb->(map $_->[3], @_);
		202	});
		203	}
		204
		205	sub any($$) {
		206	my ($domain, $cb) = @_;
		207
		208	resolver->resolve ($domain => "*", $cb);
		209	}
		210
		211	# convert textual ip address into reverse lookup form
		212	sub _munge_ptr($) {
		213	my $ipn = $_[0]
		214	or return;
		215
		216	my $ptr;
		217
		218	my $af = AnyEvent::Socket::address_family ($ipn);
		219
		220	if ($af == AF_INET6) {
		221	$ipn = substr $ipn, 0, 16; # anticipate future expansion
		222
		223	# handle v4mapped and v4compat
		224	if ($ipn =~ s/^\x00{10}(?:\xff\xff\|\x00\x00)//) {
		225	$af = AF_INET;
		226	} else {
		227	$ptr = join ".", (reverse split //, unpack "H32", $ipn), "ip6.arpa.";
		228	}
		229	}
		230
		231	if ($af == AF_INET) {
		232	$ptr = join ".", (reverse unpack "C4", $ipn), "in-addr.arpa.";
		233	}
		234
		235	$ptr
		236	}
		237
		238	sub reverse_lookup($$) {
172	my ($ip, $cb) = @_;	239	my ($ip, $cb) = @_;
173		240
174	$ip = AnyEvent::Socket::parse_ip ($ip)	241	$ip = _munge_ptr AnyEvent::Socket::parse_address ($ip)
175	or return $cb->();	242	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		243
183	resolver->resolve ($ip => "ptr", sub {	244	resolver->resolve ($ip => "ptr", sub {
184	$cb->(map $_->[3], @_);	245	$cb->(map $_->[3], @_);
185	});	246	});
186	}	247	}
187		248
188	sub any($$) {	249	sub reverse_verify($$) {
189	my ($domain, $cb) = @_;	250	my ($ip, $cb) = @_;
190		251
191	resolver->resolve ($domain => "*", $cb);	252	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->();	253	or return $cb->();
202		254
203	$family \|\|= 4;	255	my $af = AnyEvent::Socket::address_family ($ipn);
204	}
205		256
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;	257	my @res;
234	my $cv = AnyEvent->condvar (cb => sub {	258	my $cnt;
		259
		260	my $ptr = _munge_ptr $ipn
		261	or return $cb->();
		262
		263	$ip = AnyEvent::Socket::format_address ($ipn); # normalise into the same form
		264
		265	ptr $ptr, sub {
		266	for my $name (@_) {
		267	++$cnt;
235	$cb->(	268
236	map $_->[1],	269	# () around AF_INET to work around bug in 5.8
		270	resolver->resolve ("$name." => ($af == (AF_INET) ? "a" : "aaaa"), sub {
237	sort {	271	for (@_) {
238	$AnyEvent::PROTOCOL{$a->[1][0]} <=> $AnyEvent::PROTOCOL{$b->[1][0]}	272	push @res, $name
239	or $a->[0] <=> $b->[0]	273	if $_->[3] eq $ip;
240	}	274	}
241	@res	275	$cb->(@res) unless --$cnt;
242	)	276	});
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	}	277	}
283	$cv->end;	278
		279	$cb->() unless $cnt;
284	};	280	};
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	}	281	}
313		282
314	#############################################################################	283	#################################################################################
315		284
316	=back	285	=back
317		286
318	=head2 LOW-LEVEL DNS EN-/DECODING FUNCTIONS	287	=head2 LOW-LEVEL DNS EN-/DECODING FUNCTIONS
319		288
…		…
321		290
322	=item $AnyEvent::DNS::EDNS0	291	=item $AnyEvent::DNS::EDNS0
323		292
324	This variable decides whether dns_pack automatically enables EDNS0	293	This variable decides whether dns_pack automatically enables EDNS0
325	support. By default, this is disabled (C<0>), unless overridden by	294	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	295	C<$ENV{PERL_ANYEVENT_EDNS0}>, but when set to C<1>, AnyEvent::DNS will use
327	EDNS0 in all requests.	296	EDNS0 in all requests.
328		297
329	=cut	298	=cut
330		299
331	our $EDNS0 = $ENV{PERL_ANYEVENT_EDNS0} * 1; # set to 1 to enable (partial) edns0	300	our $EDNS0 = $ENV{PERL_ANYEVENT_EDNS0} * 1; # set to 1 to enable (partial) edns0
…		…
382	minfo => 14,	351	minfo => 14,
383	mx => 15,	352	mx => 15,
384	txt => 16,	353	txt => 16,
385	aaaa => 28,	354	aaaa => 28,
386	srv => 33,	355	srv => 33,
		356	naptr => 35, # rfc2915
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	},
541	99 => sub { unpack "(C/a)*", $_ }, # spf	516	99 => sub { unpack "(C/a)", $_ }, # spf
542	);	517	);
543		518
544	sub _dec_rr {	519	sub _dec_rr {
545	my $qname = _dec_qname;	520	my $name = _dec_name;
546		521
547	my ($rt, $rc, $ttl, $rdlen) = unpack "nn N n", substr $pkt, $ofs; $ofs += 10;	522	my ($rt, $rc, $ttl, $rdlen) = unpack "nn N n", substr $pkt, $ofs; $ofs += 10;
548	local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen;	523	local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen;
549		524
550	[	525	[
551	$qname,	526	$name,
552	$type_str{$rt} \|\| $rt,	527	$type_str{$rt} \|\| $rt,
553	$class_str{$rc} \|\| $rc,	528	$class_str{$rc} \|\| $rc,
554	($dec_rr{$rt} \|\| sub { $_ })->(),	529	($dec_rr{$rt} \|\| sub { $_ })->(),
555	]	530	]
556	}	531	}
…		…
559		534
560	Unpacks a DNS packet into a perl data structure.	535	Unpacks a DNS packet into a perl data structure.
561		536
562	Examples:	537	Examples:
563		538
564	# an unsuccessful reply	539	# an unsuccessful reply
565	{	540	{
566	'qd' => [	541	'qd' => [
567	[ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]	542	[ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]
568	],	543	],
569	'rc' => 'nxdomain',	544	'rc' => 'nxdomain',
570	'ar' => [],	545	'ar' => [],
571	'ns' => [	546	'ns' => [
572	[	547	[
573	'uni-karlsruhe.de',	548	'uni-karlsruhe.de',
574	'soa',	549	'soa',
575	'in',	550	'in',
576	'netserv.rz.uni-karlsruhe.de',	551	'netserv.rz.uni-karlsruhe.de',
577	'hostmaster.rz.uni-karlsruhe.de',	552	'hostmaster.rz.uni-karlsruhe.de',
578	2008052201, 10800, 1800, 2592000, 86400	553	2008052201, 10800, 1800, 2592000, 86400
579	]	554	]
580	],	555	],
581	'tc' => '',	556	'tc' => '',
582	'ra' => 1,	557	'ra' => 1,
583	'qr' => 1,	558	'qr' => 1,
584	'id' => 45915,	559	'id' => 45915,
585	'aa' => '',	560	'aa' => '',
586	'an' => [],	561	'an' => [],
587	'rd' => 1,	562	'rd' => 1,
588	'op' => 'query'	563	'op' => 'query'
589	}	564	}
590		565
591	# a successful reply	566	# a successful reply
592		567
593	{	568	{
594	'qd' => [ [ 'www.google.de', 'a', 'in' ] ],	569	'qd' => [ [ 'www.google.de', 'a', 'in' ] ],
595	'rc' => 0,	570	'rc' => 0,
596	'ar' => [	571	'ar' => [
597	[ 'a.l.google.com', 'a', 'in', '209.85.139.9' ],	572	[ 'a.l.google.com', 'a', 'in', '209.85.139.9' ],
598	[ 'b.l.google.com', 'a', 'in', '64.233.179.9' ],	573	[ 'b.l.google.com', 'a', 'in', '64.233.179.9' ],
599	[ 'c.l.google.com', 'a', 'in', '64.233.161.9' ],	574	[ 'c.l.google.com', 'a', 'in', '64.233.161.9' ],
600	],	575	],
601	'ns' => [	576	'ns' => [
602	[ 'l.google.com', 'ns', 'in', 'a.l.google.com' ],	577	[ 'l.google.com', 'ns', 'in', 'a.l.google.com' ],
603	[ 'l.google.com', 'ns', 'in', 'b.l.google.com' ],	578	[ 'l.google.com', 'ns', 'in', 'b.l.google.com' ],
604	],	579	],
605	'tc' => '',	580	'tc' => '',
606	'ra' => 1,	581	'ra' => 1,
607	'qr' => 1,	582	'qr' => 1,
608	'id' => 64265,	583	'id' => 64265,
609	'aa' => '',	584	'aa' => '',
610	'an' => [	585	'an' => [
611	[ 'www.google.de', 'cname', 'in', 'www.google.com' ],	586	[ 'www.google.de', 'cname', 'in', 'www.google.com' ],
612	[ 'www.google.com', 'cname', 'in', 'www.l.google.com' ],	587	[ 'www.google.com', 'cname', 'in', 'www.l.google.com' ],
613	[ 'www.l.google.com', 'a', 'in', '66.249.93.104' ],	588	[ 'www.l.google.com', 'a', 'in', '66.249.93.104' ],
614	[ 'www.l.google.com', 'a', 'in', '66.249.93.147' ],	589	[ 'www.l.google.com', 'a', 'in', '66.249.93.147' ],
615	],	590	],
616	'rd' => 1,	591	'rd' => 1,
617	'op' => 0	592	'op' => 0
618	}	593	}
619		594
620	=cut	595	=cut
621		596
622	sub dns_unpack($) {	597	sub dns_unpack($) {
623	local $pkt = shift;	598	local $pkt = shift;
…		…
694		669
695	=over 4	670	=over 4
696		671
697	=item server => [...]	672	=item server => [...]
698		673
699	A list of server addresses (default: C<v127.0.0.1>) in network format (4	674	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).	675	(i.e. as returned by C<AnyEvent::Socket::parse_address> - both IPv4 and
		676	IPv6 are supported).
701		677
702	=item timeout => [...]	678	=item timeout => [...]
703		679
704	A list of timeouts to use (also determines the number of retries). To make	680	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,	681	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	690	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.	691	tries to resolve the name without any suffixes first.
716		692
717	=item max_outstanding => $integer	693	=item max_outstanding => $integer
718		694
719	Most name servers do not handle many parallel requests very well. This option	695	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	696	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	697	(default: C<10>), that means if you request more than this many requests,
722	until some other requests have been resolved.	698	then the additional requests will be queued until some other requests have
		699	been resolved.
723		700
724	=item reuse => $seconds	701	=item reuse => $seconds
725		702
726	The number of seconds (default: C<300>) that a query id cannot be re-used	703	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	704	after a timeout. If there was no time-out then query ids can be reused
728	immediately.	705	immediately.
729		706
730	=back	707	=back
731		708
732	=cut	709	=cut
733		710
734	sub new {	711	sub new {
735	my ($class, %arg) = @_;	712	my ($class, %arg) = @_;
736		713
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 {	714	my $self = bless {
743	server => [v127.0.0.1],	715	server => [],
744	timeout => [2, 5, 5],	716	timeout => [2, 5, 5],
745	search => [],	717	search => [],
746	ndots => 1,	718	ndots => 1,
747	max_outstanding => 10,	719	max_outstanding => 10,
748	reuse => 300, # reuse id's after 5 minutes only, if possible	720	reuse => 300,
749	%arg,	721	%arg,
750	fh => $fh,
751	reuse_q => [],	722	reuse_q => [],
752	}, $class;	723	}, $class;
753		724
754	# search should default to gethostname's domain	725	# search should default to gethostname's domain
755	# but perl lacks a good posix module	726	# but perl lacks a good posix module
756		727
		728	# try to create an ipv4 and an ipv6 socket
		729	# only fail when we cannot create either
		730	my $got_socket;
		731
757	Scalar::Util::weaken (my $wself = $self);	732	Scalar::Util::weaken (my $wself = $self);
		733
		734	if (socket my $fh4, AF_INET , &Socket::SOCK_DGRAM, 0) {
		735	++$got_socket;
		736
		737	AnyEvent::Util::fh_nonblocking $fh4, 1;
		738	$self->{fh4} = $fh4;
758	$self->{rw} = AnyEvent->io (fh => $fh, poll => "r", cb => sub { $wself->_recv });	739	$self->{rw4} = AnyEvent->io (fh => $fh4, poll => "r", cb => sub {
		740	if (my $peer = recv $fh4, my $pkt, MAX_PKT, 0) {
		741	$wself->_recv ($pkt, $peer);
		742	}
		743	});
		744	}
		745
		746	if (AF_INET6 && socket my $fh6, AF_INET6, &Socket::SOCK_DGRAM, 0) {
		747	++$got_socket;
		748
		749	$self->{fh6} = $fh6;
		750	AnyEvent::Util::fh_nonblocking $fh6, 1;
		751	$self->{rw6} = AnyEvent->io (fh => $fh6, poll => "r", cb => sub {
		752	if (my $peer = recv $fh6, my $pkt, MAX_PKT, 0) {
		753	$wself->_recv ($pkt, $peer);
		754	}
		755	});
		756	}
		757
		758	$got_socket
		759	or Carp::croak "unable to create either an IPv4 or an IPv6 socket";
759		760
760	$self->_compile;	761	$self->_compile;
761		762
762	$self	763	$self
763	}	764	}
…		…
785	for (split /\n/, $resolvconf) {	786	for (split /\n/, $resolvconf) {
786	if (/^\s*#/) {	787	if (/^\s*#/) {
787	# comment	788	# comment
788	} elsif (/^\snameserver\s+(\S+)\s$/i) {	789	} elsif (/^\snameserver\s+(\S+)\s$/i) {
789	my $ip = $1;	790	my $ip = $1;
790	if (AnyEvent::Util::dotted_quad $ip) {	791	if (my $ipn = AnyEvent::Socket::parse_address ($ip)) {
791	push @{ $self->{server} }, AnyEvent::Util::socket_inet_aton $ip;	792	push @{ $self->{server} }, $ipn;
792	} else {	793	} else {
793	warn "nameserver $ip invalid and ignored\n";	794	warn "nameserver $ip invalid and ignored\n";
794	}	795	}
795	} elsif (/^\sdomain\s+(\S)\s+$/i) {	796	} elsif (/^\sdomain\s+(\S)\s+$/i) {
796	$self->{search} = [$1];	797	$self->{search} = [$1];
…		…
827	=cut	828	=cut
828		829
829	sub os_config {	830	sub os_config {
830	my ($self) = @_;	831	my ($self) = @_;
831		832
832	if ($^O =~ /mswin32\|cygwin/i) {	833	$self->{server} = [];
833	# yeah, it suxx... lets hope DNS is DNS in all locales	834	$self->{search} = [];
		835
		836	if (AnyEvent::WIN32 \|\| $^O =~ /cygwin/i) {
		837	no strict 'refs';
		838
		839	# there are many options to find the current nameservers etc. on windows
		840	# all of them don't work consistently:
		841	# - the registry thing needs separate code on win32 native vs. cygwin
		842	# - the registry layout differs between windows versions
		843	# - calling windows api functions doesn't work on cygwin
		844	# - ipconfig uses locale-specific messages
		845
		846	# we use ipconfig parsing because, despite all its brokenness,
		847	# it seems most stable in practise.
		848	# for good measure, we append a fallback nameserver to our list.
834		849
835	if (open my $fh, "ipconfig /all \|") {	850	if (open my $fh, "ipconfig /all \|") {
836	delete $self->{server};	851	# parsing strategy: we go through the output and look for
837	delete $self->{search};	852	# :-lines with DNS in them. everything in those is regarded as
		853	# either a nameserver (if it parses as an ip address), or a suffix
		854	# (all else).
838		855
		856	my $dns;
839	while (<$fh>) {	857	while (<$fh>) {
840	# first DNS.* is suffix list	858	if (s/^\s.\bdns\b.://i) {
841	if (/^\s*DNS/) {	859	$dns = 1;
842	while (/\s+([[:alnum:].\-]+)\s*$/) {	860	} elsif (/^\S/ \|\| /^\s[^:]{16,}: /) {
		861	$dns = 0;
		862	}
		863	if ($dns && /^\s(\S+)\s$/) {
		864	my $s = $1;
		865	$s =~ s/%\d+(?!\S)//; # get rid of ipv6 scope id
		866	if (my $ipn = AnyEvent::Socket::parse_address ($s)) {
		867	push @{ $self->{server} }, $ipn;
		868	} else {
843	push @{ $self->{search} }, $1;	869	push @{ $self->{search} }, $s;
844	$_ = <$fh>;
845	}	870	}
846	last;
847	}	871	}
848	}	872	}
849		873
850	while (<$fh>) {	874	# always add one fallback server
851	# second DNS.* is server address list	875	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		876
863	$self->_compile;	877	$self->_compile;
864	}	878	}
865	} else {	879	} else {
866	# try resolv.conf everywhere	880	# try resolv.conf everywhere
…		…
870	$self->parse_resolv_conf (<$fh>);	884	$self->parse_resolv_conf (<$fh>);
871	}	885	}
872	}	886	}
873	}	887	}
874		888
		889	=item $resolver->timeout ($timeout, ...)
		890
		891	Sets the timeout values. See the C<timeout> constructor argument (and note
		892	that this method uses the values itself, not an array-reference).
		893
		894	=cut
		895
		896	sub timeout {
		897	my ($self, @timeout) = @_;
		898
		899	$self->{timeout} = \@timeout;
		900	$self->_compile;
		901	}
		902
		903	=item $resolver->max_outstanding ($nrequests)
		904
		905	Sets the maximum number of outstanding requests to C<$nrequests>. See the
		906	C<max_outstanding> constructor argument.
		907
		908	=cut
		909
		910	sub max_outstanding {
		911	my ($self, $max) = @_;
		912
		913	$self->{max_outstanding} = $max;
		914	$self->_scheduler;
		915	}
		916
875	sub _compile {	917	sub _compile {
876	my $self = shift;	918	my $self = shift;
		919
		920	my %search; $self->{search} = [grep 0 < length, grep !$search{$_}++, @{ $self->{search} }];
		921	my %server; $self->{server} = [grep 0 < length, grep !$server{$_}++, @{ $self->{server} }];
		922
		923	unless (@{ $self->{server} }) {
		924	# use 127.0.0.1 by default, and one opendns nameserver as fallback
		925	$self->{server} = [v127.0.0.1, $DNS_FALLBACK[rand @DNS_FALLBACK]];
		926	}
877		927
878	my @retry;	928	my @retry;
879		929
880	for my $timeout (@{ $self->{timeout} }) {	930	for my $timeout (@{ $self->{timeout} }) {
881	for my $server (@{ $self->{server} }) {	931	for my $server (@{ $self->{server} }) {
…		…
899	$NOW = time;	949	$NOW = time;
900	$id->[1]->($res);	950	$id->[1]->($res);
901	}	951	}
902		952
903	sub _recv {	953	sub _recv {
904	my ($self) = @_;	954	my ($self, $pkt, $peer) = @_;
905		955
906	while (my $peer = recv $self->{fh}, my $res, 4096, 0) {	956	# we ignore errors (often one gets port unreachable, but there is
		957	# no good way to take advantage of that.
		958
907	my ($port, $host) = AnyEvent::Socket::unpack_sockaddr ($peer);	959	my ($port, $host) = AnyEvent::Socket::unpack_sockaddr ($peer);
908		960
909	return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };	961	return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };
910		962
911	$self->_feed ($res);	963	$self->_feed ($pkt);
912	}
913	}	964	}
914		965
915	sub _free_id {	966	sub _free_id {
916	my ($self, $id, $timeout) = @_;	967	my ($self, $id, $timeout) = @_;
917		968
…		…
947		998
948	$self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {	999	$self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {
949	$NOW = time;	1000	$NOW = time;
950		1001
951	# timeout, try next	1002	# timeout, try next
952	&$do_retry;	1003	&$do_retry if $do_retry;
953	}), sub {	1004	}), sub {
954	my ($res) = @_;	1005	my ($res) = @_;
955		1006
956	if ($res->{tc}) {	1007	if ($res->{tc}) {
957	# success, but truncated, so use tcp	1008	# success, but truncated, so use tcp
958	AnyEvent::Socket::tcp_connect ((Socket::inet_ntoa $server), 53, sub {	1009	AnyEvent::Socket::tcp_connect (AnyEvent::Socket::format_address ($server), DOMAIN_PORT, sub {
		1010	return unless $do_retry; # some other request could have invalidated us already
		1011
959	my ($fh) = @_	1012	my ($fh) = @_
960	or return &$do_retry;	1013	or return &$do_retry;
961		1014
962	my $handle = new AnyEvent::Handle	1015	my $handle; $handle = new AnyEvent::Handle
963	fh => $fh,	1016	fh => $fh,
		1017	timeout => $timeout,
964	on_error => sub {	1018	on_error => sub {
		1019	undef $handle;
		1020	return unless $do_retry; # some other request could have invalidated us already
965	# failure, try next	1021	# failure, try next
966	&$do_retry;	1022	&$do_retry;
967	};	1023	};
968		1024
969	$handle->push_write (pack "n/a", $req->[0]);	1025	$handle->push_write (pack "n/a", $req->[0]);
970	$handle->push_read_chunk (2, sub {	1026	$handle->push_read (chunk => 2, sub {
971	$handle->unshift_read_chunk ((unpack "n", $_[1]), sub {	1027	$handle->unshift_read (chunk => (unpack "n", $_[1]), sub {
		1028	undef $handle;
972	$self->_feed ($_[1]);	1029	$self->_feed ($_[1]);
973	});	1030	});
974	});	1031	});
975	shutdown $fh, 1;
976		1032
977	}, sub { $timeout });	1033	}, sub { $timeout });
978		1034
979	} else {	1035	} else {
980	# success	1036	# success
981	$self->_free_id ($req->[2], $retry > 1);	1037	$self->_free_id ($req->[2], $retry > 1);
982	undef $do_retry; return $req->[1]->($res);	1038	undef $do_retry; return $req->[1]->($res);
983	}	1039	}
984	}];	1040	}];
		1041
		1042	my $sa = AnyEvent::Socket::pack_sockaddr (DOMAIN_PORT, $server);
985		1043
986	send $self->{fh}, $req->[0], 0, AnyEvent::Socket::pack_sockaddr (53, $server);	1044	my $fh = AF_INET == Socket::sockaddr_family ($sa)
		1045	? $self->{fh4} : $self->{fh6}
		1046	or return &$do_retry;
		1047
		1048	send $fh, $req->[0], 0, $sa;
987	};	1049	};
988		1050
989	&$do_retry;	1051	&$do_retry;
990	}	1052	}
991		1053
992	sub _scheduler {	1054	sub _scheduler {
993	my ($self) = @_;	1055	my ($self) = @_;
		1056
		1057	no strict 'refs';
994		1058
995	$NOW = time;	1059	$NOW = time;
996		1060
997	# first clear id reuse queue	1061	# first clear id reuse queue
998	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }	1062	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }
…		…
1007	$self->_scheduler;	1071	$self->_scheduler;
1008	});	1072	});
1009	last;	1073	last;
1010	}	1074	}
1011		1075
1012	my $req = shift @{ $self->{queue} }	1076	if (my $req = shift @{ $self->{queue} }) {
1013	or last;	1077	# found a request in the queue, execute it
1014
1015	while () {	1078	while () {
1016	$req->[2] = int rand 65536;	1079	$req->[2] = int rand 65536;
1017	last unless exists $self->{id}{$req->[2]};	1080	last unless exists $self->{id}{$req->[2]};
		1081	}
		1082
		1083	++$self->{outstanding};
		1084	$self->{id}{$req->[2]} = 1;
		1085	substr $req->[0], 0, 2, pack "n", $req->[2];
		1086
		1087	$self->_exec ($req);
		1088
		1089	} elsif (my $cb = shift @{ $self->{wait} }) {
		1090	# found a wait_for_slot callback, call that one first
		1091	$cb->($self);
		1092
		1093	} else {
		1094	# nothing to do, just exit
		1095	last;
1018	}	1096	}
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	}	1097	}
1026	}	1098	}
1027		1099
1028	=item $resolver->request ($req, $cb->($res))	1100	=item $resolver->request ($req, $cb->($res))
1029		1101
		1102	This is the main low-level workhorse for sending DNS requests.
		1103
1030	Sends a single request (a hash-ref formated as specified for	1104	This function sends a single request (a hash-ref formated as specified
1031	C<dns_pack>) to the configured nameservers including	1105	for C<dns_pack>) to the configured nameservers in turn until it gets a
		1106	response. It handles timeouts, retries and automatically falls back to
		1107	virtual circuit mode (TCP) when it receives a truncated reply.
		1108
1032	retries. Calls the callback with the decoded response packet if a reply	1109	Calls the callback with the decoded response packet if a reply was
1033	was received, or no arguments on timeout.	1110	received, or no arguments in case none of the servers answered.
1034		1111
1035	=cut	1112	=cut
1036		1113
1037	sub request($$) {	1114	sub request($$) {
1038	my ($self, $req, $cb) = @_;	1115	my ($self, $req, $cb) = @_;
1039		1116
1040	push @{ $self->{queue} }, [dns_pack $req, $cb];	1117	push @{ $self->{queue} }, [dns_pack $req, $cb];
1041	$self->_scheduler;	1118	$self->_scheduler;
1042	}	1119	}
1043		1120
1044	=item $resolver->resolve ($qname, $qtype, %options, $cb->($rcode, @rr))	1121	=item $resolver->resolve ($qname, $qtype, %options, $cb->(@rr))
1045		1122
1046	Queries the DNS for the given domain name C<$qname> of type C<$qtype> (a	1123	Queries the DNS for the given domain name C<$qname> of type C<$qtype>.
1047	qtype of "*" is supported and means "any").	1124
		1125	A C<$qtype> is either a numerical query type (e.g. C<1> for A records) or
		1126	a lowercase name (you have to look at the source to see which aliases are
		1127	supported, but all types from RFC 1035, C<aaaa>, C<srv>, C<spf> and a few
		1128	more are known to this module). A C<$qtype> of "*" is supported and means
		1129	"any" record type.
1048		1130
1049	The callback will be invoked with a list of matching result records or	1131	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.	1132	none on any error or if the name could not be found.
1051		1133
1052	CNAME chains (although illegal) are followed up to a length of 8.	1134	CNAME chains (although illegal) are followed up to a length of 10.
		1135
		1136	The callback will be invoked with arraryefs of the form C<[$name, $type,
		1137	$class, @data>], where C<$name> is the domain name, C<$type> a type string
		1138	or number, C<$class> a class name and @data is resource-record-dependent
		1139	data. For C<a> records, this will be the textual IPv4 addresses, for C<ns>
		1140	or C<cname> records this will be a domain name, for C<txt> records these
		1141	are all the strings and so on.
		1142
		1143	All types mentioned in RFC 1035, C<aaaa>, C<srv>, C<naptr> and C<spf> are
		1144	decoded. All resource records not known to this module will have
		1145	the raw C<rdata> field as fourth entry.
1053		1146
1054	Note that this resolver is just a stub resolver: it requires a name server	1147	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	1148	supporting recursive queries, will not do any recursive queries itself and
1056	is not secure when used against an untrusted name server.	1149	is not secure when used against an untrusted name server.
1057		1150
…		…
1061		1154
1062	=item search => [$suffix...]	1155	=item search => [$suffix...]
1063		1156
1064	Use the given search list (which might be empty), by appending each one	1157	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	1158	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,	1159	C<ndots> and C<search> values define its value (depending on C<ndots>, the
1067	then the searchlist will be ignored.	1160	empty suffix will be prepended or appended to that C<search> value). If
		1161	the C<$qname> ends in a dot, then the searchlist will be ignored.
1068		1162
1069	=item accept => [$type...]	1163	=item accept => [$type...]
1070		1164
1071	Lists the acceptable result types: only result types in this set will be	1165	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	1166	accepted and returned. The default includes the C<$qtype> and nothing
1073	else.	1167	else. If this list includes C<cname>, then CNAME-chains will not be
		1168	followed (because you asked for the CNAME record).
1074		1169
1075	=item class => "class"	1170	=item class => "class"
1076		1171
1077	Specify the query class ("in" for internet, "ch" for chaosnet and "hs" for	1172	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.	1173	hesiod are the only ones making sense). The default is "in", of course.
1079		1174
1080	=back	1175	=back
1081		1176
1082	Examples:	1177	Examples:
1083		1178
1084	$res->resolve ("ruth.plan9.de", "a", sub {	1179	# full example, you can paste this into perl:
1085	warn Dumper [@_];	1180	use Data::Dumper;
1086	});	1181	use AnyEvent::DNS;
		1182	AnyEvent::DNS::resolver->resolve (
		1183	"google.com", "*", my $cv = AnyEvent->condvar);
		1184	warn Dumper [$cv->recv];
1087		1185
		1186	# shortened result:
1088	[	1187	# [
		1188	# [ 'google.com', 'soa', 'in', 'ns1.google.com', 'dns-admin.google.com',
		1189	# 2008052701, 7200, 1800, 1209600, 300 ],
1089	[	1190	# [
1090	'ruth.schmorp.de',	1191	# 'google.com', 'txt', 'in',
1091	'a',	1192	# 'v=spf1 include:_netblocks.google.com ~all'
1092	'in',	1193	# ],
1093	'129.13.162.95'	1194	# [ 'google.com', 'a', 'in', '64.233.187.99' ],
		1195	# [ 'google.com', 'mx', 'in', 10, 'smtp2.google.com' ],
		1196	# [ 'google.com', 'ns', 'in', 'ns2.google.com' ],
1094	]	1197	# ]
		1198
		1199	# resolve a records:
		1200	$res->resolve ("ruth.plan9.de", "a", sub { warn Dumper [@_] });
		1201
		1202	# result:
		1203	# [
		1204	# [ 'ruth.schmorp.de', 'a', 'in', '129.13.162.95' ]
1095	]	1205	# ]
1096		1206
		1207	# resolve any records, but return only a and aaaa records:
1097	$res->resolve ("test1.laendle", "*",	1208	$res->resolve ("test1.laendle", "*",
1098	accept => ["a", "aaaa"],	1209	accept => ["a", "aaaa"],
1099	sub {	1210	sub {
1100	warn Dumper [@_];	1211	warn Dumper [@_];
1101	}	1212	}
1102	);	1213	);
1103		1214
1104	[	1215	# result:
1105	[	1216	# [
1106	'test1.laendle',	1217	# [ 'test1.laendle', 'a', 'in', '10.0.0.255' ],
1107	'a',	1218	# [ '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	]	1219	# ]
1117	]
1118		1220
1119	=cut	1221	=cut
1120		1222
1121	sub resolve($%) {	1223	sub resolve($%) {
1122	my $cb = pop;	1224	my $cb = pop;
…		…
1142	$do_search = sub {	1244	$do_search = sub {
1143	@search	1245	@search
1144	or (undef $do_search), (undef $do_req), return $cb->();	1246	or (undef $do_search), (undef $do_req), return $cb->();
1145		1247
1146	(my $name = lc "$qname." . shift @search) =~ s/\.$//;	1248	(my $name = lc "$qname." . shift @search) =~ s/\.$//;
1147	my $depth = 2;	1249	my $depth = 10;
1148		1250
1149	# advance in cname-chain	1251	# advance in cname-chain
1150	$do_req = sub {	1252	$do_req = sub {
1151	$self->request ({	1253	$self->request ({
1152	rd => 1,	1254	rd => 1,
…		…
1190	};	1292	};
1191		1293
1192	$do_search->();	1294	$do_search->();
1193	}	1295	}
1194		1296
		1297	=item $resolver->wait_for_slot ($cb->($resolver))
		1298
		1299	Wait until a free request slot is available and call the callback with the
		1300	resolver object.
		1301
		1302	A request slot is used each time a request is actually sent to the
		1303	nameservers: There are never more than C<max_outstanding> of them.
		1304
		1305	Although you can submit more requests (they will simply be queued until
		1306	a request slot becomes available), sometimes, usually for rate-limiting
		1307	purposes, it is useful to instead wait for a slot before generating the
		1308	request (or simply to know when the request load is low enough so one can
		1309	submit requests again).
		1310
		1311	This is what this method does: The callback will be called when submitting
		1312	a DNS request will not result in that request being queued. The callback
		1313	may or may not generate any requests in response.
		1314
		1315	Note that the callback will only be invoked when the request queue is
		1316	empty, so this does not play well if somebody else keeps the request queue
		1317	full at all times.
		1318
		1319	=cut
		1320
		1321	sub wait_for_slot {
		1322	my ($self, $cb) = @_;
		1323
		1324	push @{ $self->{wait} }, $cb;
		1325	$self->_scheduler;
		1326	}
		1327
1195	use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end	1328	use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end
1196		1329
1197	1;	1330	1;
1198		1331
1199	=back	1332	=back
1200		1333
1201	=head1 AUTHOR	1334	=head1 AUTHOR
1202		1335
1203	Marc Lehmann <schmorp@schmorp.de>	1336	Marc Lehmann <schmorp@schmorp.de>
1204	http://home.schmorp.de/	1337	http://home.schmorp.de/
1205		1338
1206	=cut	1339	=cut
1207		1340

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.89 by root, Sun Apr 26 18:12:53 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.89 by root, Sun Apr 26 18:12:53 2009 UTC