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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.34 by root, Mon May 26 05:46:35 2008 UTC vs.
Revision 1.96 by root, Mon Jun 29 21:00:32 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", $cv;	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 qw(WIN32);	36	use AnyEvent ();
37	use AnyEvent::Handle ();	37	use AnyEvent::Handle ();
		38	use AnyEvent::Util qw(AF_INET6);
		39
		40	our $VERSION = 4.45;
38		41
39	our @DNS_FALLBACK = (v208.67.220.220, v208.67.222.222);	42	our @DNS_FALLBACK = (v208.67.220.220, v208.67.222.222);
40
41	=item AnyEvent::DNS::addr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...)
42
43	Tries to resolve the given nodename and service name into protocol families
44	and sockaddr structures usable to connect to this node and service in a
45	protocol-independent way. It works remotely similar to the getaddrinfo
46	posix function.
47
48	C<$node> is either an IPv4 or IPv6 address or a hostname, C<$service> is
49	either a service name (port name from F</etc/services>) or a numerical
50	port number. If both C<$node> and C<$service> are names, then SRV records
51	will be consulted to find the real service, otherwise they will be
52	used as-is. If you know that the service name is not in your services
53	database, then you can specify the service in the format C<name=port>
54	(e.g. C<http=80>).
55
56	C<$proto> must be a protocol name, currently C<tcp>, C<udp> or
57	C<sctp>. The default is C<tcp>.
58
59	C<$family> must be either C<0> (meaning any protocol is OK), C<4> (use
60	only IPv4) or C<6> (use only IPv6). This setting might be influenced by
61	C<$ENV{PERL_ANYEVENT_PROTOCOLS}>.
62
63	C<$type> must be C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_SEQPACKET> (or
64	C<undef> in which case it gets automatically chosen).
65
66	The callback will receive zero or more array references that contain
67	C<$family, $type, $proto> for use in C<socket> and a binary
68	C<$sockaddr> for use in C<connect> (or C<bind>).
69
70	The application should try these in the order given.
71
72	Example:
73
74	AnyEvent::DNS::addr "google.com", "http", 0, undef, undef, sub { ... };
75		43
76	=item AnyEvent::DNS::a $domain, $cb->(@addrs)	44	=item AnyEvent::DNS::a $domain, $cb->(@addrs)
77		45
78	Tries to resolve the given domain to IPv4 address(es).	46	Tries to resolve the given domain to IPv4 address(es).
79		47
…		…
97	=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)	65	=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)
98		66
99	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
100	of service records.	68	of service records.
101		69
102	Each srv_rr is an array reference with the following contents:	70	Each C<$srv_rr> is an array reference with the following contents:
103	C<[$priority, $weight, $transport, $target]>.	71	C<[$priority, $weight, $transport, $target]>.
104		72
105	They will be sorted with lowest priority, highest weight first (TODO:	73	They will be sorted with lowest priority first, then randomly
106	should use the RFC algorithm to reorder same-priority records for weight).	74	distributed by weight as per RFC 2782.
107		75
108	Example:	76	Example:
109		77
110	AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...	78	AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...
111	# @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )	79	# @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )
112		80
113	=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)
114		93
115	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)
116	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.
117		108
118	Example:	109	Example:
119		110
120	AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };	111	AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };
121	# => f.root-servers.net	112	# => f.root-servers.net
122		113
123	=item AnyEvent::DNS::any $domain, $cb->(@rrs)
124
125	Tries to resolve the given domain and passes all resource records found to
126	the callback.
127
128	=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
129		119
130	sub resolver;	120	sub resolver;
131		121
132	sub a($$) {	122	sub a($$) {
133	my ($domain, $cb) = @_;	123	my ($domain, $cb) = @_;
…		…
172	sub srv($$$$) {	162	sub srv($$$$) {
173	my ($service, $proto, $domain, $cb) = @_;	163	my ($service, $proto, $domain, $cb) = @_;
174		164
175	# todo, ask for any and check glue records	165	# todo, ask for any and check glue records
176	resolver->resolve ("_$service._$proto.$domain" => "srv", sub {	166	resolver->resolve ("_$service._$proto.$domain" => "srv", sub {
177	$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);
178	});	194	});
179	}	195	}
180		196
181	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($$) {
182	my ($ip, $cb) = @_;	239	my ($ip, $cb) = @_;
183		240
184	$ip = AnyEvent::Socket::parse_ip ($ip)	241	$ip = _munge_ptr AnyEvent::Socket::parse_address ($ip)
185	or return $cb->();	242	or return $cb->();
186
187	if (4 == length $ip) {
188	$ip = join ".", (reverse split /\./, $ip), "in-addr.arpa.";
189	} else {
190	$ip = join ".", (reverse split //, unpack "H*", $ip), "ip6.arpa.";
191	}
192		243
193	resolver->resolve ($ip => "ptr", sub {	244	resolver->resolve ($ip => "ptr", sub {
194	$cb->(map $_->[3], @_);	245	$cb->(map $_->[3], @_);
195	});	246	});
196	}	247	}
197		248
198	sub any($$) {	249	sub reverse_verify($$) {
199	my ($domain, $cb) = @_;	250	my ($ip, $cb) = @_;
200		251
201	resolver->resolve ($domain => "*", $cb);	252	my $ipn = AnyEvent::Socket::parse_address ($ip)
202	}
203
204	#############################################################################
205
206	sub addr($$$$$$) {
207	my ($node, $service, $proto, $family, $type, $cb) = @_;
208
209	unless (&AnyEvent::Util::AF_INET6) {
210	$family != 6
211	or return $cb->();	253	or return $cb->();
212		254
213	$family \|\|= 4;	255	my $af = AnyEvent::Socket::address_family ($ipn);
214	}
215		256
216	$cb->() if $family == 4 && !$AnyEvent::PROTOCOL{ipv4};
217	$cb->() if $family == 6 && !$AnyEvent::PROTOCOL{ipv6};
218
219	$family \|\|=4 unless $AnyEvent::PROTOCOL{ipv6};
220	$family \|\|=6 unless $AnyEvent::PROTOCOL{ipv4};
221
222	$proto \|\|= "tcp";
223	$type \|\|= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;
224
225	my $proton = (getprotobyname $proto)[2]
226	or Carp::croak "$proto: protocol unknown";
227
228	my $port;
229
230	if ($service =~ /^(\S+)=(\d+)$/) {
231	($service, $port) = ($1, $2);
232	} elsif ($service =~ /^\d+$/) {
233	($service, $port) = (undef, $service);
234	} else {
235	$port = (getservbyname $service, $proto)[2]
236	or Carp::croak "$service/$proto: service unknown";
237	}
238
239	my @target = [$node, $port];
240
241	# resolve a records / provide sockaddr structures
242	my $resolve = sub {
243	my @res;	257	my @res;
244	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;
245	$cb->(	268
246	map $_->[2],	269	# () around AF_INET to work around bug in 5.8
		270	resolver->resolve ("$name." => ($af == (AF_INET) ? "a" : "aaaa"), sub {
247	sort {	271	for (@_) {
248	$AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]}	272	push @res, $name
249	or $a->[0] <=> $b->[0]	273	if $_->[3] eq $ip;
250	}	274	}
251	@res	275	$cb->(@res) unless --$cnt;
252	)	276	});
253	});
254
255	$cv->begin;
256	for my $idx (0 .. $#target) {
257	my ($node, $port) = @{ $target[$idx] };
258
259	if (my $noden = AnyEvent::Socket::parse_ip ($node)) {
260	if (4 == length $noden && $family != 6) {
261	push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
262	AnyEvent::Socket::pack_sockaddr ($port, $noden)]]
263	}
264
265	if (16 == length $noden && $family != 4) {
266	push @res, [$idx, "ipv6", [&AnyEvent::Util::AF_INET6, $type, $proton,
267	AnyEvent::Socket::pack_sockaddr ( $port, $noden)]]
268	}
269	} else {
270	# ipv4
271	if ($family != 6) {
272	$cv->begin;
273	a $node, sub {
274	push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
275	AnyEvent::Socket::pack_sockaddr ($port, AnyEvent::Socket::parse_ipv4 ($_))]]
276	for @_;
277	$cv->end;
278	};
279	}
280
281	# ipv6
282	if ($family != 4) {
283	$cv->begin;
284	aaaa $node, sub {
285	push @res, [$idx, "ipv6", [&AnyEvent::Socket::AF_INET6, $type, $proton,
286	AnyEvent::Socket::pack_sockaddr ($port, AnyEvent::Socket::parse_ipv6 ($_))]]
287	for @_;
288	$cv->end;
289	};
290	}
291	}
292	}	277	}
293	$cv->end;	278
		279	$cb->() unless $cnt;
