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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.16 by root, Fri May 23 17:47:06 2008 UTC vs.
Revision 1.53 by root, Fri May 30 09:40:41 2008 UTC

…		…
3	AnyEvent::DNS - fully asynchronous DNS resolution	3	AnyEvent::DNS - fully asynchronous DNS resolution
4		4
5	=head1 SYNOPSIS	5	=head1 SYNOPSIS
6		6
7	use AnyEvent::DNS;	7	use AnyEvent::DNS;
		8
		9	my $cv = AnyEvent->condvar;
		10	AnyEvent::DNS::a "www.google.de", $cv;
		11	# ... later
		12	my @addrs = $cv->recv;
8		13
9	=head1 DESCRIPTION	14	=head1 DESCRIPTION
10		15
11	This module offers both a number of DNS convenience functions as well	16	This module offers both a number of DNS convenience functions as well
12	as a fully asynchronous and high-performance pure-perl stub resolver.	17	as a fully asynchronous and high-performance pure-perl stub resolver.
13		18
14	The stub resolver supports DNS over UDP, optional EDNS0 support for up to	19	The stub resolver supports DNS over IPv4 and IPv6, UDP and TCP, optional
15	4kiB datagrams and automatically falls back to virtual circuit mode for	20	EDNS0 support for up to 4kiB datagrams and automatically falls back to
16	large responses.	21	virtual circuit mode for large responses.
17		22
18	=head2 CONVENIENCE FUNCTIONS	23	=head2 CONVENIENCE FUNCTIONS
19		24
20	=over 4	25	=over 4
21		26
…		…
24	package AnyEvent::DNS;	29	package AnyEvent::DNS;
25		30
26	no warnings;	31	no warnings;
27	use strict;	32	use strict;
28		33
		34	use Socket qw(AF_INET SOCK_DGRAM SOCK_STREAM);
		35
29	use AnyEvent::Socket ();	36	use AnyEvent ();
30	use AnyEvent::Handle ();	37	use AnyEvent::Handle ();
		38	use AnyEvent::Util qw(AF_INET6);
31		39
32	=item AnyEvent::DNS::addr $node, $service, $family, $type, $cb->(@addrs)	40	our $VERSION = '1.0';
33		41
34	NOT YET IMPLEMENTED	42	our @DNS_FALLBACK = (v208.67.220.220, v208.67.222.222);
35
36	Tries to resolve the given nodename and service name into sockaddr
37	structures usable to connect to this node and service in a
38	protocol-independent way. It works similarly to the getaddrinfo posix
39	function.
40
41	Example:
42
43	AnyEvent::DNS::addr "google.com", "http", AF_UNSPEC, SOCK_STREAM, sub { ... };
44		43
45	=item AnyEvent::DNS::a $domain, $cb->(@addrs)	44	=item AnyEvent::DNS::a $domain, $cb->(@addrs)
46		45
47	Tries to resolve the given domain to IPv4 address(es).	46	Tries to resolve the given domain to IPv4 address(es).
		47
		48	=item AnyEvent::DNS::aaaa $domain, $cb->(@addrs)
		49
		50	Tries to resolve the given domain to IPv6 address(es).
48		51
49	=item AnyEvent::DNS::mx $domain, $cb->(@hostnames)	52	=item AnyEvent::DNS::mx $domain, $cb->(@hostnames)
50		53
51	Tries to resolve the given domain into a sorted (lower preference value	54	Tries to resolve the given domain into a sorted (lower preference value
52	first) list of domain names.	55	first) list of domain names.
…		…
62	=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)	65	=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)
63		66
64	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
65	of service records.	68	of service records.
66		69
67	Each srv_rr is an arrayref with the following contents:	70	Each srv_rr is an array reference with the following contents:
68	C<[$priority, $weight, $transport, $target]>.	71	C<[$priority, $weight, $transport, $target]>.
69		72
70	They will be sorted with lowest priority, highest weight first (TODO:	73	They will be sorted with lowest priority first, then randomly
71	should use the rfc algorithm to reorder same-priority records for weight).	74	distributed by weight as per RFC 2782.
72		75
73	Example:	76	Example:
74		77
75	AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...	78	AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...
76	# @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )	79	# @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )
77		80
78	=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)
79		93
80	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)
81	into it's hostname(s).	95	into it's hostname(s). Handles V4MAPPED and V4COMPAT IPv6 addresses
		96	transparently.
82		97
83	Requires the Socket6 module for IPv6 support.	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.
84		108
85	Example:	109	Example:
86		110
87	AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };	111	AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };
88	# => f.root-servers.net	112	# => f.root-servers.net
89		113
90	=item AnyEvent::DNS::any $domain, $cb->(@rrs)
91
92	Tries to resolve the given domain and passes all resource records found to
93	the callback.
94
95	=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
96		119
97	sub resolver;	120	sub resolver;
98		121
99	sub a($$) {	122	sub a($$) {
100	my ($domain, $cb) = @_;	123	my ($domain, $cb) = @_;
…		…
102	resolver->resolve ($domain => "a", sub {	125	resolver->resolve ($domain => "a", sub {
103	$cb->(map $_->[3], @_);	126	$cb->(map $_->[3], @_);
104	});	127	});
105	}	128	}
106		129
		130	sub aaaa($$) {
		131	my ($domain, $cb) = @_;
		132
		133	resolver->resolve ($domain => "aaaa", sub {
		134	$cb->(map $_->[3], @_);
		135	});
		136	}
		137
