[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.60 by root, Tue Jun 3 09:02:46 2008 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.12;
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->[0] <=> $b->[0] } 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	my ($order, $preference, $flags, $service, $regexp, $offset) = unpack "nn C/a* C/a* C/a* .", $_;
		512	local $ofs = $ofs + $offset - length;
		513	($order, $preference, $flags, $service, $regexp, _dec_name)
		514	},
541	99 => sub { unpack "(C/a)*", $_ }, # spf	515	99 => sub { unpack "(C/a)", $_ }, # spf
542	);	516	);
543		517
544	sub _dec_rr {	518	sub _dec_rr {
545	my $qname = _dec_qname;	519	my $name = _dec_name;
546		520
547	my ($rt, $rc, $ttl, $rdlen) = unpack "nn N n", substr $pkt, $ofs; $ofs += 10;	521	my ($rt, $rc, $ttl, $rdlen) = unpack "nn N n", substr $pkt, $ofs; $ofs += 10;
548	local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen;	522	local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen;
549		523
550	[	524	[
551	$qname,	525	$name,
552	$type_str{$rt} \|\| $rt,	526	$type_str{$rt} \|\| $rt,
553	$class_str{$rc} \|\| $rc,	527	$class_str{$rc} \|\| $rc,
554	($dec_rr{$rt} \|\| sub { $_ })->(),	528	($dec_rr{$rt} \|\| sub { $_ })->(),
555	]	529	]
556	}	530	}
…		…
559		533
560	Unpacks a DNS packet into a perl data structure.	534	Unpacks a DNS packet into a perl data structure.
561		535
562	Examples:	536	Examples:
563		537
564	# an unsuccessful reply	538	# an unsuccessful reply
565	{	539	{
566	'qd' => [	540	'qd' => [
567	[ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]	541	[ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]
568	],	542	],
569	'rc' => 'nxdomain',	543	'rc' => 'nxdomain',
570	'ar' => [],	544	'ar' => [],
571	'ns' => [	545	'ns' => [
572	[	546	[
573	'uni-karlsruhe.de',	547	'uni-karlsruhe.de',
574	'soa',	548	'soa',
575	'in',	549	'in',
576	'netserv.rz.uni-karlsruhe.de',	550	'netserv.rz.uni-karlsruhe.de',
577	'hostmaster.rz.uni-karlsruhe.de',	551	'hostmaster.rz.uni-karlsruhe.de',
578	2008052201, 10800, 1800, 2592000, 86400	552	2008052201, 10800, 1800, 2592000, 86400
579	]	553	]
580	],	554	],
581	'tc' => '',	555	'tc' => '',
582	'ra' => 1,	556	'ra' => 1,
583	'qr' => 1,	557	'qr' => 1,
584	'id' => 45915,	558	'id' => 45915,
585	'aa' => '',	559	'aa' => '',
586	'an' => [],	560	'an' => [],
587	'rd' => 1,	561	'rd' => 1,
588	'op' => 'query'	562	'op' => 'query'
589	}	563	}
590		564
591	# a successful reply	565	# a successful reply
592		566
593	{	567	{
594	'qd' => [ [ 'www.google.de', 'a', 'in' ] ],	568	'qd' => [ [ 'www.google.de', 'a', 'in' ] ],
595	'rc' => 0,	569	'rc' => 0,
596	'ar' => [	570	'ar' => [
597	[ 'a.l.google.com', 'a', 'in', '209.85.139.9' ],	571	[ 'a.l.google.com', 'a', 'in', '209.85.139.9' ],
598	[ 'b.l.google.com', 'a', 'in', '64.233.179.9' ],	572	[ 'b.l.google.com', 'a', 'in', '64.233.179.9' ],
599	[ 'c.l.google.com', 'a', 'in', '64.233.161.9' ],	573	[ 'c.l.google.com', 'a', 'in', '64.233.161.9' ],
600	],	574	],
601	'ns' => [	575	'ns' => [
602	[ 'l.google.com', 'ns', 'in', 'a.l.google.com' ],	576	[ 'l.google.com', 'ns', 'in', 'a.l.google.com' ],
603	[ 'l.google.com', 'ns', 'in', 'b.l.google.com' ],	577	[ 'l.google.com', 'ns', 'in', 'b.l.google.com' ],
604	],	578	],
605	'tc' => '',	579	'tc' => '',
606	'ra' => 1,	580	'ra' => 1,
607	'qr' => 1,	581	'qr' => 1,
608	'id' => 64265,	582	'id' => 64265,
609	'aa' => '',	583	'aa' => '',
610	'an' => [	584	'an' => [
611	[ 'www.google.de', 'cname', 'in', 'www.google.com' ],	585	[ 'www.google.de', 'cname', 'in', 'www.google.com' ],
612	[ 'www.google.com', 'cname', 'in', 'www.l.google.com' ],	586	[ 'www.google.com', 'cname', 'in', 'www.l.google.com' ],
613	[ 'www.l.google.com', 'a', 'in', '66.249.93.104' ],	587	[ 'www.l.google.com', 'a', 'in', '66.249.93.104' ],
614	[ 'www.l.google.com', 'a', 'in', '66.249.93.147' ],	588	[ 'www.l.google.com', 'a', 'in', '66.249.93.147' ],
615	],	589	],
616	'rd' => 1,	590	'rd' => 1,
617	'op' => 0	591	'op' => 0
618	}	592	}
619		593
620	=cut	594	=cut
621		595
622	sub dns_unpack($) {	596	sub dns_unpack($) {
623	local $pkt = shift;	597	local $pkt = shift;
…		…
694		668
695	=over 4	669	=over 4
696		670
697	=item server => [...]	671	=item server => [...]
698		672
699	A list of server addresses (default: C<v127.0.0.1>) in network format (4	673	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).	674	(i.e. as returned by C<AnyEvent::Socket::parse_address> - both IPv4 and
		675	IPv6 are supported).
701		676
702	=item timeout => [...]	677	=item timeout => [...]
703		678
704	A list of timeouts to use (also determines the number of retries). To make	679	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,	680	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	689	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.	690	tries to resolve the name without any suffixes first.
716		691
717	=item max_outstanding => $integer	692	=item max_outstanding => $integer
718		693
719	Most name servers do not handle many parallel requests very well. This option	694	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	695	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	696	(default: C<10>), that means if you request more than this many requests,
722	until some other requests have been resolved.	697	then the additional requests will be queued until some other requests have
		698	been resolved.
723		699
724	=item reuse => $seconds	700	=item reuse => $seconds
725		701
726	The number of seconds (default: C<300>) that a query id cannot be re-used	702	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	703	after a timeout. If there was no time-out then query ids can be reused
728	immediately.	704	immediately.
729		705
730	=back	706	=back
731		707
732	=cut	708	=cut
733		709
734	sub new {	710	sub new {
735	my ($class, %arg) = @_;	711	my ($class, %arg) = @_;
736		712
		713	# try to create a ipv4 and an ipv6 socket
		714	# only fail when we cnanot create either
		715
737	socket my $fh, &Socket::AF_INET, &Socket::SOCK_DGRAM, 0	716	socket my $fh4, AF_INET , &Socket::SOCK_DGRAM, 0;
738	or Carp::croak "socket: $!";	717	socket my $fh6, AF_INET6, &Socket::SOCK_DGRAM, 0;
739		718
740	AnyEvent::Util::fh_nonblocking $fh, 1;	719	$fh4 \|\| $fh6
		720	or Carp::croak "unable to create either an IPv6 or an IPv4 socket";
741		721
742	my $self = bless {	722	my $self = bless {
743	server => [v127.0.0.1],	723	server => [],
744	timeout => [2, 5, 5],	724	timeout => [2, 5, 5],
745	search => [],	725	search => [],
746	ndots => 1,	726	ndots => 1,
747	max_outstanding => 10,	727	max_outstanding => 10,
748	reuse => 300, # reuse id's after 5 minutes only, if possible	728	reuse => 300,
749	%arg,	729	%arg,
750	fh => $fh,
751	reuse_q => [],	730	reuse_q => [],
752	}, $class;	731	}, $class;
753		732
754	# search should default to gethostname's domain	733	# search should default to gethostname's domain
755	# but perl lacks a good posix module	734	# but perl lacks a good posix module
756		735
757	Scalar::Util::weaken (my $wself = $self);	736	Scalar::Util::weaken (my $wself = $self);
		737
		738	if ($fh4) {
		739	AnyEvent::Util::fh_nonblocking $fh4, 1;
		740	$self->{fh4} = $fh4;
758	$self->{rw} = AnyEvent->io (fh => $fh, poll => "r", cb => sub { $wself->_recv });	741	$self->{rw4} = AnyEvent->io (fh => $fh4, poll => "r", cb => sub {
		742	if (my $peer = recv $fh4, my $pkt, MAX_PKT, 0) {
		743	$wself->_recv ($pkt, $peer);
		744	}
		745	});
		746	}
		747
		748	if ($fh6) {
		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	}
759		757
760	$self->_compile;	758	$self->_compile;
761		759
762	$self	760	$self
763	}	761	}
…		…
785	for (split /\n/, $resolvconf) {	783	for (split /\n/, $resolvconf) {
786	if (/^\s*#/) {	784	if (/^\s*#/) {
787	# comment	785	# comment
788	} elsif (/^\snameserver\s+(\S+)\s$/i) {	786	} elsif (/^\snameserver\s+(\S+)\s$/i) {
789	my $ip = $1;	787	my $ip = $1;
790	if (AnyEvent::Util::dotted_quad $ip) {	788	if (my $ipn = AnyEvent::Socket::parse_address ($ip)) {
791	push @{ $self->{server} }, AnyEvent::Util::socket_inet_aton $ip;	789	push @{ $self->{server} }, $ipn;
792	} else {	790	} else {
793	warn "nameserver $ip invalid and ignored\n";	791	warn "nameserver $ip invalid and ignored\n";
794	}	792	}
795	} elsif (/^\sdomain\s+(\S)\s+$/i) {	793	} elsif (/^\sdomain\s+(\S)\s+$/i) {
796	$self->{search} = [$1];	794	$self->{search} = [$1];
…		…
827	=cut	825	=cut
828		826
829	sub os_config {	827	sub os_config {
830	my ($self) = @_;	828	my ($self) = @_;
831		829
832	if ($^O =~ /mswin32\|cygwin/i) {	830	$self->{server} = [];
833	# yeah, it suxx... lets hope DNS is DNS in all locales	831	$self->{search} = [];
		832
		833	if (AnyEvent::WIN32 \|\| $^O =~ /cygwin/i) {
		834	no strict 'refs';
		835
		836	# there are many options to find the current nameservers etc. on windows
		837	# all of them don't work consistently:
		838	# - the registry thing needs separate code on win32 native vs. cygwin
		839	# - the registry layout differs between windows versions
		840	# - calling windows api functions doesn't work on cygwin
		841	# - ipconfig uses locale-specific messages
		842
		843	# we use ipconfig parsing because, despite all its brokenness,
		844	# it seems most stable in practise.
		845	# for good measure, we append a fallback nameserver to our list.
834		846
835	if (open my $fh, "ipconfig /all \|") {	847	if (open my $fh, "ipconfig /all \|") {
836	delete $self->{server};	848	# parsing strategy: we go through the output and look for
837	delete $self->{search};	849	# :-lines with DNS in them. everything in those is regarded as
		850	# either a nameserver (if it parses as an ip address), or a suffix
		851	# (all else).
838		852
		853	my $dns;
839	while (<$fh>) {	854	while (<$fh>) {
840	# first DNS.* is suffix list	855	if (s/^\s.\bdns\b.://i) {
841	if (/^\s*DNS/) {	856	$dns = 1;
842	while (/\s+([[:alnum:].\-]+)\s*$/) {	857	} elsif (/^\S/ \|\| /^\s[^:]{16,}: /) {
		858	$dns = 0;
		859	}
		860	if ($dns && /^\s(\S+)\s$/) {
		861	my $s = $1;
		862	$s =~ s/%\d+(?!\S)//; # get rid of ipv6 scope id
		863	if (my $ipn = AnyEvent::Socket::parse_address ($s)) {
		864	push @{ $self->{server} }, $ipn;
		865	} else {
843	push @{ $self->{search} }, $1;	866	push @{ $self->{search} }, $s;
844	$_ = <$fh>;
845	}	867	}
846	last;
847	}	868	}
848	}	869	}
849		870
850	while (<$fh>) {	871	# always add one fallback server
851	# second DNS.* is server address list	872	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		873
863	$self->_compile;	874	$self->_compile;
864	}	875	}
865	} else {	876	} else {
866	# try resolv.conf everywhere	877	# try resolv.conf everywhere
…		…
870	$self->parse_resolv_conf (<$fh>);	881	$self->parse_resolv_conf (<$fh>);
871	}	882	}
872	}	883	}
873	}	884	}
874		885
		886	=item $resolver->timeout ($timeout, ...)
		887
		888	Sets the timeout values. See the C<timeout> constructor argument (and note
		889	that this method uses the values itself, not an array-reference).
		890
		891	=cut
		892
		893	sub timeout {
		894	my ($self, @timeout) = @_;
		895
		896	$self->{timeout} = \@timeout;
		897	$self->_compile;
		898	}
		899
		900	=item $resolver->max_outstanding ($nrequests)
		901
		902	Sets the maximum number of outstanding requests to C<$nrequests>. See the
		903	C<max_outstanding> constructor argument.
		904
		905	=cut
		906
		907	sub max_outstanding {
		908	my ($self, $max) = @_;
		909
		910	$self->{max_outstanding} = $max;
		911	$self->_scheduler;
		912	}
		913
875	sub _compile {	914	sub _compile {
876	my $self = shift;	915	my $self = shift;
		916
		917	my %search; $self->{search} = [grep 0 < length, grep !$search{$_}++, @{ $self->{search} }];
		918	my %server; $self->{server} = [grep 0 < length, grep !$server{$_}++, @{ $self->{server} }];
		919
		920	unless (@{ $self->{server} }) {
		921	# use 127.0.0.1 by default, and one opendns nameserver as fallback
		922	$self->{server} = [v127.0.0.1, $DNS_FALLBACK[rand @DNS_FALLBACK]];
		923	}
877		924
878	my @retry;	925	my @retry;
879		926
880	for my $timeout (@{ $self->{timeout} }) {	927	for my $timeout (@{ $self->{timeout} }) {
881	for my $server (@{ $self->{server} }) {	928	for my $server (@{ $self->{server} }) {
…		…
899	$NOW = time;	946	$NOW = time;
900	$id->[1]->($res);	947	$id->[1]->($res);
901	}	948	}
902		949
903	sub _recv {	950	sub _recv {
904	my ($self) = @_;	951	my ($self, $pkt, $peer) = @_;
905		952
906	while (my $peer = recv $self->{fh}, my $res, 4096, 0) {	953	# we ignore errors (often one gets port unreachable, but there is
		954	# no good way to take advantage of that.
		955
907	my ($port, $host) = AnyEvent::Socket::unpack_sockaddr ($peer);	956	my ($port, $host) = AnyEvent::Socket::unpack_sockaddr ($peer);
908		957
909	return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };	958	return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };
910		959
911	$self->_feed ($res);	960	$self->_feed ($pkt);
912	}
913	}	961	}
914		962
915	sub _free_id {	963	sub _free_id {
916	my ($self, $id, $timeout) = @_;	964	my ($self, $id, $timeout) = @_;
917		965
…		…
953	}), sub {	1001	}), sub {
954	my ($res) = @_;	1002	my ($res) = @_;
955		1003
956	if ($res->{tc}) {	1004	if ($res->{tc}) {
957	# success, but truncated, so use tcp	1005	# success, but truncated, so use tcp
958	AnyEvent::Socket::tcp_connect ((Socket::inet_ntoa $server), 53, sub {	1006	AnyEvent::Socket::tcp_connect (AnyEvent::Socket::format_address ($server), DOMAIN_PORT, sub {
		1007	return unless $do_retry; # some other request could have invalidated us already
		1008
959	my ($fh) = @_	1009	my ($fh) = @_
960	or return &$do_retry;	1010	or return &$do_retry;
961		1011
962	my $handle = new AnyEvent::Handle	1012	my $handle; $handle = new AnyEvent::Handle
963	fh => $fh,	1013	fh => $fh,
		1014	timeout => $timeout,
964	on_error => sub {	1015	on_error => sub {
		1016	undef $handle;
		1017	return unless $do_retry; # some other request could have invalidated us already
965	# failure, try next	1018	# failure, try next
966	&$do_retry;	1019	&$do_retry;
967	};	1020	};
968		1021
969	$handle->push_write (pack "n/a", $req->[0]);	1022	$handle->push_write (pack "n/a", $req->[0]);
970	$handle->push_read_chunk (2, sub {	1023	$handle->push_read (chunk => 2, sub {
971	$handle->unshift_read_chunk ((unpack "n", $_[1]), sub {	1024	$handle->unshift_read (chunk => (unpack "n", $_[1]), sub {
		1025	undef $handle;
972	$self->_feed ($_[1]);	1026	$self->_feed ($_[1]);
973	});	1027	});
974	});	1028	});
975	shutdown $fh, 1;
976		1029
977	}, sub { $timeout });	1030	}, sub { $timeout });
978		1031
979	} else {	1032	} else {
980	# success	1033	# success
981	$self->_free_id ($req->[2], $retry > 1);	1034	$self->_free_id ($req->[2], $retry > 1);
982	undef $do_retry; return $req->[1]->($res);	1035	undef $do_retry; return $req->[1]->($res);
983	}	1036	}
984	}];	1037	}];
		1038
		1039	my $sa = AnyEvent::Socket::pack_sockaddr (DOMAIN_PORT, $server);
985		1040
986	send $self->{fh}, $req->[0], 0, AnyEvent::Socket::pack_sockaddr (53, $server);	1041	my $fh = AF_INET == Socket::sockaddr_family ($sa)
		1042	? $self->{fh4} : $self->{fh6}
		1043	or return &$do_retry;
		1044
		1045	send $fh, $req->[0], 0, $sa;
987	};	1046	};
988		1047
989	&$do_retry;	1048	&$do_retry;
990	}	1049	}
991		1050
992	sub _scheduler {	1051	sub _scheduler {
993	my ($self) = @_;	1052	my ($self) = @_;
		1053
		1054	no strict 'refs';
994		1055
995	$NOW = time;	1056	$NOW = time;
996		1057
997	# first clear id reuse queue	1058	# first clear id reuse queue
998	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }	1059	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }
…		…
1007	$self->_scheduler;	1068	$self->_scheduler;
1008	});	1069	});
1009	last;	1070	last;
1010	}	1071	}
1011		1072
1012	my $req = shift @{ $self->{queue} }	1073	if (my $req = shift @{ $self->{queue} }) {
1013	or last;	1074	# found a request in the queue, execute it
1014
1015	while () {	1075	while () {
1016	$req->[2] = int rand 65536;	1076	$req->[2] = int rand 65536;
1017	last unless exists $self->{id}{$req->[2]};	1077	last unless exists $self->{id}{$req->[2]};
		1078	}
		1079
		1080	++$self->{outstanding};
		1081	$self->{id}{$req->[2]} = 1;
		1082	substr $req->[0], 0, 2, pack "n", $req->[2];
		1083
		1084	$self->_exec ($req);
		1085
		1086	} elsif (my $cb = shift @{ $self->{wait} }) {
		1087	# found a wait_for_slot callback, call that one first
		1088	$cb->($self);
		1089
		1090	} else {
		1091	# nothing to do, just exit
		1092	last;
1018	}	1093	}
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	}	1094	}
1026	}	1095	}
1027		1096
1028	=item $resolver->request ($req, $cb->($res))	1097	=item $resolver->request ($req, $cb->($res))
1029		1098
		1099	This is the main low-level workhorse for sending DNS requests.
		1100