294	};	280	};
295
296	# try srv records, if applicable
297	if ($node eq "localhost") {
298	@target = (["127.0.0.1", $port], ["::1", $port]);
299	&$resolve;
300	} elsif (defined $service && !AnyEvent::Socket::parse_ip ($node)) {
301	srv $service, $proto, $node, sub {
302	my (@srv) = @_;
303
304	# no srv records, continue traditionally
305	@srv
306	or return &$resolve;
307
308	# only srv record has "." => abort
309	$srv[0][2] ne "." \|\| $#srv
310	or return $cb->();
311
312	# use srv records then
313	@target = map ["$_->[3].", $_->[2]],
314	grep $_->[3] ne ".",
315	@srv;
316
317	&$resolve;
318	};
319	} else {
320	&$resolve;
321	}
322	}	281	}
323		282
324	#############################################################################	283	#################################################################################
325		284
326	=back	285	=back
327		286
328	=head2 LOW-LEVEL DNS EN-/DECODING FUNCTIONS	287	=head2 LOW-LEVEL DNS EN-/DECODING FUNCTIONS
329		288
…		…
331		290
332	=item $AnyEvent::DNS::EDNS0	291	=item $AnyEvent::DNS::EDNS0
333		292
334	This variable decides whether dns_pack automatically enables EDNS0	293	This variable decides whether dns_pack automatically enables EDNS0
335	support. By default, this is disabled (C<0>), unless overridden by	294	support. By default, this is disabled (C<0>), unless overridden by
336	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
337	EDNS0 in all requests.	296	EDNS0 in all requests.
338		297
339	=cut	298	=cut
340		299
341	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
342		301
343	our %opcode_id = (	302	our %opcode_id = (
344	query => 0,	303	query => 0,
345	iquery => 1,	304	iquery => 1,
346	status => 2,	305	status => 2,
…		…
392	minfo => 14,	351	minfo => 14,
393	mx => 15,	352	mx => 15,
394	txt => 16,	353	txt => 16,
395	aaaa => 28,	354	aaaa => 28,
396	srv => 33,	355	srv => 33,
		356	naptr => 35, # rfc2915
		357	dname => 39, # rfc2672
397	opt => 41,	358	opt => 41,
398	spf => 99,	359	spf => 99,
399	tkey => 249,	360	tkey => 249,
400	tsig => 250,	361	tsig => 250,
401	ixfr => 251,	362	ixfr => 251,
…		…
414	"*" => 255,	375	"*" => 255,
415	);	376	);
416		377
417	our %class_str = reverse %class_id;	378	our %class_str = reverse %class_id;
418		379
419	# names MUST have a trailing dot
420	sub _enc_name($) {	380	sub _enc_name($) {
421	pack "(C/a)", (split /\./, shift), ""	381	pack "(C/a)", (split /\./, shift), ""
422	}	382	}
423		383
424	sub _enc_qd() {	384	sub _enc_qd() {
…		…
431	die "encoding of resource records is not supported";	391	die "encoding of resource records is not supported";
432	}	392	}
433		393
434	=item $pkt = AnyEvent::DNS::dns_pack $dns	394	=item $pkt = AnyEvent::DNS::dns_pack $dns
435		395
436	Packs a perl data structure into a DNS packet. Reading RFC1034 is strongly	396	Packs a perl data structure into a DNS packet. Reading RFC 1035 is strongly
437	recommended, then everything will be totally clear. Or maybe not.	397	recommended, then everything will be totally clear. Or maybe not.
438		398
439	Resource records are not yet encodable.	399	Resource records are not yet encodable.
440		400
441	Examples:	401	Examples:
442		402
443	# very simple request, using lots of default values:	403	# very simple request, using lots of default values:
444	{ rd => 1, qd => [ [ "host.domain", "a"] ] }	404	{ rd => 1, qd => [ [ "host.domain", "a"] ] }
445		405
446	# more complex example, showing how flags etc. are named:	406	# more complex example, showing how flags etc. are named:
447		407
448	{	408	{
449	id => 10000,	409	id => 10000,
450	op => "query",	410	op => "query",
451	rc => "nxdomain",	411	rc => "nxdomain",
452		412
453	# flags	413	# flags
454	qr => 1,	414	qr => 1,
455	aa => 0,	415	aa => 0,
456	tc => 0,	416	tc => 0,
457	rd => 0,	417	rd => 0,
458	ra => 0,	418	ra => 0,
459	ad => 0,	419	ad => 0,
460	cd => 0,	420	cd => 0,
461		421
462	qd => [@rr], # query section	422	qd => [@rr], # query section
463	an => [@rr], # answer section	423	an => [@rr], # answer section
464	ns => [@rr], # authority section	424	ns => [@rr], # authority section
465	ar => [@rr], # additional records section	425	ar => [@rr], # additional records section
466	}	426	}
467		427
468	=cut	428	=cut
469		429
470	sub dns_pack($) {	430	sub dns_pack($) {
471	my ($req) = @_;	431	my ($req) = @_;
…		…
484	+ $rcode_id{$req->{rc}} * 0x0001,	444	+ $rcode_id{$req->{rc}} * 0x0001,
485		445
486	scalar @{ $req->{qd} \|\| [] },	446	scalar @{ $req->{qd} \|\| [] },
487	scalar @{ $req->{an} \|\| [] },	447	scalar @{ $req->{an} \|\| [] },
488	scalar @{ $req->{ns} \|\| [] },	448	scalar @{ $req->{ns} \|\| [] },
489	$EDNS0 + scalar @{ $req->{ar} \|\| [] }, # include EDNS0 option here	449	$EDNS0 + scalar @{ $req->{ar} \|\| [] }, # EDNS0 option included here
490		450
491	(join "", map _enc_qd, @{ $req->{qd} \|\| [] }),	451	(join "", map _enc_qd, @{ $req->{qd} \|\| [] }),
492	(join "", map _enc_rr, @{ $req->{an} \|\| [] }),	452	(join "", map _enc_rr, @{ $req->{an} \|\| [] }),
493	(join "", map _enc_rr, @{ $req->{ns} \|\| [] }),	453	(join "", map _enc_rr, @{ $req->{ns} \|\| [] }),
494	(join "", map _enc_rr, @{ $req->{ar} \|\| [] }),	454	(join "", map _enc_rr, @{ $req->{ar} \|\| [] }),
495		455
496	($EDNS0 ? pack "C nnNn", 0, 41, 4096, 0, 0 : "") # EDNS0, 4kiB udp payload size	456	($EDNS0 ? pack "C nnNn", 0, 41, MAX_PKT, 0, 0 : "") # EDNS0 option
497	}	457	}
498		458
499	our $ofs;	459	our $ofs;
500	our $pkt;	460	our $pkt;
501		461
…		…
544	11 => sub { ((join ".", unpack "C4", $_), unpack "C a*", substr $_, 4) }, # wks	504	11 => sub { ((join ".", unpack "C4", $_), unpack "C a*", substr $_, 4) }, # wks
545	12 => sub { local $ofs = $ofs - length; _dec_name }, # ptr	505	12 => sub { local $ofs = $ofs - length; _dec_name }, # ptr
546	13 => sub { unpack "C/a* C/a*", $_ }, # hinfo	506	13 => sub { unpack "C/a* C/a*", $_ }, # hinfo
547	15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_name) }, # mx	507	15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_name) }, # mx
548	16 => sub { unpack "(C/a)", $_ }, # txt	508	16 => sub { unpack "(C/a)", $_ }, # txt
549	28 => sub { AnyEvent::Socket::format_ip ($_) }, # aaaa	509	28 => sub { AnyEvent::Socket::format_address ($_) }, # aaaa
550	33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_name) }, # srv	510	33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_name) }, # srv
		511	35 => sub { # naptr
		512	# requires perl 5.10, sorry
		513	my ($order, $preference, $flags, $service, $regexp, $offset) = unpack "nn C/a* C/a* C/a* .", $_;
		514	local $ofs = $ofs + $offset - length;
		515	($order, $preference, $flags, $service, $regexp, _dec_name)
		516	},
		517	39 => sub { local $ofs = $ofs - length; _dec_name }, # dname