107	sub mx($$) {	138	sub mx($$) {
108	my ($domain, $cb) = @_;	139	my ($domain, $cb) = @_;
109		140
110	resolver->resolve ($domain => "mx", sub {	141	resolver->resolve ($domain => "mx", sub {
111	$cb->(map $_->[4], sort { $a->[3] <=> $b->[3] } @_);	142	$cb->(map $_->[4], sort { $a->[3] <=> $b->[3] } @_);
…		…
131	sub srv($$$$) {	162	sub srv($$$$) {
132	my ($service, $proto, $domain, $cb) = @_;	163	my ($service, $proto, $domain, $cb) = @_;
133		164
134	# todo, ask for any and check glue records	165	# todo, ask for any and check glue records
135	resolver->resolve ("_$service._$proto.$domain" => "srv", sub {	166	resolver->resolve ("_$service._$proto.$domain" => "srv", sub {
136	$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);
137	});	194	});
138	}	195	}
139		196
140	sub ptr($$) {	197	sub ptr($$) {
141	my ($ip, $cb) = @_;	198	my ($domain, $cb) = @_;
142		199
143	my $name;
144
145	if (AnyEvent::Util::dotted_quad $ip) {
146	$name = join ".", (reverse split /\./, $ip), "in-addr.arpa.";
147	} else {
148	require Socket6;
149	$name = join ".",
150	(reverse split //,
151	unpack "H*", Socket6::inet_pton (Socket::AF_INET6, $ip)),
152	"ip6.arpa.";
153	}
154
155	resolver->resolve ($name => "ptr", sub {	200	resolver->resolve ($domain => "ptr", sub {
156	$cb->(map $_->[3], @_);	201	$cb->(map $_->[3], @_);
157	});	202	});
158	}	203	}
159		204
160	sub any($$) {	205	sub any($$) {
161	my ($domain, $cb) = @_;	206	my ($domain, $cb) = @_;
162		207
163	resolver->resolve ($domain => "*", $cb);	208	resolver->resolve ($domain => "*", $cb);
164	}	209	}
165		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($$) {
		239	my ($ip, $cb) = @_;
		240
		241	$ip = _munge_ptr AnyEvent::Socket::parse_address ($ip)
		242	or return $cb->();
		243
		244	resolver->resolve ($ip => "ptr", sub {
		245	$cb->(map $_->[3], @_);
		246	});
		247	}
		248
		249	sub reverse_verify($$) {
		250	my ($ip, $cb) = @_;
		251
		252	my $ipn = AnyEvent::Socket::parse_address ($ip)
		253	or return $cb->();
		254
		255	my $af = AnyEvent::Socket::address_family ($ipn);
		256
		257	my @res;
		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;
		268
		269	# () around AF_INET to work around bug in 5.8
		270	resolver->resolve ($name => ($af == (AF_INET) ? "a" : "aaaa"), sub {
		271	for (@_) {
		272	push @res, $name
		273	if $_->[3] eq $ip;
		274	}
		275	$cb->(@res) unless --$cnt;
		276	});
		277	}
		278
		279	$cb->() unless $cnt;
		280	};
		281	}
		282
		283	#################################################################################
		284
166	=back	285	=back
167		286
168	=head2 LOW-LEVEL DNS EN-/DECODING FUNCTIONS	287	=head2 LOW-LEVEL DNS EN-/DECODING FUNCTIONS
169		288
170	=over 4	289	=over 4
171		290
172	=item $AnyEvent::DNS::EDNS0	291	=item $AnyEvent::DNS::EDNS0
173		292
174	This variable decides whether dns_pack automatically enables EDNS0	293	This variable decides whether dns_pack automatically enables EDNS0
175	support. By default, this is disabled (C<0>), but when set to C<1>,	294	support. By default, this is disabled (C<0>), unless overridden by
176	AnyEvent::DNS will use EDNS0 in all requests.	295	C<$ENV{PERL_ANYEVENT_EDNS0}>, but when set to C<1>, AnyEvent::DNS will use
		296	EDNS0 in all requests.
177		297
178	=cut	298	=cut
179		299
180	our $EDNS0 = 0; # set to 1 to enable (partial) edns0	300	our $EDNS0 = $ENV{PERL_ANYEVENT_EDNS0} * 1; # set to 1 to enable (partial) edns0
181		301
182	our %opcode_id = (	302	our %opcode_id = (
183	query => 0,	303	query => 0,
184	iquery => 1,	304	iquery => 1,
185	status => 2,	305	status => 2,
…		…
231	minfo => 14,	351	minfo => 14,
232	mx => 15,	352	mx => 15,
233	txt => 16,	353	txt => 16,
234	aaaa => 28,	354	aaaa => 28,
235	srv => 33,	355	srv => 33,
		356	naptr => 35, # rfc2915
236	opt => 41,	357	opt => 41,
237	spf => 99,	358	spf => 99,
238	tkey => 249,	359	tkey => 249,
239	tsig => 250,	360	tsig => 250,
240	ixfr => 251,	361	ixfr => 251,
…		…
253	"*" => 255,	374	"*" => 255,
254	);	375	);
255		376
256	our %class_str = reverse %class_id;	377	our %class_str = reverse %class_id;
257		378
258	# names MUST have a trailing dot
259	sub _enc_qname($) {	379	sub _enc_name($) {
260	pack "(C/a)*", (split /\./, shift), ""	380	pack "(C/a)", (split /\./, shift), ""
261	}	381	}
262		382
263	sub _enc_qd() {	383	sub _enc_qd() {
264	(_enc_qname $_->[0]) . pack "nn",	384	(_enc_name $_->[0]) . pack "nn",
265	($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}),	385	($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}),
266	($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] \|\| "in"})	386	($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] \|\| "in"})
267	}	387	}
268		388
269	sub _enc_rr() {	389	sub _enc_rr() {
270	die "encoding of resource records is not supported";	390	die "encoding of resource records is not supported";
271	}	391	}
272		392
273	=item $pkt = AnyEvent::DNS::dns_pack $dns	393	=item $pkt = AnyEvent::DNS::dns_pack $dns
274		394
275	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
276	recommended, then everything will be totally clear. Or maybe not.	396	recommended, then everything will be totally clear. Or maybe not.
277		397
278	Resource records are not yet encodable.	398	Resource records are not yet encodable.
279		399
280	Examples:	400	Examples:
…		…
323	+ $rcode_id{$req->{rc}} * 0x0001,	443	+ $rcode_id{$req->{rc}} * 0x0001,
324		444
325	scalar @{ $req->{qd} \|\| [] },	445	scalar @{ $req->{qd} \|\| [] },
326	scalar @{ $req->{an} \|\| [] },	446	scalar @{ $req->{an} \|\| [] },
327	scalar @{ $req->{ns} \|\| [] },	447	scalar @{ $req->{ns} \|\| [] },
328	$EDNS0 + scalar @{ $req->{ar} \|\| [] }, # include EDNS0 option here	448	$EDNS0 + scalar @{ $req->{ar} \|\| [] }, # EDNS0 option included here
329		449
330	(join "", map _enc_qd, @{ $req->{qd} \|\| [] }),	450	(join "", map _enc_qd, @{ $req->{qd} \|\| [] }),
331	(join "", map _enc_rr, @{ $req->{an} \|\| [] }),	451	(join "", map _enc_rr, @{ $req->{an} \|\| [] }),
332	(join "", map _enc_rr, @{ $req->{ns} \|\| [] }),	452	(join "", map _enc_rr, @{ $req->{ns} \|\| [] }),
333	(join "", map _enc_rr, @{ $req->{ar} \|\| [] }),	453	(join "", map _enc_rr, @{ $req->{ar} \|\| [] }),
334		454
335	($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
336	}	456	}
337		457
338	our $ofs;	458	our $ofs;
339	our $pkt;	459	our $pkt;
340		460
341	# bitches	461	# bitches
342	sub _dec_qname {	462	sub _dec_name {
343	my @res;	463	my @res;
344	my $redir;	464	my $redir;
345	my $ptr = $ofs;	465	my $ptr = $ofs;
346	my $cnt;	466	my $cnt;
347		467
348	while () {	468	while () {
349	return undef if ++$cnt >= 256; # to avoid DoS attacks	469	return undef if ++$cnt >= 256; # to avoid DoS attacks
350		470
351	my $len = ord substr $pkt, $ptr++, 1;	471	my $len = ord substr $pkt, $ptr++, 1;
352		472
353	if ($len & 0xc0) {	473	if ($len >= 0xc0) {
354	$ptr++;	474	$ptr++;
355	$ofs = $ptr if $ptr > $ofs;	475	$ofs = $ptr if $ptr > $ofs;
356	$ptr = (unpack "n", substr $pkt, $ptr - 2, 2) & 0x3fff;	476	$ptr = (unpack "n", substr $pkt, $ptr - 2, 2) & 0x3fff;
357	} elsif ($len) {	477	} elsif ($len) {
358	push @res, substr $pkt, $ptr, $len;	478	push @res, substr $pkt, $ptr, $len;
…		…
363	}	483	}
364	}	484	}
365	}	485	}
366		486
367	sub _dec_qd {	487	sub _dec_qd {
368	my $qname = _dec_qname;	488	my $qname = _dec_name;
369	my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;	489	my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;
370	[$qname, $type_str{$qt} \|\| $qt, $class_str{$qc} \|\| $qc]	490	[$qname, $type_str{$qt} \|\| $qt, $class_str{$qc} \|\| $qc]
371	}	491	}
372		492
373	our %dec_rr = (	493	our %dec_rr = (
374	1 => sub { Socket::inet_ntoa $_ }, # a	494	1 => sub { join ".", unpack "C4", $_ }, # a
375	2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns	495	2 => sub { local $ofs = $ofs - length; _dec_name }, # ns
376	5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname	496	5 => sub { local $ofs = $ofs - length; _dec_name }, # cname
377	6 => sub {	497	6 => sub {
378	local $ofs = $ofs - length;	498	local $ofs = $ofs - length;
379	my $mname = _dec_qname;	499	my $mname = _dec_name;
380	my $rname = _dec_qname;	500	my $rname = _dec_name;
381	($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)	501	($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)
382	}, # soa	502	}, # soa
383	11 => sub { ((Socket::inet_aton substr $_, 0, 4), unpack "C a*", substr $_, 4) }, # wks	503	11 => sub { ((join ".", unpack "C4", $_), unpack "C a*", substr $_, 4) }, # wks
384	12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr	504	12 => sub { local $ofs = $ofs - length; _dec_name }, # ptr
385	13 => sub { unpack "C/a C/a", $_ }, # hinfo	505	13 => sub { unpack "C/a* C/a*", $_ }, # hinfo
386	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
387	16 => sub { unpack "(C/a)*", $_ }, # txt	507	16 => sub { unpack "(C/a)", $_ }, # txt
388	28 => sub { sprintf "%04x:%04x:%04x:%04x:%04x:%04x:%04x:%04x", unpack "n8" }, # aaaa	508	28 => sub { AnyEvent::Socket::format_address ($_) }, # aaaa
389	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	},
390	99 => sub { unpack "(C/a)*", $_ }, # spf	515	99 => sub { unpack "(C/a)", $_ }, # spf
391	);	516	);
392		517
393	sub _dec_rr {	518	sub _dec_rr {
394	my $qname = _dec_qname;	519	my $name = _dec_name;
395		520
396	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;
397	local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen;	522	local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen;
398		523
399	[	524	[
400	$qname,	525	$name,
401	$type_str{$rt} \|\| $rt,	526	$type_str{$rt} \|\| $rt,
402	$class_str{$rc} \|\| $rc,	527	$class_str{$rc} \|\| $rc,
403	($dec_rr{$rt} \|\| sub { $_ })->(),	528	($dec_rr{$rt} \|\| sub { $_ })->(),
404	]	529	]
405	}	530	}
…		…
543		668
544	=over 4	669	=over 4
545		670
546	=item server => [...]	671	=item server => [...]
547		672
548	A list of server addressses (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
549	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).
550		676
551	=item timeout => [...]	677	=item timeout => [...]
552		678
553	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
554	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,
…		…
563	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
564	tries to resolve the name without any suffixes first.	690	tries to resolve the name without any suffixes first.
565		691
566	=item max_outstanding => $integer	692	=item max_outstanding => $integer
567		693
568	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
569	limits the numbe rof outstanding requests to C<$n> (default: C<10>), that means	695	option limits the number of outstanding requests to C<$integer>
570	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,
571	until some other requests have been resolved.	697	then the additional requests will be queued until some other requests have
		698	been resolved.