1030	Sends a single request (a hash-ref formated as specified for	1101	This function sends a single request (a hash-ref formated as specified
1031	C<dns_pack>) to the configured nameservers including	1102	for C<dns_pack>) to the configured nameservers in turn until it gets a
		1103	response. It handles timeouts, retries and automatically falls back to
		1104	virtual circuit mode (TCP) when it receives a truncated reply.
		1105
1032	retries. Calls the callback with the decoded response packet if a reply	1106	Calls the callback with the decoded response packet if a reply was
1033	was received, or no arguments on timeout.	1107	received, or no arguments in case none of the servers answered.
1034		1108
1035	=cut	1109	=cut
1036		1110
1037	sub request($$) {	1111	sub request($$) {
1038	my ($self, $req, $cb) = @_;	1112	my ($self, $req, $cb) = @_;
…		…
1041	$self->_scheduler;	1115	$self->_scheduler;
1042	}	1116	}
1043		1117
1044	=item $resolver->resolve ($qname, $qtype, %options, $cb->($rcode, @rr))	1118	=item $resolver->resolve ($qname, $qtype, %options, $cb->($rcode, @rr))
1045		1119
1046	Queries the DNS for the given domain name C<$qname> of type C<$qtype> (a	1120	Queries the DNS for the given domain name C<$qname> of type C<$qtype>.
1047	qtype of "*" is supported and means "any").	1121
		1122	A C<$qtype> is either a numerical query type (e.g. C<1> for A records) or
		1123	a lowercase name (you have to look at the source to see which aliases are
		1124	supported, but all types from RFC 1035, C<aaaa>, C<srv>, C<spf> and a few
		1125	more are known to this module). A C<$qtype> of "*" is supported and means
		1126	"any" record type.