551	99 => sub { unpack "(C/a)", $_ }, # spf	518	99 => sub { unpack "(C/a)", $_ }, # spf
552	);	519	);
553		520
554	sub _dec_rr {	521	sub _dec_rr {
555	my $name = _dec_name;	522	my $name = _dec_name;
…		…
569		536
570	Unpacks a DNS packet into a perl data structure.	537	Unpacks a DNS packet into a perl data structure.
571		538
572	Examples:	539	Examples:
573		540
574	# an unsuccessful reply	541	# an unsuccessful reply
575	{	542	{
576	'qd' => [	543	'qd' => [
577	[ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]	544	[ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]
578	],	545	],
579	'rc' => 'nxdomain',	546	'rc' => 'nxdomain',
580	'ar' => [],	547	'ar' => [],
581	'ns' => [	548	'ns' => [
582	[	549	[
583	'uni-karlsruhe.de',	550	'uni-karlsruhe.de',
584	'soa',	551	'soa',
585	'in',	552	'in',
586	'netserv.rz.uni-karlsruhe.de',	553	'netserv.rz.uni-karlsruhe.de',
587	'hostmaster.rz.uni-karlsruhe.de',	554	'hostmaster.rz.uni-karlsruhe.de',
588	2008052201, 10800, 1800, 2592000, 86400	555	2008052201, 10800, 1800, 2592000, 86400
589	]	556	]
590	],	557	],
591	'tc' => '',	558	'tc' => '',
592	'ra' => 1,	559	'ra' => 1,
593	'qr' => 1,	560	'qr' => 1,
594	'id' => 45915,	561	'id' => 45915,
595	'aa' => '',	562	'aa' => '',
596	'an' => [],	563	'an' => [],
597	'rd' => 1,	564	'rd' => 1,
598	'op' => 'query'	565	'op' => 'query'
599	}	566	}
600		567
601	# a successful reply	568	# a successful reply
602		569
603	{	570	{
604	'qd' => [ [ 'www.google.de', 'a', 'in' ] ],	571	'qd' => [ [ 'www.google.de', 'a', 'in' ] ],
605	'rc' => 0,	572	'rc' => 0,
606	'ar' => [	573	'ar' => [
607	[ 'a.l.google.com', 'a', 'in', '209.85.139.9' ],	574	[ 'a.l.google.com', 'a', 'in', '209.85.139.9' ],
608	[ 'b.l.google.com', 'a', 'in', '64.233.179.9' ],	575	[ 'b.l.google.com', 'a', 'in', '64.233.179.9' ],
609	[ 'c.l.google.com', 'a', 'in', '64.233.161.9' ],	576	[ 'c.l.google.com', 'a', 'in', '64.233.161.9' ],
610	],	577	],
611	'ns' => [	578	'ns' => [
612	[ 'l.google.com', 'ns', 'in', 'a.l.google.com' ],	579	[ 'l.google.com', 'ns', 'in', 'a.l.google.com' ],
613	[ 'l.google.com', 'ns', 'in', 'b.l.google.com' ],	580	[ 'l.google.com', 'ns', 'in', 'b.l.google.com' ],
614	],	581	],
615	'tc' => '',	582	'tc' => '',
616	'ra' => 1,	583	'ra' => 1,
617	'qr' => 1,	584	'qr' => 1,
618	'id' => 64265,	585	'id' => 64265,
619	'aa' => '',	586	'aa' => '',
620	'an' => [	587	'an' => [
621	[ 'www.google.de', 'cname', 'in', 'www.google.com' ],	588	[ 'www.google.de', 'cname', 'in', 'www.google.com' ],
622	[ 'www.google.com', 'cname', 'in', 'www.l.google.com' ],	589	[ 'www.google.com', 'cname', 'in', 'www.l.google.com' ],
623	[ 'www.l.google.com', 'a', 'in', '66.249.93.104' ],	590	[ 'www.l.google.com', 'a', 'in', '66.249.93.104' ],
624	[ 'www.l.google.com', 'a', 'in', '66.249.93.147' ],	591	[ 'www.l.google.com', 'a', 'in', '66.249.93.147' ],
625	],	592	],
626	'rd' => 1,	593	'rd' => 1,
627	'op' => 0	594	'op' => 0
628	}	595	}
629		596
630	=cut	597	=cut
631		598
632	sub dns_unpack($) {	599	sub dns_unpack($) {
633	local $pkt = shift;	600	local $pkt = shift;
…		…
688		655
689	our $RESOLVER;	656	our $RESOLVER;
690		657
691	sub resolver() {	658	sub resolver() {
692	$RESOLVER \|\| do {	659	$RESOLVER \|\| do {
693	$RESOLVER = new AnyEvent::DNS;	660	$RESOLVER = new AnyEvent::DNS untaint => 1;
694	$RESOLVER->os_config;	661	$RESOLVER->os_config;
695	$RESOLVER	662	$RESOLVER
696	}	663	}
697	}	664	}
698		665
…		…
704		671
705	=over 4	672	=over 4
706		673
707	=item server => [...]	674	=item server => [...]
708		675
709	A list of server addresses (default: C<v127.0.0.1>) in network format (4	676	A list of server addresses (default: C<v127.0.0.1>) in network format
710	octets for IPv4, 16 octets for IPv6 - not yet supported).	677	(i.e. as returned by C<AnyEvent::Socket::parse_address> - both IPv4 and
		678	IPv6 are supported).
711		679
712	=item timeout => [...]	680	=item timeout => [...]
713		681
714	A list of timeouts to use (also determines the number of retries). To make	682	A list of timeouts to use (also determines the number of retries). To make
715	three retries with individual time-outs of 2, 5 and 5 seconds, use C<[2,	683	three retries with individual time-outs of 2, 5 and 5 seconds, use C<[2,
…		…
724	The number of dots (default: C<1>) that a name must have so that the resolver	692	The number of dots (default: C<1>) that a name must have so that the resolver
725	tries to resolve the name without any suffixes first.	693	tries to resolve the name without any suffixes first.
726		694
727	=item max_outstanding => $integer	695	=item max_outstanding => $integer
728		696
729	Most name servers do not handle many parallel requests very well. This option	697	Most name servers do not handle many parallel requests very well. This
730	limits the number of outstanding requests to C<$n> (default: C<10>), that means	698	option limits the number of outstanding requests to C<$integer>
731	if you request more than this many requests, then the additional requests will be queued	699	(default: C<10>), that means if you request more than this many requests,
732	until some other requests have been resolved.	700	then the additional requests will be queued until some other requests have
		701	been resolved.
733		702
734	=item reuse => $seconds	703	=item reuse => $seconds
735		704
736	The number of seconds (default: C<300>) that a query id cannot be re-used	705	The number of seconds (default: C<300>) that a query id cannot be re-used
737	after a timeout. If there as no time-out then query id's can be reused	706	after a timeout. If there was no time-out then query ids can be reused
738	immediately.	707	immediately.
		708
		709	=item untaint => $boolean
		710
		711	When true, then the resolver will automatically untaint results, and might
		712	also ignore certain environment variables.
739		713
740	=back	714	=back
741		715
742	=cut	716	=cut
743		717
744	sub new {	718	sub new {
745	my ($class, %arg) = @_;	719	my ($class, %arg) = @_;
746
747	socket my $fh, AF_INET, &Socket::SOCK_DGRAM, 0
748	or Carp::croak "socket: $!";
749
750	AnyEvent::Util::fh_nonblocking $fh, 1;
751		720
752	my $self = bless {	721	my $self = bless {
753	server => [],	722	server => [],
754	timeout => [2, 5, 5],	723	timeout => [2, 5, 5],
755	search => [],	724	search => [],
756	ndots => 1,	725	ndots => 1,
757	max_outstanding => 10,	726	max_outstanding => 10,
758	reuse => 300, # reuse id's after 5 minutes only, if possible	727	reuse => 300,
759	%arg,	728	%arg,
760	fh => $fh,
761	reuse_q => [],	729	reuse_q => [],
762	}, $class;	730	}, $class;
763		731
764	# search should default to gethostname's domain	732	# search should default to gethostname's domain
765	# but perl lacks a good posix module	733	# but perl lacks a good posix module
766		734
		735	# try to create an ipv4 and an ipv6 socket
		736	# only fail when we cannot create either
		737	my $got_socket;
		738
767	Scalar::Util::weaken (my $wself = $self);	739	Scalar::Util::weaken (my $wself = $self);
		740
		741	if (socket my $fh4, AF_INET , &Socket::SOCK_DGRAM, 0) {
		742	++$got_socket;
		743
		744	AnyEvent::Util::fh_nonblocking $fh4, 1;
		745	$self->{fh4} = $fh4;
768	$self->{rw} = AnyEvent->io (fh => $fh, poll => "r", cb => sub { $wself->_recv });	746	$self->{rw4} = AnyEvent->io (fh => $fh4, poll => "r", cb => sub {
		747	if (my $peer = recv $fh4, my $pkt, MAX_PKT, 0) {
		748	$wself->_recv ($pkt, $peer);
		749	}
		750	});
		751	}
		752
		753	if (AF_INET6 && socket my $fh6, AF_INET6, &Socket::SOCK_DGRAM, 0) {
		754	++$got_socket;
		755
		756	$self->{fh6} = $fh6;
		757	AnyEvent::Util::fh_nonblocking $fh6, 1;
		758	$self->{rw6} = AnyEvent->io (fh => $fh6, poll => "r", cb => sub {
		759	if (my $peer = recv $fh6, my $pkt, MAX_PKT, 0) {
		760	$wself->_recv ($pkt, $peer);
		761	}
		762	});
		763	}
		764
		765	$got_socket
		766	or Carp::croak "unable to create either an IPv4 or an IPv6 socket";
769		767
770	$self->_compile;	768	$self->_compile;
771		769
772	$self	770	$self
773	}	771	}
…		…
795	for (split /\n/, $resolvconf) {	793	for (split /\n/, $resolvconf) {
796	if (/^\s*#/) {	794	if (/^\s*#/) {
797	# comment	795	# comment
798	} elsif (/^\snameserver\s+(\S+)\s$/i) {	796	} elsif (/^\snameserver\s+(\S+)\s$/i) {
799	my $ip = $1;	797	my $ip = $1;
800	if (my $ipn = AnyEvent::Socket::parse_ip ($ip)) {	798	if (my $ipn = AnyEvent::Socket::parse_address ($ip)) {
801	push @{ $self->{server} }, $ipn;	799	push @{ $self->{server} }, $ipn;
802	} else {	800	} else {
803	warn "nameserver $ip invalid and ignored\n";	801	warn "nameserver $ip invalid and ignored\n";
804	}	802	}
805	} elsif (/^\sdomain\s+(\S)\s+$/i) {	803	} elsif (/^\sdomain\s+(\S)\s+$/i) {
…		…
829	$self->_compile;	827	$self->_compile;
830	}	828	}
831		829
832	=item $resolver->os_config	830	=item $resolver->os_config
833		831
834	Tries so load and parse F</etc/resolv.conf> on portable operating systems. Tries various	832	Tries so load and parse F</etc/resolv.conf> on portable operating
835	egregious hacks on windows to force the DNS servers and searchlist out of the system.	833	systems. Tries various egregious hacks on windows to force the DNS servers
		834	and searchlist out of the system.
836		835
837	=cut	836	=cut
838		837
839	sub os_config {	838	sub os_config {
840	my ($self) = @_;	839	my ($self) = @_;
841		840
842	$self->{server} = [];	841	$self->{server} = [];
843	$self->{search} = [];	842	$self->{search} = [];
844		843
845	if (WIN32 \|\| $^O =~ /cygwin/i) {	844	if (AnyEvent::WIN32 \|\| $^O =~ /cygwin/i) {
846	no strict 'refs';	845	no strict 'refs';
847		846
848	# there are many options to find the current nameservers etc. on windows	847	# there are many options to find the current nameservers etc. on windows
849	# all of them don't work consistently:	848	# all of them don't work consistently:
850	# - the registry thing needs separate code on win32 native vs. cygwin	849	# - the registry thing needs separate code on win32 native vs. cygwin
851	# - the registry layout differs between windows versions	850	# - the registry layout differs between windows versions
852	# - calling windows api functions doesn't work on cygwin	851	# - calling windows api functions doesn't work on cygwin
853	# - ipconfig uses locale-specific messages	852	# - ipconfig uses locale-specific messages
854		853
855	# we use ipconfig parsing because, despite all it's brokenness,	854	# we use ipconfig parsing because, despite all its brokenness,
856	# it seems most stable in practise.	855	# it seems most stable in practise.
857	# for good measure, we append a fallback nameserver to our list.	856	# for good measure, we append a fallback nameserver to our list.
858		857
859	if (open my $fh, "ipconfig /all \|") {	858	if (open my $fh, "ipconfig /all \|") {
860	# parsing strategy: we go through the output and look for	859	# parsing strategy: we go through the output and look for
…		…
869	} elsif (/^\S/ \|\| /^\s[^:]{16,}: /) {	868	} elsif (/^\S/ \|\| /^\s[^:]{16,}: /) {
870	$dns = 0;	869	$dns = 0;
871	}	870	}
872	if ($dns && /^\s(\S+)\s$/) {	871	if ($dns && /^\s(\S+)\s$/) {
873	my $s = $1;	872	my $s = $1;
874	$s =~ s/%\d+(?!\S)//; # get rid of scope id	873	$s =~ s/%\d+(?!\S)//; # get rid of ipv6 scope id
875	if (my $ipn = AnyEvent::Socket::parse_ip ($s)) {	874	if (my $ipn = AnyEvent::Socket::parse_address ($s)) {
876	push @{ $self->{server} }, $ipn;	875	push @{ $self->{server} }, $ipn;
877	} else {	876	} else {
878	push @{ $self->{search} }, $s;	877	push @{ $self->{search} }, $s;
879	}	878	}
880	}	879	}
…		…
893	$self->parse_resolv_conf (<$fh>);	892	$self->parse_resolv_conf (<$fh>);
894	}	893	}
895	}	894	}
896	}	895	}
897		896
		897	=item $resolver->timeout ($timeout, ...)
		898
		899	Sets the timeout values. See the C<timeout> constructor argument (and note
		900	that this method uses the values itself, not an array-reference).
		901
		902	=cut
		903
		904	sub timeout {
		905	my ($self, @timeout) = @_;
		906
		907	$self->{timeout} = \@timeout;
		908	$self->_compile;
		909	}
		910
		911	=item $resolver->max_outstanding ($nrequests)
		912
		913	Sets the maximum number of outstanding requests to C<$nrequests>. See the
		914	C<max_outstanding> constructor argument.
		915
		916	=cut
		917
		918	sub max_outstanding {
		919	my ($self, $max) = @_;
		920
		921	$self->{max_outstanding} = $max;
		922	$self->_scheduler;
		923	}
		924
898	sub _compile {	925	sub _compile {
899	my $self = shift;	926	my $self = shift;
900		927
901	# we currently throw away all ipv6 nameservers, we do not yet support those
902
903	my %search; $self->{search} = [grep 0 < length, grep !$search{$_}++, @{ $self->{search} }];	928	my %search; $self->{search} = [grep 0 < length, grep !$search{$_}++, @{ $self->{search} }];
904	my %server; $self->{server} = [grep 4 == length, grep !$server{$_}++, @{ $self->{server} }];	929	my %server; $self->{server} = [grep 0 < length, grep !$server{$_}++, @{ $self->{server} }];
905		930
906	unless (@{ $self->{server} }) {	931	unless (@{ $self->{server} }) {
907	# use 127.0.0.1 by default, and one opendns nameserver as fallback	932	# use 127.0.0.1 by default, and one opendns nameserver as fallback
908	$self->{server} = [v127.0.0.1, $DNS_FALLBACK[rand @DNS_FALLBACK]];	933	$self->{server} = [v127.0.0.1, $DNS_FALLBACK[rand @DNS_FALLBACK]];
909	}	934	}
…		…
920	}	945	}
921		946
922	sub _feed {	947	sub _feed {
923	my ($self, $res) = @_;	948	my ($self, $res) = @_;
924		949
		950	($res) = $res =~ /^(.*)$/s
		951	if AnyEvent::TAINT && $self->{untaint};
		952
925	$res = dns_unpack $res	953	$res = dns_unpack $res
926	or return;	954	or return;
927		955
928	my $id = $self->{id}{$res->{id}};	956	my $id = $self->{id}{$res->{id}};
929		957
…		…
932	$NOW = time;	960	$NOW = time;
933	$id->[1]->($res);	961	$id->[1]->($res);
934	}	962	}
935		963
936	sub _recv {	964	sub _recv {
937	my ($self) = @_;	965	my ($self, $pkt, $peer) = @_;
938		966
939	# we ignore errors (often one gets port unreachable, but there is	967	# we ignore errors (often one gets port unreachable, but there is
940	# no good way to take advantage of that.	968	# no good way to take advantage of that.
941	while (my $peer = recv $self->{fh}, my $res, 4096, 0) {	969
942	my ($port, $host) = AnyEvent::Socket::unpack_sockaddr ($peer);	970	my ($port, $host) = AnyEvent::Socket::unpack_sockaddr ($peer);
943		971
944	return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };	972	return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };
945		973
946	$self->_feed ($res);	974	$self->_feed ($pkt);
947	}
948	}	975	}
949		976
950	sub _free_id {	977	sub _free_id {
951	my ($self, $id, $timeout) = @_;	978	my ($self, $id, $timeout) = @_;
952		979
…		…
982		1009
983	$self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {	1010	$self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {
984	$NOW = time;	1011	$NOW = time;
985		1012
986	# timeout, try next	1013	# timeout, try next
987	&$do_retry;	1014	&$do_retry if $do_retry;
988	}), sub {	1015	}), sub {
989	my ($res) = @_;	1016	my ($res) = @_;
990		1017
991	if ($res->{tc}) {	1018	if ($res->{tc}) {
992	# success, but truncated, so use tcp	1019	# success, but truncated, so use tcp
993	AnyEvent::Socket::tcp_connect ((Socket::inet_ntoa $server), 53, sub {	1020	AnyEvent::Socket::tcp_connect (AnyEvent::Socket::format_address ($server), DOMAIN_PORT, sub {
		1021	return unless $do_retry; # some other request could have invalidated us already
		1022
994	my ($fh) = @_	1023	my ($fh) = @_
995	or return &$do_retry;	1024	or return &$do_retry;
996		1025
997	my $handle = new AnyEvent::Handle	1026	my $handle; $handle = new AnyEvent::Handle
998	fh => $fh,	1027	fh => $fh,
		1028	timeout => $timeout,
999	on_error => sub {	1029	on_error => sub {
		1030	undef $handle;
		1031	return unless $do_retry; # some other request could have invalidated us already
1000	# failure, try next	1032	# failure, try next
1001	&$do_retry;	1033	&$do_retry;
1002	};	1034	};
1003		1035
1004	$handle->push_write (pack "n/a", $req->[0]);	1036	$handle->push_write (pack "n/a", $req->[0]);
1005	$handle->push_read (chunk => 2, sub {	1037	$handle->push_read (chunk => 2, sub {
1006	$handle->unshift_read (chunk => (unpack "n", $_[1]), sub {	1038	$handle->unshift_read (chunk => (unpack "n", $_[1]), sub {
		1039	undef $handle;
1007	$self->_feed ($_[1]);	1040	$self->_feed ($_[1]);
1008	});	1041	});
1009	});	1042	});
1010	shutdown $fh, 1;
1011		1043
1012	}, sub { $timeout });	1044	}, sub { $timeout });
1013		1045
1014	} else {	1046	} else {
1015	# success	1047	# success
1016	$self->_free_id ($req->[2], $retry > 1);	1048	$self->_free_id ($req->[2], $retry > 1);
1017	undef $do_retry; return $req->[1]->($res);	1049	undef $do_retry; return $req->[1]->($res);
1018	}	1050	}
1019	}];	1051	}];
		1052
		1053	my $sa = AnyEvent::Socket::pack_sockaddr (DOMAIN_PORT, $server);
1020		1054
1021	send $self->{fh}, $req->[0], 0, AnyEvent::Socket::pack_sockaddr (53, $server);	1055	my $fh = AF_INET == Socket::sockaddr_family ($sa)
		1056	? $self->{fh4} : $self->{fh6}
		1057	or return &$do_retry;
		1058
		1059	send $fh, $req->[0], 0, $sa;
1022	};	1060	};
1023		1061
1024	&$do_retry;	1062	&$do_retry;
1025	}	1063	}
1026		1064
1027	sub _scheduler {	1065	sub _scheduler {
1028	my ($self) = @_;	1066	my ($self) = @_;
		1067
		1068	no strict 'refs';
1029		1069
1030	$NOW = time;	1070	$NOW = time;
1031		1071
1032	# first clear id reuse queue	1072	# first clear id reuse queue
1033	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }	1073	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }
…		…
1042	$self->_scheduler;	1082	$self->_scheduler;
1043	});	1083	});
1044	last;	1084	last;
1045	}	1085	}
1046		1086
1047	my $req = shift @{ $self->{queue} }	1087	if (my $req = shift @{ $self->{queue} }) {
1048	or last;	1088	# found a request in the queue, execute it
1049
1050	while () {	1089	while () {
1051	$req->[2] = int rand 65536;	1090	$req->[2] = int rand 65536;
1052	last unless exists $self->{id}{$req->[2]};	1091	last unless exists $self->{id}{$req->[2]};
		1092	}
		1093
		1094	++$self->{outstanding};
		1095	$self->{id}{$req->[2]} = 1;
		1096	substr $req->[0], 0, 2, pack "n", $req->[2];
		1097
		1098	$self->_exec ($req);
		1099
		1100	} elsif (my $cb = shift @{ $self->{wait} }) {
		1101	# found a wait_for_slot callback, call that one first
		1102	$cb->($self);
		1103
		1104	} else {
		1105	# nothing to do, just exit
		1106	last;
1053	}	1107	}
1054
1055	++$self->{outstanding};
1056	$self->{id}{$req->[2]} = 1;
1057	substr $req->[0], 0, 2, pack "n", $req->[2];
1058
1059	$self->_exec ($req);
1060	}	1108	}
1061	}	1109	}
1062		1110
1063	=item $resolver->request ($req, $cb->($res))	1111	=item $resolver->request ($req, $cb->($res))
1064		1112
		1113	This is the main low-level workhorse for sending DNS requests.
		1114