572		699
573	=item reuse => $seconds	700	=item reuse => $seconds
574		701
575	The number of seconds (default: C<60>) that a query id cannot be re-used	702	The number of seconds (default: C<300>) that a query id cannot be re-used
576	after a request. Since AnyEvent::DNS will only allocate up to 30000 ID's	703	after a timeout. If there as no time-out then query id's can be reused
577	at the same time, the long-term maximum number of requests per second is	704	immediately.
578	C<30000 / $seconds> (and thus C<500> requests/s by default).
579		705
580	=back	706	=back
581		707
582	=cut	708	=cut
583		709
584	sub new {	710	sub new {
585	my ($class, %arg) = @_;	711	my ($class, %arg) = @_;
586		712
		713	# try to create a ipv4 and an ipv6 socket
		714	# only fail when we cnanot create either
		715
587	socket my $fh, &Socket::AF_INET, &Socket::SOCK_DGRAM, 0	716	socket my $fh4, AF_INET , &Socket::SOCK_DGRAM, 0;
588	or Carp::croak "socket: $!";	717	socket my $fh6, AF_INET6, &Socket::SOCK_DGRAM, 0;
589		718
590	AnyEvent::Util::fh_nonblocking $fh, 1;	719	$fh4 \|\| $fh6
		720	or Carp::croak "unable to create either an IPv6 or an IPv4 socket";
591		721
592	my $self = bless {	722	my $self = bless {
593	server => [v127.0.0.1],	723	server => [],
594	timeout => [2, 5, 5],	724	timeout => [2, 5, 5],
595	search => [],	725	search => [],
596	ndots => 1,	726	ndots => 1,
597	max_outstanding => 10,	727	max_outstanding => 10,
598	reuse => 60, # reuse id's after 5 minutes only, if possible	728	reuse => 300, # reuse id's after 5 minutes only, if possible
599	%arg,	729	%arg,
600	fh => $fh,
601	reuse_q => [],	730	reuse_q => [],
602	}, $class;	731	}, $class;
603		732
604	# search should default to gethostname's domain	733	# search should default to gethostname's domain
605	# but perl lacks a good posix module	734	# but perl lacks a good posix module
606		735
607	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;
608	$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	}
609		757
610	$self->_compile;	758	$self->_compile;
611		759
612	$self	760	$self
613	}	761	}
614		762
615	=item $resolver->parse_resolv_conv ($string)	763	=item $resolver->parse_resolv_conv ($string)
616		764
617	Parses the given string a sif it were a F<resolv.conf> file. The following	765	Parses the given string as if it were a F<resolv.conf> file. The following
618	directives are supported (but not neecssarily implemented).	766	directives are supported (but not necessarily implemented).
619		767
620	C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,	768	C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,
621	C<options> (C<timeout>, C<attempts>, C<ndots>).	769	C<options> (C<timeout>, C<attempts>, C<ndots>).
622		770
623	Everything else is silently ignored.	771	Everything else is silently ignored.
…		…
635	for (split /\n/, $resolvconf) {	783	for (split /\n/, $resolvconf) {
636	if (/^\s*#/) {	784	if (/^\s*#/) {
637	# comment	785	# comment
638	} elsif (/^\snameserver\s+(\S+)\s$/i) {	786	} elsif (/^\snameserver\s+(\S+)\s$/i) {
639	my $ip = $1;	787	my $ip = $1;
640	if (AnyEvent::Util::dotted_quad $ip) {	788	if (my $ipn = AnyEvent::Socket::parse_address ($ip)) {
641	push @{ $self->{server} }, AnyEvent::Util::socket_inet_aton $ip;	789	push @{ $self->{server} }, $ipn;
642	} else {	790	} else {
643	warn "nameserver $ip invalid and ignored\n";	791	warn "nameserver $ip invalid and ignored\n";
644	}	792	}
645	} elsif (/^\sdomain\s+(\S)\s+$/i) {	793	} elsif (/^\sdomain\s+(\S)\s+$/i) {
646	$self->{search} = [$1];	794	$self->{search} = [$1];
…		…
669	$self->_compile;	817	$self->_compile;
670	}	818	}
671		819
672	=item $resolver->os_config	820	=item $resolver->os_config
673		821
674	Tries so load and parse F</etc/resolv.conf> on portable opertaing systems. Tries various	822	Tries so load and parse F</etc/resolv.conf> on portable operating systems. Tries various
675	egregious hacks on windows to force the dns servers and searchlist out of the config.	823	egregious hacks on windows to force the DNS servers and searchlist out of the system.
676		824
677	=cut	825	=cut
678		826
679	sub os_config {	827	sub os_config {
680	my ($self) = @_;	828	my ($self) = @_;
681		829
682	if ($^O =~ /mswin32\|cygwin/i) {	830	$self->{server} = [];
683	# 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 it's brokenness,
		844	# it seems most stable in practise.
		845	# for good measure, we append a fallback nameserver to our list.
684		846
685	if (open my $fh, "ipconfig /all \|") {	847	if (open my $fh, "ipconfig /all \|") {
686	delete $self->{server};	848	# parsing strategy: we go through the output and look for
687	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).
688		852
		853	my $dns;
689	while (<$fh>) {	854	while (<$fh>) {
690	# first DNS.* is suffix list	855	if (s/^\s.\bdns\b.://i) {
691	if (/^\s*DNS/) {	856	$dns = 1;
692	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 scope id
		863	if (my $ipn = AnyEvent::Socket::parse_address ($s)) {
		864	push @{ $self->{server} }, $ipn;
		865	} else {
693	push @{ $self->{search} }, $1;	866	push @{ $self->{search} }, $s;
694	$_ = <$fh>;
695	}	867	}
696	last;
697	}	868	}
698	}	869	}
699		870
700	while (<$fh>) {	871	# always add one fallback server
701	# second DNS.* is server address list	872	push @{ $self->{server} }, $DNS_FALLBACK[rand @DNS_FALLBACK];
702	if (/^\s*DNS/) {
703	while (/\s+(\d+\.\d+\.\d+\.\d+)\s*$/) {
704	my $ip = $1;
705	push @{ $self->{server} }, AnyEvent::Util::socket_inet_aton $ip
706	if AnyEvent::Util::dotted_quad $ip;
707	$_ = <$fh>;
708	}
709	last;
710	}
711	}
712		873
713	$self->_compile;	874	$self->_compile;
714	}	875	}
715	} else {	876	} else {
716	# try resolv.conf everywhere	877	# try resolv.conf everywhere
…		…
720	$self->parse_resolv_conf (<$fh>);	881	$self->parse_resolv_conf (<$fh>);
721	}	882	}
722	}	883	}
723	}	884	}
724		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 itselt, 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
725	sub _compile {	914	sub _compile {
726	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	}
727		924
728	my @retry;	925	my @retry;
729		926
730	for my $timeout (@{ $self->{timeout} }) {	927	for my $timeout (@{ $self->{timeout} }) {
731	for my $server (@{ $self->{server} }) {	928	for my $server (@{ $self->{server} }) {
…		…
749	$NOW = time;	946	$NOW = time;
750	$id->[1]->($res);	947	$id->[1]->($res);
751	}	948	}
752		949
753	sub _recv {	950	sub _recv {
754	my ($self) = @_;	951	my ($self, $pkt, $peer) = @_;
755		952
756	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
757	my ($port, $host) = Socket::unpack_sockaddr_in $peer;	956	my ($port, $host) = AnyEvent::Socket::unpack_sockaddr ($peer);
758		957
759	return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };	958	return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };
760		959
761	$self->_feed ($res);	960	$self->_feed ($pkt);
		961	}
		962
		963	sub _free_id {
		964	my ($self, $id, $timeout) = @_;
		965
		966	if ($timeout) {
		967	# we need to block the id for a while
		968	$self->{id}{$id} = 1;
		969	push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $id];
		970	} else {
		971	# we can quickly recycle the id
		972	delete $self->{id}{$id};
762	}	973	}
763	}
764		974
		975	--$self->{outstanding};
		976	$self->_scheduler;
		977	}
		978
		979	# execute a single request, involves sending it with timeouts to multiple servers
