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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.29 by root, Sun May 25 03:11:38 2008 UTC vs.
Revision 1.83 by root, Sat Feb 7 22:18:02 2009 UTC

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

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.29 by root, Sun May 25 03:11:38 2008 UTC vs. Revision 1.83 by root, Sat Feb 7 22:18:02 2009 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.29 by root, Sun May 25 03:11:38 2008 UTC vs.
Revision 1.83 by root, Sat Feb 7 22:18:02 2009 UTC