1065	Sends a single request (a hash-ref formated as specified for	1115	This function sends a single request (a hash-ref formated as specified
1066	C<dns_pack>) to the configured nameservers including	1116	for C<dns_pack>) to the configured nameservers in turn until it gets a
		1117	response. It handles timeouts, retries and automatically falls back to
		1118	virtual circuit mode (TCP) when it receives a truncated reply.
		1119
1067	retries. Calls the callback with the decoded response packet if a reply	1120	Calls the callback with the decoded response packet if a reply was
1068	was received, or no arguments on timeout.	1121	received, or no arguments in case none of the servers answered.
1069		1122
1070	=cut	1123	=cut
1071		1124
1072	sub request($$) {	1125	sub request($$) {
1073	my ($self, $req, $cb) = @_;	1126	my ($self, $req, $cb) = @_;
1074		1127
1075	push @{ $self->{queue} }, [dns_pack $req, $cb];	1128	push @{ $self->{queue} }, [dns_pack $req, $cb];
1076	$self->_scheduler;	1129	$self->_scheduler;
1077	}	1130	}
1078		1131
1079	=item $resolver->resolve ($qname, $qtype, %options, $cb->($rcode, @rr))	1132	=item $resolver->resolve ($qname, $qtype, %options, $cb->(@rr))
1080		1133
1081	Queries the DNS for the given domain name C<$qname> of type C<$qtype> (a	1134	Queries the DNS for the given domain name C<$qname> of type C<$qtype>.
1082	qtype of "*" is supported and means "any").	1135
		1136	A C<$qtype> is either a numerical query type (e.g. C<1> for A records) or
		1137	a lowercase name (you have to look at the source to see which aliases are
		1138	supported, but all types from RFC 1035, C<aaaa>, C<srv>, C<spf> and a few
		1139	more are known to this module). A C<$qtype> of "*" is supported and means
		1140	"any" record type.