765	sub _exec {	980	sub _exec {
766	my ($self, $req, $retry) = @_;	981	my ($self, $req) = @_;
767		982
		983	my $retry; # of retries
		984	my $do_retry;
		985
		986	$do_retry = sub {
768	if (my $retry_cfg = $self->{retry}[$retry]) {	987	my $retry_cfg = $self->{retry}[$retry++]
		988	or do {
		989	# failure
		990	$self->_free_id ($req->[2], $retry > 1);
		991	undef $do_retry; return $req->[1]->();
		992	};
		993
769	my ($server, $timeout) = @$retry_cfg;	994	my ($server, $timeout) = @$retry_cfg;
770		995
771	$self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {	996	$self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {
772	$NOW = time;	997	$NOW = time;
773		998
774	# timeout, try next	999	# timeout, try next
775	$self->_exec ($req, $retry + 1);	1000	&$do_retry;
776	}), sub {	1001	}), sub {
777	my ($res) = @_;	1002	my ($res) = @_;
778		1003
779	if ($res->{tc}) {	1004	if ($res->{tc}) {
780	# success, but truncated, so use tcp	1005	# success, but truncated, so use tcp
781	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
782	my ($fh) = @_	1009	my ($fh) = @_
783	or return $self->_exec ($req, $retry + 1);	1010	or return &$do_retry;
784		1011
785	my $handle = new AnyEvent::Handle	1012	my $handle; $handle = new AnyEvent::Handle
786	fh => $fh,	1013	fh => $fh,
		1014	timeout => $timeout,
787	on_error => sub {	1015	on_error => sub {
		1016	undef $handle;
		1017	return unless $do_retry; # some other request could have invalidated us already
788	# failure, try next	1018	# failure, try next
789	$self->_exec ($req, $retry + 1);	1019	&$do_retry;
790	};	1020	};
791		1021
792	$handle->push_write (pack "n/a", $req->[0]);	1022	$handle->push_write (pack "n/a", $req->[0]);
793	$handle->push_read_chunk (2, sub {	1023	$handle->push_read (chunk => 2, sub {
794	$handle->unshift_read_chunk ((unpack "n", $_[1]), sub {	1024	$handle->unshift_read (chunk => (unpack "n", $_[1]), sub {
		1025	undef $handle;
795	$self->_feed ($_[1]);	1026	$self->_feed ($_[1]);
796	});	1027	});
797	});	1028	});
798	shutdown $fh, 1;
799		1029
800	}, sub { $timeout };	1030	}, sub { $timeout });
801		1031
802	} else {	1032	} else {
803	# success	1033	# success
804	$self->{id}{$req->[2]} = 1;	1034	$self->_free_id ($req->[2], $retry > 1);
805	push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];	1035	undef $do_retry; return $req->[1]->($res);
806	--$self->{outstanding};
807	$self->_scheduler;
808
809	$req->[1]->($res);
810	}	1036	}
811	}];	1037	}];
		1038
		1039	my $sa = AnyEvent::Socket::pack_sockaddr (DOMAIN_PORT, $server);