1048		1127
1049	The callback will be invoked with a list of matching result records or	1128	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.	1129	none on any error or if the name could not be found.
1051		1130
1052	CNAME chains (although illegal) are followed up to a length of 8.	1131	CNAME chains (although illegal) are followed up to a length of 8.
		1132
		1133	The callback will be invoked with an result code in string form (noerror,
		1134	formerr, servfail, nxdomain, notimp, refused and so on), or numerical
		1135	form if the result code is not supported. The remaining arguments are
		1136	arraryefs of the form C<[$name, $type, $class, @data>], where C<$name> is
		1137	the domain name, C<$type> a type string or number, C<$class> a class name
		1138	and @data is resource-record-dependent data. For C<a> records, this will
		1139	be the textual IPv4 addresses, for C<ns> or C<cname> records this will be
		1140	a domain name, for C<txt> records these are all the strings and so on.
		1141
		1142	All types mentioned in RFC 1035, C<aaaa>, C<srv>, C<naptr> and C<spf> are
		1143	decoded. All resource records not known to this module will have
		1144	the raw C<rdata> field as fourth entry.
1053		1145
1054	Note that this resolver is just a stub resolver: it requires a name server	1146	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	1147	supporting recursive queries, will not do any recursive queries itself and
1056	is not secure when used against an untrusted name server.	1148	is not secure when used against an untrusted name server.
1057		1149
…		…
1061		1153
1062	=item search => [$suffix...]	1154	=item search => [$suffix...]
1063		1155
1064	Use the given search list (which might be empty), by appending each one	1156	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	1157	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,	1158	C<ndots> and C<search> values define its value (depending on C<ndots>, the
1067	then the searchlist will be ignored.	1159	empty suffix will be prepended or appended to that C<search> value). If
		1160	the C<$qname> ends in a dot, then the searchlist will be ignored.