1083		1141
1084	The callback will be invoked with a list of matching result records or	1142	The callback will be invoked with a list of matching result records or
1085	none on any error or if the name could not be found.	1143	none on any error or if the name could not be found.
1086		1144
1087	CNAME chains (although illegal) are followed up to a length of 8.	1145	CNAME chains (although illegal) are followed up to a length of 10.
		1146
		1147	The callback will be invoked with arraryefs of the form C<[$name, $type,
		1148	$class, @data>], where C<$name> is the domain name, C<$type> a type string
		1149	or number, C<$class> a class name and @data is resource-record-dependent
		1150	data. For C<a> records, this will be the textual IPv4 addresses, for C<ns>
		1151	or C<cname> records this will be a domain name, for C<txt> records these
		1152	are all the strings and so on.
		1153
		1154	All types mentioned in RFC 1035, C<aaaa>, C<srv>, C<naptr> and C<spf> are
		1155	decoded. All resource records not known to this module will have
		1156	the raw C<rdata> field as fourth entry.
1088		1157
1089	Note that this resolver is just a stub resolver: it requires a name server	1158	Note that this resolver is just a stub resolver: it requires a name server
1090	supporting recursive queries, will not do any recursive queries itself and	1159	supporting recursive queries, will not do any recursive queries itself and
1091	is not secure when used against an untrusted name server.	1160	is not secure when used against an untrusted name server.
1092		1161
…		…
1096		1165
1097	=item search => [$suffix...]	1166	=item search => [$suffix...]
1098		1167
1099	Use the given search list (which might be empty), by appending each one	1168	Use the given search list (which might be empty), by appending each one
1100	in turn to the C<$qname>. If this option is missing then the configured	1169	in turn to the C<$qname>. If this option is missing then the configured
1101	C<ndots> and C<search> define its value. If the C<$qname> ends in a dot,	1170	C<ndots> and C<search> values define its value (depending on C<ndots>, the
1102	then the searchlist will be ignored.	1171	empty suffix will be prepended or appended to that C<search> value). If
		1172	the C<$qname> ends in a dot, then the searchlist will be ignored.