812		1040
813	send $self->{fh}, $req->[0], 0, Socket::pack_sockaddr_in 53, $server;	1041	my $fh = AF_INET == Socket::sockaddr_family ($sa)
814	} else {	1042	? $self->{fh4} : $self->{fh6}
815	# failure	1043	or return &$do_retry;
816	$self->{id}{$req->[2]} = 1;
817	push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];
818	--$self->{outstanding};
819	$self->_scheduler;
820		1044
821	$req->[1]->();	1045	send $fh, $req->[0], 0, $sa;
822	}	1046	};
		1047
		1048	&$do_retry;
823	}	1049	}
824		1050
825	sub _scheduler {	1051	sub _scheduler {
826	my ($self) = @_;	1052	my ($self) = @_;
		1053
		1054	no strict 'refs';
827		1055
828	$NOW = time;	1056	$NOW = time;
829		1057
830	# first clear id reuse queue	1058	# first clear id reuse queue
831	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }	1059	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }
…		…
840	$self->_scheduler;	1068	$self->_scheduler;
841	});	1069	});
842	last;	1070	last;
843	}	1071	}
844		1072
845	my $req = shift @{ $self->{queue} }	1073	if (my $req = shift @{ $self->{queue} }) {
846	or last;	1074	# found a request in the queue, execute it
847
848	while () {	1075	while () {
849	$req->[2] = int rand 65536;	1076	$req->[2] = int rand 65536;
850	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;
851	}	1093	}
852
853	$self->{id}{$req->[2]} = 1;
854	substr $req->[0], 0, 2, pack "n", $req->[2];
855
856	++$self->{outstanding};
857	$self->_exec ($req, 0);
858	}	1094	}
859	}	1095	}
860		1096
861	=item $resolver->request ($req, $cb->($res))	1097	=item $resolver->request ($req, $cb->($res))
862		1098
…		…
874	$self->_scheduler;	1110	$self->_scheduler;
875	}	1111	}
876		1112
877	=item $resolver->resolve ($qname, $qtype, %options, $cb->($rcode, @rr))	1113	=item $resolver->resolve ($qname, $qtype, %options, $cb->($rcode, @rr))
878		1114
879	Queries the DNS for the given domain name C<$qname> of type C<$qtype> (a	1115	Queries the DNS for the given domain name C<$qname> of type C<$qtype>.
880	qtype of "*" is supported and means "any").	1116
		1117	A C<$qtype> is either a numerical query type (e.g. C<1> for A recods) or
		1118	a lowercase name (you have to look at the source to see which aliases are
		1119	supported, but all types from RFC 1035, C<aaaa>, C<srv>, C<spf> and a few
		1120	more are known to this module). A qtype of "*" is supported and means
		1121	"any" record type.