1068		1161
1069	=item accept => [$type...]	1162	=item accept => [$type...]
1070		1163
1071	Lists the acceptable result types: only result types in this set will be	1164	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	1165	accepted and returned. The default includes the C<$qtype> and nothing
1073	else.	1166	else. If this list includes C<cname>, then CNAME-chains will not be
		1167	followed (because you asked for the CNAME record).
1074		1168
1075	=item class => "class"	1169	=item class => "class"
1076		1170
1077	Specify the query class ("in" for internet, "ch" for chaosnet and "hs" for	1171	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.	1172	hesiod are the only ones making sense). The default is "in", of course.
1079		1173
1080	=back	1174	=back
1081		1175
1082	Examples:	1176	Examples:
1083		1177
1084	$res->resolve ("ruth.plan9.de", "a", sub {	1178	# full example, you can paste this into perl:
1085	warn Dumper [@_];	1179	use Data::Dumper;
1086	});	1180	use AnyEvent::DNS;
		1181	AnyEvent::DNS::resolver->resolve (
		1182	"google.com", "*", my $cv = AnyEvent->condvar);
		1183	warn Dumper [$cv->recv];
1087		1184
		1185	# shortened result:
1088	[	1186	# [
		1187	# [ 'google.com', 'soa', 'in', 'ns1.google.com', 'dns-admin.google.com',
		1188	# 2008052701, 7200, 1800, 1209600, 300 ],
1089	[	1189	# [
1090	'ruth.schmorp.de',	1190	# 'google.com', 'txt', 'in',
1091	'a',	1191	# 'v=spf1 include:_netblocks.google.com ~all'
1092	'in',	1192	# ],
1093	'129.13.162.95'	1193	# [ 'google.com', 'a', 'in', '64.233.187.99' ],
		1194	# [ 'google.com', 'mx', 'in', 10, 'smtp2.google.com' ],
		1195	# [ 'google.com', 'ns', 'in', 'ns2.google.com' ],
1094	]	1196	# ]
		1197
		1198	# resolve a records:
		1199	$res->resolve ("ruth.plan9.de", "a", sub { warn Dumper [@_] });
		1200
		1201	# result:
		1202	# [
		1203	# [ 'ruth.schmorp.de', 'a', 'in', '129.13.162.95' ]
1095	]	1204	# ]
1096		1205
		1206	# resolve any records, but return only a and aaaa records:
1097	$res->resolve ("test1.laendle", "*",	1207	$res->resolve ("test1.laendle", "*",
1098	accept => ["a", "aaaa"],	1208	accept => ["a", "aaaa"],
1099	sub {	1209	sub {
1100	warn Dumper [@_];	1210	warn Dumper [@_];
1101	}	1211	}
1102	);	1212	);
1103		1213
1104	[	1214	# result:
1105	[	1215	# [
1106	'test1.laendle',	1216	# [ 'test1.laendle', 'a', 'in', '10.0.0.255' ],
1107	'a',	1217	# [ '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	]	1218	# ]
1117	]
1118		1219
1119	=cut	1220	=cut
1120		1221
1121	sub resolve($%) {	1222	sub resolve($%) {
1122	my $cb = pop;	1223	my $cb = pop;
…		…
1190	};	1291	};
1191		1292
1192	$do_search->();	1293	$do_search->();
1193	}	1294	}
1194		1295
		1296	=item $resolver->wait_for_slot ($cb->($resolver))
		1297
		1298	Wait until a free request slot is available and call the callback with the
		1299	resolver object.
		1300
		1301	A request slot is used each time a request is actually sent to the
		1302	nameservers: There are never more than C<max_outstanding> of them.
		1303
		1304	Although you can submit more requests (they will simply be queued until
		1305	a request slot becomes available), sometimes, usually for rate-limiting
		1306	purposes, it is useful to instead wait for a slot before generating the
		1307	request (or simply to know when the request load is low enough so one can
		1308	submit requests again).
		1309
		1310	This is what this method does: The callback will be called when submitting
		1311	a DNS request will not result in that request being queued. The callback
		1312	may or may not generate any requests in response.
		1313
		1314	Note that the callback will only be invoked when the request queue is
		1315	empty, so this does not play well if somebody else keeps the request queue
		1316	full at all times.
		1317
		1318	=cut
		1319
		1320	sub wait_for_slot {
		1321	my ($self, $cb) = @_;
		1322
		1323	push @{ $self->{wait} }, $cb;
		1324	$self->_scheduler;
		1325	}
		1326
1195	use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end	1327	use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end
1196		1328
1197	1;	1329	1;
1198		1330
1199	=back	1331	=back
1200		1332
1201	=head1 AUTHOR	1333	=head1 AUTHOR
1202		1334
1203	Marc Lehmann <schmorp@schmorp.de>	1335	Marc Lehmann <schmorp@schmorp.de>
1204	http://home.schmorp.de/	1336	http://home.schmorp.de/
1205		1337
1206	=cut	1338	=cut
1207		1339

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.60 by root, Tue Jun 3 09:02:46 2008 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.60 by root, Tue Jun 3 09:02:46 2008 UTC