1103		1173
1104	=item accept => [$type...]	1174	=item accept => [$type...]
1105		1175
1106	Lists the acceptable result types: only result types in this set will be	1176	Lists the acceptable result types: only result types in this set will be
1107	accepted and returned. The default includes the C<$qtype> and nothing	1177	accepted and returned. The default includes the C<$qtype> and nothing
1108	else.	1178	else. If this list includes C<cname>, then CNAME-chains will not be
		1179	followed (because you asked for the CNAME record).
1109		1180
1110	=item class => "class"	1181	=item class => "class"
1111		1182
1112	Specify the query class ("in" for internet, "ch" for chaosnet and "hs" for	1183	Specify the query class ("in" for internet, "ch" for chaosnet and "hs" for
1113	hesiod are the only ones making sense). The default is "in", of course.	1184	hesiod are the only ones making sense). The default is "in", of course.
1114		1185
1115	=back	1186	=back
1116		1187
1117	Examples:	1188	Examples:
1118		1189
1119	$res->resolve ("ruth.plan9.de", "a", sub {	1190	# full example, you can paste this into perl:
1120	warn Dumper [@_];	1191	use Data::Dumper;
1121	});	1192	use AnyEvent::DNS;
		1193	AnyEvent::DNS::resolver->resolve (
		1194	"google.com", "*", my $cv = AnyEvent->condvar);
		1195	warn Dumper [$cv->recv];