881		1122
882	The callback will be invoked with a list of matching result records or	1123	The callback will be invoked with a list of matching result records or
883	none on any error or if the name could not be found.	1124	none on any error or if the name could not be found.
884		1125
885	CNAME chains (although illegal) are followed up to a length of 8.	1126	CNAME chains (although illegal) are followed up to a length of 8.
886		1127
		1128	The callback will be invoked with an result code in string form (noerror,
		1129	formerr, servfail, nxdomain, notimp, refused and so on), or numerical
		1130	form if the result code is not supported. The remaining arguments are
		1131	arraryefs of the form C<[$name, $type, $class, @data>], where C<$name> is
		1132	the domain name, C<$type> a type string or number, C<$class> a class name
		1133	and @data is resource-record-dependent data. For C<a> records, this will
		1134	be the textual IPv4 addresses, for C<ns> or C<cname> records this will be
		1135	a domain name, for C<txt> records these are all the strings and so on.
		1136
		1137	All types mentioned in RFC 1035, C<aaaa>, C<srv> and C<spf> are
		1138	decoded. All resource records not known to this module will just return
		1139	the raw C<rdata> field as fourth entry.
		1140
887	Note that this resolver is just a stub resolver: it requires a nameserver	1141	Note that this resolver is just a stub resolver: it requires a name server
888	supporting recursive queries, will not do any recursive queries itself and	1142	supporting recursive queries, will not do any recursive queries itself and
889	is not secure when used against an untrusted name server.	1143	is not secure when used against an untrusted name server.
890		1144
891	The following options are supported:	1145	The following options are supported:
892		1146
…		…
901		1155
902	=item accept => [$type...]	1156	=item accept => [$type...]
903		1157
904	Lists the acceptable result types: only result types in this set will be	1158	Lists the acceptable result types: only result types in this set will be
905	accepted and returned. The default includes the C<$qtype> and nothing	1159	accepted and returned. The default includes the C<$qtype> and nothing
906	else.	1160	else. If this list includes C<cname>, then CNAME-chains will not be
		1161	followed (because you asked for the CNAME record).