1122		1196
		1197	# shortened result:
1123	[	1198	# [
		1199	# [ 'google.com', 'soa', 'in', 'ns1.google.com', 'dns-admin.google.com',
		1200	# 2008052701, 7200, 1800, 1209600, 300 ],
1124	[	1201	# [
1125	'ruth.schmorp.de',	1202	# 'google.com', 'txt', 'in',
1126	'a',	1203	# 'v=spf1 include:_netblocks.google.com ~all'
1127	'in',	1204	# ],
1128	'129.13.162.95'	1205	# [ 'google.com', 'a', 'in', '64.233.187.99' ],
		1206	# [ 'google.com', 'mx', 'in', 10, 'smtp2.google.com' ],
		1207	# [ 'google.com', 'ns', 'in', 'ns2.google.com' ],
1129	]	1208	# ]
		1209
		1210	# resolve a records:
		1211	$res->resolve ("ruth.plan9.de", "a", sub { warn Dumper [@_] });
		1212
		1213	# result:
		1214	# [
		1215	# [ 'ruth.schmorp.de', 'a', 'in', '129.13.162.95' ]
1130	]	1216	# ]
1131		1217
		1218	# resolve any records, but return only a and aaaa records:
1132	$res->resolve ("test1.laendle", "*",	1219	$res->resolve ("test1.laendle", "*",
1133	accept => ["a", "aaaa"],	1220	accept => ["a", "aaaa"],
1134	sub {	1221	sub {
1135	warn Dumper [@_];	1222	warn Dumper [@_];
1136	}	1223	}
1137	);	1224	);
1138		1225
1139	[	1226	# result:
1140	[	1227	# [
1141	'test1.laendle',	1228	# [ 'test1.laendle', 'a', 'in', '10.0.0.255' ],
1142	'a',	1229	# [ 'test1.laendle', 'aaaa', 'in', '3ffe:1900:4545:0002:0240:0000:0000:f7e1' ]
1143	'in',
1144	'10.0.0.255'
1145	],
1146	[
1147	'test1.laendle',
1148	'aaaa',
1149	'in',
1150	'3ffe:1900:4545:0002:0240:0000:0000:f7e1'
1151	]	1230	# ]
1152	]
1153		1231
1154	=cut	1232	=cut
1155		1233
1156	sub resolve($%) {	1234	sub resolve($%) {
1157	my $cb = pop;	1235	my $cb = pop;
…		…
1177	$do_search = sub {	1255	$do_search = sub {
1178	@search	1256	@search
1179	or (undef $do_search), (undef $do_req), return $cb->();	1257	or (undef $do_search), (undef $do_req), return $cb->();
1180		1258
1181	(my $name = lc "$qname." . shift @search) =~ s/\.$//;	1259	(my $name = lc "$qname." . shift @search) =~ s/\.$//;
1182	my $depth = 2;	1260	my $depth = 10;
1183		1261
1184	# advance in cname-chain	1262	# advance in cname-chain
1185	$do_req = sub {	1263	$do_req = sub {
1186	$self->request ({	1264	$self->request ({
1187	rd => 1,	1265	rd => 1,
…		…
1225	};	1303	};
1226		1304
1227	$do_search->();	1305	$do_search->();
1228	}	1306	}
1229		1307
		1308	=item $resolver->wait_for_slot ($cb->($resolver))
		1309
		1310	Wait until a free request slot is available and call the callback with the
		1311	resolver object.
		1312
		1313	A request slot is used each time a request is actually sent to the
		1314	nameservers: There are never more than C<max_outstanding> of them.
		1315
		1316	Although you can submit more requests (they will simply be queued until
		1317	a request slot becomes available), sometimes, usually for rate-limiting
		1318	purposes, it is useful to instead wait for a slot before generating the
		1319	request (or simply to know when the request load is low enough so one can
		1320	submit requests again).
		1321
		1322	This is what this method does: The callback will be called when submitting
		1323	a DNS request will not result in that request being queued. The callback
		1324	may or may not generate any requests in response.
		1325
		1326	Note that the callback will only be invoked when the request queue is
		1327	empty, so this does not play well if somebody else keeps the request queue
		1328	full at all times.
		1329
		1330	=cut
		1331
		1332	sub wait_for_slot {
		1333	my ($self, $cb) = @_;
		1334
		1335	push @{ $self->{wait} }, $cb;
		1336	$self->_scheduler;
		1337	}
		1338
1230	use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end	1339	use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end
1231		1340
1232	1;	1341	1;
1233		1342
1234	=back	1343	=back
1235		1344
1236	=head1 AUTHOR	1345	=head1 AUTHOR
1237		1346
1238	Marc Lehmann <schmorp@schmorp.de>	1347	Marc Lehmann <schmorp@schmorp.de>
1239	http://home.schmorp.de/	1348	http://home.schmorp.de/
1240		1349
1241	=cut	1350	=cut
1242		1351

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.34 by root, Mon May 26 05:46:35 2008 UTC vs. Revision 1.96 by root, Mon Jun 29 21:00:32 2009 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.34 by root, Mon May 26 05:46:35 2008 UTC vs.
Revision 1.96 by root, Mon Jun 29 21:00:32 2009 UTC