907		1162
908	=item class => "class"	1163	=item class => "class"
909		1164
910	Specify the query class ("in" for internet, "ch" for chaosnet and "hs" for	1165	Specify the query class ("in" for internet, "ch" for chaosnet and "hs" for
911	hesiod are the only ones making sense). The default is "in", of course.	1166	hesiod are the only ones making sense). The default is "in", of course.
912		1167
913	=back	1168	=back
914		1169
915	Examples:	1170	Examples:
916		1171
917	$res->resolve ("ruth.plan9.de", "a", sub {	1172	# full example, you can paste this into perl:
918	warn Dumper [@_];	1173	use Data::Dumper;
919	});	1174	use AnyEvent::DNS;
		1175	AnyEvent::DNS::resolver->resolve (
		1176	"google.com", "*", my $cv = AnyEvent->condvar);
		1177	warn Dumper [$cv->recv];
920		1178
		1179	# shortened result:
921	[	1180	# [
		1181	# [ 'google.com', 'soa', 'in', 'ns1.google.com', 'dns-admin.google.com',
		1182	# 2008052701, 7200, 1800, 1209600, 300 ],
922	[	1183	# [
923	'ruth.schmorp.de',	1184	# 'google.com', 'txt', 'in',
924	'a',	1185	# 'v=spf1 include:_netblocks.google.com ~all'
925	'in',	1186	# ],
926	'129.13.162.95'	1187	# [ 'google.com', 'a', 'in', '64.233.187.99' ],
		1188	# [ 'google.com', 'mx', 'in', 10, 'smtp2.google.com' ],
		1189	# [ 'google.com', 'ns', 'in', 'ns2.google.com' ],
927	]	1190	# ]
		1191
		1192	# resolve a records:
		1193	$res->resolve ("ruth.plan9.de", "a", sub { warn Dumper [@_] });
		1194
		1195	# result:
		1196	# [
		1197	# [ 'ruth.schmorp.de', 'a', 'in', '129.13.162.95' ]
928	]	1198	# ]
929		1199
		1200	# resolve any records, but return only a and aaaa records:
930	$res->resolve ("test1.laendle", "*",	1201	$res->resolve ("test1.laendle", "*",
931	accept => ["a", "aaaa"],	1202	accept => ["a", "aaaa"],
932	sub {	1203	sub {
933	warn Dumper [@_];	1204	warn Dumper [@_];
934	}	1205	}
935	);	1206	);
936		1207
937	[	1208	# result:
938	[	1209	# [
939	'test1.laendle',	1210	# [ 'test1.laendle', 'a', 'in', '10.0.0.255' ],
940	'a',	1211	# [ 'test1.laendle', 'aaaa', 'in', '3ffe:1900:4545:0002:0240:0000:0000:f7e1' ]
941	'in',
942	'10.0.0.255'
943	],
944	[
945	'test1.laendle',
946	'aaaa',
947	'in',
948	'3ffe:1900:4545:0002:0240:0000:0000:f7e1'
949	]	1212	# ]
950	]
951		1213
952	=cut	1214	=cut
953		1215
954	sub resolve($%) {	1216	sub resolve($%) {
955	my $cb = pop;	1217	my $cb = pop;
…		…
968	my %atype = $opt{accept}	1230	my %atype = $opt{accept}
969	? map +($_ => 1), @{ $opt{accept} }	1231	? map +($_ => 1), @{ $opt{accept} }
970	: ($qtype => 1);	1232	: ($qtype => 1);
971		1233
972	# advance in searchlist	1234	# advance in searchlist
973	my $do_search; $do_search = sub {	1235	my ($do_search, $do_req);
		1236
		1237	$do_search = sub {
974	@search	1238	@search
975	or return $cb->();	1239	or (undef $do_search), (undef $do_req), return $cb->();
976		1240
977	(my $name = lc "$qname." . shift @search) =~ s/\.$//;	1241	(my $name = lc "$qname." . shift @search) =~ s/\.$//;
978	my $depth = 2;	1242	my $depth = 2;
979		1243
980	# advance in cname-chain	1244	# advance in cname-chain
981	my $do_req; $do_req = sub {	1245	$do_req = sub {
982	$self->request ({	1246	$self->request ({
983	rd => 1,	1247	rd => 1,
984	qd => [[$name, $qtype, $class]],	1248	qd => [[$name, $qtype, $class]],
985	}, sub {	1249	}, sub {
986	my ($res) = @_	1250	my ($res) = @_
…		…
990		1254
991	while () {	1255	while () {
992	# results found?	1256	# results found?
993	my @rr = grep $name eq lc $_->[0] && ($atype{"*"} \|\| $atype{$_->[1]}), @{ $res->{an} };	1257	my @rr = grep $name eq lc $_->[0] && ($atype{"*"} \|\| $atype{$_->[1]}), @{ $res->{an} };
994		1258
995	return $cb->(@rr)	1259	(undef $do_search), (undef $do_req), return $cb->(@rr)
996	if @rr;	1260	if @rr;
997		1261
998	# see if there is a cname we can follow	1262	# see if there is a cname we can follow
999	my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} };	1263	my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} };
1000		1264
…		…
1021	};	1285	};
1022		1286
1023	$do_search->();	1287	$do_search->();
1024	}	1288	}
1025		1289
		1290	=item $resolver->wait_for_slot ($cb->($resolver))
		1291
		1292	Wait until a free request slot is available and call the callback with the
		1293	resolver object.
		1294
		1295	A request slot is used each time a request is actually sent to the
		1296	nameservers: There are never more than C<max_outstanding> of them.
		1297
		1298	Although you can submit more requests (they will simply be queued until
		1299	a request slot becomes available), sometimes, usually for rate-limiting
		1300	purposes, it is useful to instead wait for a slot before generating the
		1301	request (or simply to know when the request load is low enough so one can
		1302	submit requests again).
		1303
		1304	This is what this method does: The callback will be called when submitting
		1305	a DNS request will not result in that request being queued. The callback
		1306	may or may not generate any requests in response.
		1307
		1308	Note that the callback will only be invoked when the request queue is
		1309	empty, so this does not play well if somebody else keeps the request queue
		1310	full at all times.
		1311
		1312	=cut
		1313
		1314	sub wait_for_slot {
		1315	my ($self, $cb) = @_;
		1316
		1317	push @{ $self->{wait} }, $cb;
		1318	$self->_scheduler;
		1319	}
		1320
		1321	use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end
		1322
1026	1;	1323	1;
1027		1324
1028	=back	1325	=back
1029		1326
1030	=head1 AUTHOR	1327	=head1 AUTHOR

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.16 by root, Fri May 23 17:47:06 2008 UTC vs. Revision 1.53 by root, Fri May 30 09:40:41 2008 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.16 by root, Fri May 23 17:47:06 2008 UTC vs.
Revision 1.53 by root, Fri May 30 09:40:41 2008 UTC