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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.19 by root, Fri May 23 23:37:13 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
		9	my $cv = AnyEvent->condvar;
		10	AnyEvent::DNS::a "www.google.de", $cv;
		11	# ... later
		12	my @addrs = $cv->recv;
8		13
9	=head1 DESCRIPTION	14	=head1 DESCRIPTION
10		15
11	This module offers both a number of DNS convenience functions as well	16	This module offers both a number of DNS convenience functions as well
12	as a fully asynchronous and high-performance pure-perl stub resolver.	17	as a fully asynchronous and high-performance pure-perl stub resolver.
13		18
14	The stub resolver supports DNS over UDP, optional EDNS0 support for up to	19	The stub resolver supports DNS over IPv4 and IPv6, UDP and TCP, optional
15	4kiB datagrams and automatically falls back to virtual circuit mode for	20	EDNS0 support for up to 4kiB datagrams and automatically falls back to
16	large responses.	21	virtual circuit mode for large responses.
17		22
18	=head2 CONVENIENCE FUNCTIONS	23	=head2 CONVENIENCE FUNCTIONS
19		24
20	=over 4	25	=over 4
21		26
…		…
24	package AnyEvent::DNS;	29	package AnyEvent::DNS;
25		30
26	no warnings;	31	no warnings;
27	use strict;	32	use strict;
28		33
		34	use Socket qw(AF_INET SOCK_DGRAM SOCK_STREAM);
		35
		36	use AnyEvent ();
29	use AnyEvent::Handle ();	37	use AnyEvent::Handle ();
		38	use AnyEvent::Util qw(AF_INET6);
30		39
31	=item AnyEvent::DNS::addr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...)	40	our $VERSION = 4.45;
32		41
33	NOT YET IMPLEMENTED	42	our @DNS_FALLBACK = (v208.67.220.220, v208.67.222.222);
34
35	Tries to resolve the given nodename and service name into protocol families
36	and sockaddr structures usable to connect to this node and service in a
37	protocol-independent way. It works remotely similar to the getaddrinfo
38	posix function.
39
40	C<$node> is either an IPv4 or IPv6 address or a hostname, C<$service> is
41	either a service name (port name from F</etc/services>) or a numerical
42	port number. If both C<$node> and C<$service> are names, then SRV records
43	will be consulted to find the real service, otherwise they will be
44	used as-is. If you know that the service name is not in your services
45	database, then you cna specify the service in the format C<name=port>
46	(e.g. C<http=80>).
47
48	C<$proto> must be a protocol name, currently C<tcp>, C<udp> or
49	C<sctp>. The default is C<tcp>.
50
51	C<$family> must be either C<0> (meaning any protocol is ok), C<4> (use
52	only IPv4) or C<6> (use only IPv6).
53
54	C<$type> must be C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_SEQPACKET> (or
55	C<undef> in which case it gets automatically chosen).
56
57	The callback will receive zero or more array references that contain
58	C<$family, $type, $proto> for use in C<socket> and a binary
59	C<$sockaddr> for use in C<connect> (or C<bind>).
60
61	The application should try these in the order given.
62
63	Example:
64
65	AnyEvent::DNS::addr "google.com", "http", 0, undef, undef, sub { ... };
66		43
67	=item AnyEvent::DNS::a $domain, $cb->(@addrs)	44	=item AnyEvent::DNS::a $domain, $cb->(@addrs)
68		45
69	Tries to resolve the given domain to IPv4 address(es).	46	Tries to resolve the given domain to IPv4 address(es).
70		47
…		…
88	=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)	65	=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)
89		66
90	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
91	of service records.	68	of service records.
92		69
93	Each srv_rr is an arrayref with the following contents:	70	Each C<$srv_rr> is an array reference with the following contents:
94	C<[$priority, $weight, $transport, $target]>.	71	C<[$priority, $weight, $transport, $target]>.
95		72
96	They will be sorted with lowest priority, highest weight first (TODO:	73	They will be sorted with lowest priority first, then randomly
97	should use the rfc algorithm to reorder same-priority records for weight).	74	distributed by weight as per RFC 2782.
98		75
99	Example:	76	Example:
100		77
101	AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...	78	AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...
102	# @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )	79	# @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )
103		80
104	=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)
105		93
106	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)
107	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.
108		108
109	Example:	109	Example:
110		110
111	AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };	111	AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };
112	# => f.root-servers.net	112	# => f.root-servers.net
113		113
114	=item AnyEvent::DNS::any $domain, $cb->(@rrs)
115
116	Tries to resolve the given domain and passes all resource records found to
117	the callback.
118
119	=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
120		119
121	sub resolver;	120	sub resolver;
122		121
123	sub a($$) {	122	sub a($$) {
124	my ($domain, $cb) = @_;	123	my ($domain, $cb) = @_;
…		…
163	sub srv($$$$) {	162	sub srv($$$$) {
164	my ($service, $proto, $domain, $cb) = @_;	163	my ($service, $proto, $domain, $cb) = @_;
165		164
166	# todo, ask for any and check glue records	165	# todo, ask for any and check glue records
167	resolver->resolve ("_$service._$proto.$domain" => "srv", sub {	166	resolver->resolve ("_$service._$proto.$domain" => "srv", sub {
168	$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);
169	});	194	});
170	}	195	}
171		196
172	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($$) {
173	my ($ip, $cb) = @_;	239	my ($ip, $cb) = @_;
174		240
175	$ip = AnyEvent::Socket::parse_ip ($ip)	241	$ip = _munge_ptr AnyEvent::Socket::parse_address ($ip)
176	or return $cb->();	242	or return $cb->();
177
178	if (4 == length $ip) {
179	$ip = join ".", (reverse split /\./, $ip), "in-addr.arpa.";
180	} else {
181	$ip = join ".", (reverse split //, unpack "H*", $ip), "ip6.arpa.";
182	}
183		243
184	resolver->resolve ($ip => "ptr", sub {	244	resolver->resolve ($ip => "ptr", sub {
185	$cb->(map $_->[3], @_);	245	$cb->(map $_->[3], @_);
186	});	246	});
187	}	247	}
188		248
189	sub any($$) {	249	sub reverse_verify($$) {
190	my ($domain, $cb) = @_;	250	my ($ip, $cb) = @_;
191		251
192	resolver->resolve ($domain => "*", $cb);	252	my $ipn = AnyEvent::Socket::parse_address ($ip)
193	}
194
195	#############################################################################
196
197	#AnyEvent::DNS::addr $node, $service, $family, $type, $proto, $cb->([$family, $type, $protocol, $sockaddr], ...)
198
199	# $port, $host
200	sub pack_sockaddr_in6($$) {
201	pack "nnN a16 N",
202	Socket::AF_INET6,
203	$_[0], # port
204	0, # flowinfo
205	$_[1], # addr
206	0 # scope id
207	}
208
209	sub addr($$$$$$) {
210	my ($node, $service, $proto, $family, $type, $cb) = @_;
211
212	unless (eval { &Socket::AF_INET6 }) {
213	$family != 6
214	or return $cb->();	253	or return $cb->();
215		254
216	$family \|\|= 4;	255	my $af = AnyEvent::Socket::address_family ($ipn);
217	}
218		256
219	$proto \|\|= "tcp";
220	$type \|\|= $proto eq "udp" ? Socket::SOCK_DGRAM : Socket::SOCK_STREAM;
221
222	my $proton = (getprotobyname $proto)[2]
223	or Carp::croak "$proto: protocol unknown";
224
225	my $port;
226
227	if ($service =~ /^(\S+)=(\d+)$/) {
228	($service, $port) = ($1, $2);
229	} elsif ($service =~ /^\d+$/) {
230	($service, $port) = (undef, $service);
231	} else {
232	$port = (getservbyname $service, $proto)[2]
233	or Carp::croak "$service/$proto: service unknown";
234	}
235
236	my @target = [$node, $port];
237
238	# resolve a records / provide sockaddr structures
239	my $resolve = sub {
240	my @res;	257	my @res;
241	my $cv = AnyEvent->condvar (cb => sub {	258	my $cnt;
242	$cb->(map $_->[1], sort { $a->[0] <=> $b->[0] } @res)
243	});
244		259
245	$cv->begin;	260	my $ptr = _munge_ptr $ipn
246	for my $idx (0 .. $#target) {	261	or return $cb->();
247	my ($node, $port) = @{ $target[$idx] };
248		262
249	if (my $noden = AnyEvent::Socket::parse_ip ($node)) {	263	$ip = AnyEvent::Socket::format_address ($ipn); # normalise into the same form
250	if (4 == length $noden && $family != 6) {	264
251	push @res, [$idx, [Socket::AF_INET, $type, $proton,	265	ptr $ptr, sub {
252	Socket::pack_sockaddr_in $port, $noden]]	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;
253	}	274	}
254		275	$cb->(@res) unless --$cnt;
255	if (16 == length $noden && $family != 4) {
256	push @res, [$idx, [Socket::AF_INET6, $type, $proton,
257	pack_sockaddr_in6 $port, $noden]]
258	}
259	} else {
260	# ipv4
261	if ($family != 6) {
262	$cv->begin;
263	a $node, sub {
264	push @res, [$idx, [Socket::AF_INET, $type, $proton,
265	Socket::pack_sockaddr_in $port, AnyEvent::Socket::parse_ipv4 ($_)]]
266	for @_;
267	$cv->end;
268	};
269	}
270
271	my $idx = $idx + 0.5; # prefer ipv4 for now
272
273	# ipv6
274	if ($family != 4) {
275	$cv->begin;
276	aaaa $node, sub {
277	push @res, [$idx, [Socket::AF_INET6, $type, $proton,
278	pack_sockaddr_in6 $port, AnyEvent::Socket::parse_ipv6 ($_)]]
279	for @_;
280	$cv->end;
281	};
282	}
283	}	276	});
284	}	277	}
285	$cv->end;	278
		279	$cb->() unless $cnt;
286	};	280	};
287
288	# try srv records, if applicable
289	if (defined $service && !AnyEvent::Socket::parse_ip ($node)) {
290	srv $service, $proto, $node, sub {
291	my (@srv) = @_;
292
293	# no srv records, continue traditionally
294	@srv
295	or return &$resolve;
296
297	# only srv record has "." => abort
298	$srv[0][2] ne "." \|\| $#srv
299	or return $cb->();
300
301	# use srv records then
302	@target = map [$_->[3], $_->[2]],
303	grep $_->[3] ne ".",
304	@srv;
305
306	&$resolve;
307	};
308	} else {
309	&$resolve;
310	}
311	}	281	}
312		282
313	#############################################################################	283	#################################################################################
314		284
315	=back	285	=back
316		286
317	=head2 LOW-LEVEL DNS EN-/DECODING FUNCTIONS	287	=head2 LOW-LEVEL DNS EN-/DECODING FUNCTIONS
318		288
319	=over 4	289	=over 4
320		290
321	=item $AnyEvent::DNS::EDNS0	291	=item $AnyEvent::DNS::EDNS0
322		292
323	This variable decides whether dns_pack automatically enables EDNS0	293	This variable decides whether dns_pack automatically enables EDNS0
324	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
325	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.
326		297
327	=cut	298	=cut
328		299
329	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
330		301
331	our %opcode_id = (	302	our %opcode_id = (
332	query => 0,	303	query => 0,
333	iquery => 1,	304	iquery => 1,
334	status => 2,	305	status => 2,
…		…
380	minfo => 14,	351	minfo => 14,
381	mx => 15,	352	mx => 15,
382	txt => 16,	353	txt => 16,
383	aaaa => 28,	354	aaaa => 28,
384	srv => 33,	355	srv => 33,
		356	naptr => 35, # rfc2915
		357	dname => 39, # rfc2672
385	opt => 41,	358	opt => 41,
386	spf => 99,	359	spf => 99,
387	tkey => 249,	360	tkey => 249,
388	tsig => 250,	361	tsig => 250,
389	ixfr => 251,	362	ixfr => 251,
…		…
402	"*" => 255,	375	"*" => 255,
403	);	376	);
404		377
405	our %class_str = reverse %class_id;	378	our %class_str = reverse %class_id;
406		379
407	# names MUST have a trailing dot
408	sub _enc_qname($) {	380	sub _enc_name($) {
409	pack "(C/a)*", (split /\./, shift), ""	381	pack "(C/a)", (split /\./, shift), ""
410	}	382	}
411		383
412	sub _enc_qd() {	384	sub _enc_qd() {
413	(_enc_qname $_->[0]) . pack "nn",	385	(_enc_name $_->[0]) . pack "nn",
414	($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}),	386	($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}),
415	($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] \|\| "in"})	387	($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] \|\| "in"})
416	}	388	}
417		389
418	sub _enc_rr() {	390	sub _enc_rr() {
419	die "encoding of resource records is not supported";	391	die "encoding of resource records is not supported";
420	}	392	}
421		393
422	=item $pkt = AnyEvent::DNS::dns_pack $dns	394	=item $pkt = AnyEvent::DNS::dns_pack $dns
423		395
424	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
425	recommended, then everything will be totally clear. Or maybe not.	397	recommended, then everything will be totally clear. Or maybe not.
426		398
427	Resource records are not yet encodable.	399	Resource records are not yet encodable.
428		400
429	Examples:	401	Examples:
430		402
431	# very simple request, using lots of default values:	403	# very simple request, using lots of default values:
432	{ rd => 1, qd => [ [ "host.domain", "a"] ] }	404	{ rd => 1, qd => [ [ "host.domain", "a"] ] }
433		405
434	# more complex example, showing how flags etc. are named:	406	# more complex example, showing how flags etc. are named:
435		407
436	{	408	{
437	id => 10000,	409	id => 10000,
438	op => "query",	410	op => "query",
439	rc => "nxdomain",	411	rc => "nxdomain",
440		412
441	# flags	413	# flags
442	qr => 1,	414	qr => 1,
443	aa => 0,	415	aa => 0,
444	tc => 0,	416	tc => 0,
445	rd => 0,	417	rd => 0,
446	ra => 0,	418	ra => 0,
447	ad => 0,	419	ad => 0,
448	cd => 0,	420	cd => 0,
449		421
450	qd => [@rr], # query section	422	qd => [@rr], # query section
451	an => [@rr], # answer section	423	an => [@rr], # answer section
452	ns => [@rr], # authority section	424	ns => [@rr], # authority section
453	ar => [@rr], # additional records section	425	ar => [@rr], # additional records section
454	}	426	}
455		427
456	=cut	428	=cut
457		429
458	sub dns_pack($) {	430	sub dns_pack($) {
459	my ($req) = @_;	431	my ($req) = @_;
…		…
472	+ $rcode_id{$req->{rc}} * 0x0001,	444	+ $rcode_id{$req->{rc}} * 0x0001,
473		445
474	scalar @{ $req->{qd} \|\| [] },	446	scalar @{ $req->{qd} \|\| [] },
475	scalar @{ $req->{an} \|\| [] },	447	scalar @{ $req->{an} \|\| [] },
476	scalar @{ $req->{ns} \|\| [] },	448	scalar @{ $req->{ns} \|\| [] },
477	$EDNS0 + scalar @{ $req->{ar} \|\| [] }, # include EDNS0 option here	449	$EDNS0 + scalar @{ $req->{ar} \|\| [] }, # EDNS0 option included here
478		450
479	(join "", map _enc_qd, @{ $req->{qd} \|\| [] }),	451	(join "", map _enc_qd, @{ $req->{qd} \|\| [] }),
480	(join "", map _enc_rr, @{ $req->{an} \|\| [] }),	452	(join "", map _enc_rr, @{ $req->{an} \|\| [] }),
481	(join "", map _enc_rr, @{ $req->{ns} \|\| [] }),	453	(join "", map _enc_rr, @{ $req->{ns} \|\| [] }),
482	(join "", map _enc_rr, @{ $req->{ar} \|\| [] }),	454	(join "", map _enc_rr, @{ $req->{ar} \|\| [] }),
483		455
484	($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
485	}	457	}
486		458
487	our $ofs;	459	our $ofs;
488	our $pkt;	460	our $pkt;
489		461
490	# bitches	462	# bitches
491	sub _dec_qname {	463	sub _dec_name {
492	my @res;	464	my @res;
493	my $redir;	465	my $redir;
494	my $ptr = $ofs;	466	my $ptr = $ofs;
495	my $cnt;	467	my $cnt;
496		468
497	while () {	469	while () {
498	return undef if ++$cnt >= 256; # to avoid DoS attacks	470	return undef if ++$cnt >= 256; # to avoid DoS attacks
499		471
500	my $len = ord substr $pkt, $ptr++, 1;	472	my $len = ord substr $pkt, $ptr++, 1;
501		473
502	if ($len & 0xc0) {	474	if ($len >= 0xc0) {
503	$ptr++;	475	$ptr++;
504	$ofs = $ptr if $ptr > $ofs;	476	$ofs = $ptr if $ptr > $ofs;
505	$ptr = (unpack "n", substr $pkt, $ptr - 2, 2) & 0x3fff;	477	$ptr = (unpack "n", substr $pkt, $ptr - 2, 2) & 0x3fff;
506	} elsif ($len) {	478	} elsif ($len) {
507	push @res, substr $pkt, $ptr, $len;	479	push @res, substr $pkt, $ptr, $len;
…		…
512	}	484	}
513	}	485	}
514	}	486	}
515		487
516	sub _dec_qd {	488	sub _dec_qd {
517	my $qname = _dec_qname;	489	my $qname = _dec_name;
518	my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;	490	my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;
519	[$qname, $type_str{$qt} \|\| $qt, $class_str{$qc} \|\| $qc]	491	[$qname, $type_str{$qt} \|\| $qt, $class_str{$qc} \|\| $qc]
520	}	492	}
521		493
522	our %dec_rr = (	494	our %dec_rr = (
523	1 => sub { join ".", unpack "C4" }, # a	495	1 => sub { join ".", unpack "C4", $_ }, # a
524	2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns	496	2 => sub { local $ofs = $ofs - length; _dec_name }, # ns
525	5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname	497	5 => sub { local $ofs = $ofs - length; _dec_name }, # cname
526	6 => sub {	498	6 => sub {
527	local $ofs = $ofs - length;	499	local $ofs = $ofs - length;
528	my $mname = _dec_qname;	500	my $mname = _dec_name;
529	my $rname = _dec_qname;	501	my $rname = _dec_name;
530	($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)	502	($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)
531	}, # soa	503	}, # soa
532	11 => sub { ((join ".", unpack "C4"), unpack "C a*", substr $_, 4) }, # wks	504	11 => sub { ((join ".", unpack "C4", $_), unpack "C a*", substr $_, 4) }, # wks
533	12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr	505	12 => sub { local $ofs = $ofs - length; _dec_name }, # ptr
534	13 => sub { unpack "C/a C/a", $_ }, # hinfo	506	13 => sub { unpack "C/a* C/a*", $_ }, # hinfo
535	15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_qname) }, # mx	507	15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_name) }, # mx
536	16 => sub { unpack "(C/a)*", $_ }, # txt	508	16 => sub { unpack "(C/a)", $_ }, # txt
537	28 => sub { AnyEvent::Socket::format_ip ($_) }, # aaaa	509	28 => sub { AnyEvent::Socket::format_address ($_) }, # aaaa
538	33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_qname) }, # 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
539	99 => sub { unpack "(C/a)*", $_ }, # spf	518	99 => sub { unpack "(C/a)", $_ }, # spf
540	);	519	);
541		520
542	sub _dec_rr {	521	sub _dec_rr {
543	my $qname = _dec_qname;	522	my $name = _dec_name;
544		523
545	my ($rt, $rc, $ttl, $rdlen) = unpack "nn N n", substr $pkt, $ofs; $ofs += 10;	524	my ($rt, $rc, $ttl, $rdlen) = unpack "nn N n", substr $pkt, $ofs; $ofs += 10;
546	local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen;	525	local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen;
547		526
548	[	527	[
549	$qname,	528	$name,
550	$type_str{$rt} \|\| $rt,	529	$type_str{$rt} \|\| $rt,
551	$class_str{$rc} \|\| $rc,	530	$class_str{$rc} \|\| $rc,
552	($dec_rr{$rt} \|\| sub { $_ })->(),	531	($dec_rr{$rt} \|\| sub { $_ })->(),
553	]	532	]
554	}	533	}
…		…
557		536
558	Unpacks a DNS packet into a perl data structure.	537	Unpacks a DNS packet into a perl data structure.
559		538
560	Examples:	539	Examples:
561		540
562	# an unsuccessful reply	541	# an unsuccessful reply
563	{	542	{
564	'qd' => [	543	'qd' => [
565	[ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]	544	[ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]
566	],	545	],
567	'rc' => 'nxdomain',	546	'rc' => 'nxdomain',
568	'ar' => [],	547	'ar' => [],
569	'ns' => [	548	'ns' => [
570	[	549	[
571	'uni-karlsruhe.de',	550	'uni-karlsruhe.de',
572	'soa',	551	'soa',
573	'in',	552	'in',
574	'netserv.rz.uni-karlsruhe.de',	553	'netserv.rz.uni-karlsruhe.de',
575	'hostmaster.rz.uni-karlsruhe.de',	554	'hostmaster.rz.uni-karlsruhe.de',
576	2008052201, 10800, 1800, 2592000, 86400	555	2008052201, 10800, 1800, 2592000, 86400
577	]	556	]
578	],	557	],
579	'tc' => '',	558	'tc' => '',
580	'ra' => 1,	559	'ra' => 1,
581	'qr' => 1,	560	'qr' => 1,
582	'id' => 45915,	561	'id' => 45915,
583	'aa' => '',	562	'aa' => '',
584	'an' => [],	563	'an' => [],
585	'rd' => 1,	564	'rd' => 1,
586	'op' => 'query'	565	'op' => 'query'
587	}	566	}
588		567
589	# a successful reply	568	# a successful reply
590		569
591	{	570	{
592	'qd' => [ [ 'www.google.de', 'a', 'in' ] ],	571	'qd' => [ [ 'www.google.de', 'a', 'in' ] ],
593	'rc' => 0,	572	'rc' => 0,
594	'ar' => [	573	'ar' => [
595	[ 'a.l.google.com', 'a', 'in', '209.85.139.9' ],	574	[ 'a.l.google.com', 'a', 'in', '209.85.139.9' ],
596	[ 'b.l.google.com', 'a', 'in', '64.233.179.9' ],	575	[ 'b.l.google.com', 'a', 'in', '64.233.179.9' ],
597	[ 'c.l.google.com', 'a', 'in', '64.233.161.9' ],	576	[ 'c.l.google.com', 'a', 'in', '64.233.161.9' ],
598	],	577	],
599	'ns' => [	578	'ns' => [
600	[ 'l.google.com', 'ns', 'in', 'a.l.google.com' ],	579	[ 'l.google.com', 'ns', 'in', 'a.l.google.com' ],
601	[ 'l.google.com', 'ns', 'in', 'b.l.google.com' ],	580	[ 'l.google.com', 'ns', 'in', 'b.l.google.com' ],
602	],	581	],
603	'tc' => '',	582	'tc' => '',
604	'ra' => 1,	583	'ra' => 1,
605	'qr' => 1,	584	'qr' => 1,
606	'id' => 64265,	585	'id' => 64265,
607	'aa' => '',	586	'aa' => '',
608	'an' => [	587	'an' => [
609	[ 'www.google.de', 'cname', 'in', 'www.google.com' ],	588	[ 'www.google.de', 'cname', 'in', 'www.google.com' ],
610	[ 'www.google.com', 'cname', 'in', 'www.l.google.com' ],	589	[ 'www.google.com', 'cname', 'in', 'www.l.google.com' ],
611	[ 'www.l.google.com', 'a', 'in', '66.249.93.104' ],	590	[ 'www.l.google.com', 'a', 'in', '66.249.93.104' ],
612	[ 'www.l.google.com', 'a', 'in', '66.249.93.147' ],	591	[ 'www.l.google.com', 'a', 'in', '66.249.93.147' ],
613	],	592	],
614	'rd' => 1,	593	'rd' => 1,
615	'op' => 0	594	'op' => 0
616	}	595	}
617		596
618	=cut	597	=cut
619		598
620	sub dns_unpack($) {	599	sub dns_unpack($) {
621	local $pkt = shift;	600	local $pkt = shift;
…		…
676		655
677	our $RESOLVER;	656	our $RESOLVER;
678		657
679	sub resolver() {	658	sub resolver() {
680	$RESOLVER \|\| do {	659	$RESOLVER \|\| do {
681	$RESOLVER = new AnyEvent::DNS;	660	$RESOLVER = new AnyEvent::DNS untaint => 1;
682	$RESOLVER->os_config;	661	$RESOLVER->os_config;
683	$RESOLVER	662	$RESOLVER
684	}	663	}
685	}	664	}
686		665
…		…
692		671
693	=over 4	672	=over 4
694		673
695	=item server => [...]	674	=item server => [...]
696		675
697	A list of server addressses (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
698	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).
699		679
700	=item timeout => [...]	680	=item timeout => [...]
701		681
702	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
703	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,
…		…
712	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
713	tries to resolve the name without any suffixes first.	693	tries to resolve the name without any suffixes first.
714		694
715	=item max_outstanding => $integer	695	=item max_outstanding => $integer
716		696
717	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
718	limits the numbe rof outstanding requests to C<$n> (default: C<10>), that means	698	option limits the number of outstanding requests to C<$integer>
719	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,
720	until some other requests have been resolved.	700	then the additional requests will be queued until some other requests have
		701	been resolved.
721		702
722	=item reuse => $seconds	703	=item reuse => $seconds
723		704
724	The number of seconds (default: C<60>) that a query id cannot be re-used	705	The number of seconds (default: C<300>) that a query id cannot be re-used
725	after a request. Since AnyEvent::DNS will only allocate up to 30000 ID's	706	after a timeout. If there was no time-out then query ids can be reused
726	at the same time, the long-term maximum number of requests per second is	707	immediately.
727	C<30000 / $seconds> (and thus C<500> requests/s by default).	708
		709	=item untaint => $boolean
		710
		711	When true, then the resolver will automatically untaint results, and might
		712	also ignore certain environment variables.
728		713
729	=back	714	=back
730		715
731	=cut	716	=cut
732		717
733	sub new {	718	sub new {
734	my ($class, %arg) = @_;	719	my ($class, %arg) = @_;
735		720
736	socket my $fh, &Socket::AF_INET, &Socket::SOCK_DGRAM, 0
737	or Carp::croak "socket: $!";
738
739	AnyEvent::Util::fh_nonblocking $fh, 1;
740
741	my $self = bless {	721	my $self = bless {
742	server => [v127.0.0.1],	722	server => [],
743	timeout => [2, 5, 5],	723	timeout => [2, 5, 5],
744	search => [],	724	search => [],
745	ndots => 1,	725	ndots => 1,
746	max_outstanding => 10,	726	max_outstanding => 10,
747	reuse => 60, # reuse id's after 5 minutes only, if possible	727	reuse => 300,
748	%arg,	728	%arg,
749	fh => $fh,
750	reuse_q => [],	729	reuse_q => [],
751	}, $class;	730	}, $class;
752		731
753	# search should default to gethostname's domain	732	# search should default to gethostname's domain
754	# but perl lacks a good posix module	733	# but perl lacks a good posix module
755		734
		735	# try to create an ipv4 and an ipv6 socket
		736	# only fail when we cannot create either
		737	my $got_socket;
		738
756	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;
757	$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";
758		767
759	$self->_compile;	768	$self->_compile;
760		769
761	$self	770	$self
762	}	771	}
763		772
764	=item $resolver->parse_resolv_conv ($string)	773	=item $resolver->parse_resolv_conv ($string)
765		774
766	Parses the given string a sif it were a F<resolv.conf> file. The following	775	Parses the given string as if it were a F<resolv.conf> file. The following
767	directives are supported (but not neecssarily implemented).	776	directives are supported (but not necessarily implemented).
768		777
769	C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,	778	C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,
770	C<options> (C<timeout>, C<attempts>, C<ndots>).	779	C<options> (C<timeout>, C<attempts>, C<ndots>).
771		780
772	Everything else is silently ignored.	781	Everything else is silently ignored.
…		…
784	for (split /\n/, $resolvconf) {	793	for (split /\n/, $resolvconf) {
785	if (/^\s*#/) {	794	if (/^\s*#/) {
786	# comment	795	# comment
787	} elsif (/^\snameserver\s+(\S+)\s$/i) {	796	} elsif (/^\snameserver\s+(\S+)\s$/i) {
788	my $ip = $1;	797	my $ip = $1;
789	if (AnyEvent::Util::dotted_quad $ip) {	798	if (my $ipn = AnyEvent::Socket::parse_address ($ip)) {
790	push @{ $self->{server} }, AnyEvent::Util::socket_inet_aton $ip;	799	push @{ $self->{server} }, $ipn;
791	} else {	800	} else {
792	warn "nameserver $ip invalid and ignored\n";	801	warn "nameserver $ip invalid and ignored\n";
793	}	802	}
794	} elsif (/^\sdomain\s+(\S)\s+$/i) {	803	} elsif (/^\sdomain\s+(\S)\s+$/i) {
795	$self->{search} = [$1];	804	$self->{search} = [$1];
…		…
818	$self->_compile;	827	$self->_compile;
819	}	828	}
820		829
821	=item $resolver->os_config	830	=item $resolver->os_config
822		831
823	Tries so load and parse F</etc/resolv.conf> on portable opertaing systems. Tries various	832	Tries so load and parse F</etc/resolv.conf> on portable operating
824	egregious hacks on windows to force the dns servers and searchlist out of the config.	833	systems. Tries various egregious hacks on windows to force the DNS servers
		834	and searchlist out of the system.
825		835
826	=cut	836	=cut
827		837
828	sub os_config {	838	sub os_config {
829	my ($self) = @_;	839	my ($self) = @_;
830		840
831	if ($^O =~ /mswin32\|cygwin/i) {	841	$self->{server} = [];
832	# yeah, it suxx... lets hope DNS is DNS in all locales	842	$self->{search} = [];
		843
		844	if (AnyEvent::WIN32 \|\| $^O =~ /cygwin/i) {
		845	no strict 'refs';
		846
		847	# there are many options to find the current nameservers etc. on windows
		848	# all of them don't work consistently:
		849	# - the registry thing needs separate code on win32 native vs. cygwin
		850	# - the registry layout differs between windows versions
		851	# - calling windows api functions doesn't work on cygwin
		852	# - ipconfig uses locale-specific messages
		853
		854	# we use ipconfig parsing because, despite all its brokenness,
		855	# it seems most stable in practise.
		856	# for good measure, we append a fallback nameserver to our list.
833		857
834	if (open my $fh, "ipconfig /all \|") {	858	if (open my $fh, "ipconfig /all \|") {
835	delete $self->{server};	859	# parsing strategy: we go through the output and look for
836	delete $self->{search};	860	# :-lines with DNS in them. everything in those is regarded as
		861	# either a nameserver (if it parses as an ip address), or a suffix
		862	# (all else).
837		863
		864	my $dns;
838	while (<$fh>) {	865	while (<$fh>) {
839	# first DNS.* is suffix list	866	if (s/^\s.\bdns\b.://i) {
840	if (/^\s*DNS/) {	867	$dns = 1;
841	while (/\s+([[:alnum:].\-]+)\s*$/) {	868	} elsif (/^\S/ \|\| /^\s[^:]{16,}: /) {
		869	$dns = 0;
		870	}
		871	if ($dns && /^\s(\S+)\s$/) {
		872	my $s = $1;
		873	$s =~ s/%\d+(?!\S)//; # get rid of ipv6 scope id
		874	if (my $ipn = AnyEvent::Socket::parse_address ($s)) {
		875	push @{ $self->{server} }, $ipn;
		876	} else {
842	push @{ $self->{search} }, $1;	877	push @{ $self->{search} }, $s;
843	$_ = <$fh>;
844	}	878	}
845	last;
846	}	879	}
847	}	880	}
848		881
849	while (<$fh>) {	882	# always add one fallback server
850	# second DNS.* is server address list	883	push @{ $self->{server} }, $DNS_FALLBACK[rand @DNS_FALLBACK];
851	if (/^\s*DNS/) {
852	while (/\s+(\d+\.\d+\.\d+\.\d+)\s*$/) {
853	my $ip = $1;
854	push @{ $self->{server} }, AnyEvent::Util::socket_inet_aton $ip
855	if AnyEvent::Util::dotted_quad $ip;
856	$_ = <$fh>;
857	}
858	last;
859	}
860	}
861		884
862	$self->_compile;	885	$self->_compile;
863	}	886	}
864	} else {	887	} else {
865	# try resolv.conf everywhere	888	# try resolv.conf everywhere
…		…
869	$self->parse_resolv_conf (<$fh>);	892	$self->parse_resolv_conf (<$fh>);
870	}	893	}
871	}	894	}
872	}	895	}
873		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
874	sub _compile {	925	sub _compile {
875	my $self = shift;	926	my $self = shift;
		927
		928	my %search; $self->{search} = [grep 0 < length, grep !$search{$_}++, @{ $self->{search} }];
		929	my %server; $self->{server} = [grep 0 < length, grep !$server{$_}++, @{ $self->{server} }];
		930
		931	unless (@{ $self->{server} }) {
		932	# use 127.0.0.1 by default, and one opendns nameserver as fallback
		933	$self->{server} = [v127.0.0.1, $DNS_FALLBACK[rand @DNS_FALLBACK]];
		934	}
876		935
877	my @retry;	936	my @retry;
878		937
879	for my $timeout (@{ $self->{timeout} }) {	938	for my $timeout (@{ $self->{timeout} }) {
880	for my $server (@{ $self->{server} }) {	939	for my $server (@{ $self->{server} }) {
…		…
886	}	945	}
887		946
888	sub _feed {	947	sub _feed {
889	my ($self, $res) = @_;	948	my ($self, $res) = @_;
890		949
		950	($res) = $res =~ /^(.*)$/s
		951	if AnyEvent::TAINT && $self->{untaint};
		952
891	$res = dns_unpack $res	953	$res = dns_unpack $res
892	or return;	954	or return;
893		955
894	my $id = $self->{id}{$res->{id}};	956	my $id = $self->{id}{$res->{id}};
895		957
…		…
898	$NOW = time;	960	$NOW = time;
899	$id->[1]->($res);	961	$id->[1]->($res);
900	}	962	}
901		963
902	sub _recv {	964	sub _recv {
903	my ($self) = @_;	965	my ($self, $pkt, $peer) = @_;
904		966
905	while (my $peer = recv $self->{fh}, my $res, 4096, 0) {	967	# we ignore errors (often one gets port unreachable, but there is
		968	# no good way to take advantage of that.
		969
906	my ($port, $host) = Socket::unpack_sockaddr_in $peer;	970	my ($port, $host) = AnyEvent::Socket::unpack_sockaddr ($peer);
907		971
908	return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };	972	return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };
909		973
910	$self->_feed ($res);	974	$self->_feed ($pkt);
911	}
912	}	975	}
913		976
		977	sub _free_id {
		978	my ($self, $id, $timeout) = @_;
		979
		980	if ($timeout) {
		981	# we need to block the id for a while
		982	$self->{id}{$id} = 1;
		983	push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $id];
		984	} else {
		985	# we can quickly recycle the id
		986	delete $self->{id}{$id};
		987	}
		988
		989	--$self->{outstanding};
		990	$self->_scheduler;
		991	}
		992
		993	# execute a single request, involves sending it with timeouts to multiple servers
914	sub _exec {	994	sub _exec {
915	my ($self, $req, $retry) = @_;	995	my ($self, $req) = @_;
916		996
		997	my $retry; # of retries
		998	my $do_retry;
		999
		1000	$do_retry = sub {
917	if (my $retry_cfg = $self->{retry}[$retry]) {	1001	my $retry_cfg = $self->{retry}[$retry++]
		1002	or do {
		1003	# failure
		1004	$self->_free_id ($req->[2], $retry > 1);
		1005	undef $do_retry; return $req->[1]->();
		1006	};
		1007
918	my ($server, $timeout) = @$retry_cfg;	1008	my ($server, $timeout) = @$retry_cfg;
919		1009
920	$self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {	1010	$self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {
921	$NOW = time;	1011	$NOW = time;
922		1012
923	# timeout, try next	1013	# timeout, try next
924	$self->_exec ($req, $retry + 1);	1014	&$do_retry if $do_retry;
925	}), sub {	1015	}), sub {
926	my ($res) = @_;	1016	my ($res) = @_;
927		1017
928	if ($res->{tc}) {	1018	if ($res->{tc}) {
929	# success, but truncated, so use tcp	1019	# success, but truncated, so use tcp
930	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
931	my ($fh) = @_	1023	my ($fh) = @_
932	or return $self->_exec ($req, $retry + 1);	1024	or return &$do_retry;
933		1025
934	my $handle = new AnyEvent::Handle	1026	my $handle; $handle = new AnyEvent::Handle
935	fh => $fh,	1027	fh => $fh,
		1028	timeout => $timeout,
936	on_error => sub {	1029	on_error => sub {
		1030	undef $handle;
		1031	return unless $do_retry; # some other request could have invalidated us already
937	# failure, try next	1032	# failure, try next
938	$self->_exec ($req, $retry + 1);	1033	&$do_retry;
939	};	1034	};
940		1035
941	$handle->push_write (pack "n/a", $req->[0]);	1036	$handle->push_write (pack "n/a", $req->[0]);
942	$handle->push_read_chunk (2, sub {	1037	$handle->push_read (chunk => 2, sub {
943	$handle->unshift_read_chunk ((unpack "n", $_[1]), sub {	1038	$handle->unshift_read (chunk => (unpack "n", $_[1]), sub {
		1039	undef $handle;
944	$self->_feed ($_[1]);	1040	$self->_feed ($_[1]);
945	});	1041	});
946	});	1042	});
947	shutdown $fh, 1;
948		1043
949	}, sub { $timeout });	1044	}, sub { $timeout });
950		1045
951	} else {	1046	} else {
952	# success	1047	# success
953	$self->{id}{$req->[2]} = 1;	1048	$self->_free_id ($req->[2], $retry > 1);
954	push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];	1049	undef $do_retry; return $req->[1]->($res);
955	--$self->{outstanding};
956	$self->_scheduler;
957
958	$req->[1]->($res);
959	}	1050	}
960	}];	1051	}];
		1052
		1053	my $sa = AnyEvent::Socket::pack_sockaddr (DOMAIN_PORT, $server);
961		1054
962	send $self->{fh}, $req->[0], 0, Socket::pack_sockaddr_in 53, $server;	1055	my $fh = AF_INET == Socket::sockaddr_family ($sa)
963	} else {	1056	? $self->{fh4} : $self->{fh6}
964	# failure	1057	or return &$do_retry;
965	$self->{id}{$req->[2]} = 1;
966	push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];
967	--$self->{outstanding};
968	$self->_scheduler;
969		1058
970	$req->[1]->();	1059	send $fh, $req->[0], 0, $sa;
971	}	1060	};
		1061
		1062	&$do_retry;
972	}	1063	}
973		1064
974	sub _scheduler {	1065	sub _scheduler {
975	my ($self) = @_;	1066	my ($self) = @_;
		1067
		1068	no strict 'refs';
976		1069
977	$NOW = time;	1070	$NOW = time;
978		1071
979	# first clear id reuse queue	1072	# first clear id reuse queue
980	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }	1073	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }
…		…
989	$self->_scheduler;	1082	$self->_scheduler;
990	});	1083	});
991	last;	1084	last;
992	}	1085	}
993		1086
994	my $req = shift @{ $self->{queue} }	1087	if (my $req = shift @{ $self->{queue} }) {
995	or last;	1088	# found a request in the queue, execute it
996
997	while () {	1089	while () {
998	$req->[2] = int rand 65536;	1090	$req->[2] = int rand 65536;
999	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;
1000	}	1107	}
1001
1002	$self->{id}{$req->[2]} = 1;
1003	substr $req->[0], 0, 2, pack "n", $req->[2];
1004
1005	++$self->{outstanding};
1006	$self->_exec ($req, 0);
1007	}	1108	}
1008	}	1109	}
1009		1110
1010	=item $resolver->request ($req, $cb->($res))	1111	=item $resolver->request ($req, $cb->($res))
1011		1112
		1113	This is the main low-level workhorse for sending DNS requests.
		1114
1012	Sends a single request (a hash-ref formated as specified for	1115	This function sends a single request (a hash-ref formated as specified
1013	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
1014	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
1015	was received, or no arguments on timeout.	1121	received, or no arguments in case none of the servers answered.
1016		1122
1017	=cut	1123	=cut
1018		1124
1019	sub request($$) {	1125	sub request($$) {
1020	my ($self, $req, $cb) = @_;	1126	my ($self, $req, $cb) = @_;
1021		1127
1022	push @{ $self->{queue} }, [dns_pack $req, $cb];	1128	push @{ $self->{queue} }, [dns_pack $req, $cb];
1023	$self->_scheduler;	1129	$self->_scheduler;
1024	}	1130	}
1025		1131
1026	=item $resolver->resolve ($qname, $qtype, %options, $cb->($rcode, @rr))	1132	=item $resolver->resolve ($qname, $qtype, %options, $cb->(@rr))
1027		1133
1028	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>.
1029	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.
1030		1141
1031	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
1032	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.
1033		1144
1034	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.
1035		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.
		1157
1036	Note that this resolver is just a stub resolver: it requires a nameserver	1158	Note that this resolver is just a stub resolver: it requires a name server
1037	supporting recursive queries, will not do any recursive queries itself and	1159	supporting recursive queries, will not do any recursive queries itself and
1038	is not secure when used against an untrusted name server.	1160	is not secure when used against an untrusted name server.
1039		1161
1040	The following options are supported:	1162	The following options are supported:
1041		1163
…		…
1043		1165
1044	=item search => [$suffix...]	1166	=item search => [$suffix...]
1045		1167
1046	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
1047	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
1048	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
1049	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.
1050		1173
1051	=item accept => [$type...]	1174	=item accept => [$type...]
1052		1175
1053	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
1054	accepted and returned. The default includes the C<$qtype> and nothing	1177	accepted and returned. The default includes the C<$qtype> and nothing
1055	else.	1178	else. If this list includes C<cname>, then CNAME-chains will not be
		1179	followed (because you asked for the CNAME record).
1056		1180
1057	=item class => "class"	1181	=item class => "class"
1058		1182
1059	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
1060	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.
1061		1185
1062	=back	1186	=back
1063		1187
1064	Examples:	1188	Examples:
1065		1189
1066	$res->resolve ("ruth.plan9.de", "a", sub {	1190	# full example, you can paste this into perl:
1067	warn Dumper [@_];	1191	use Data::Dumper;
1068	});	1192	use AnyEvent::DNS;
		1193	AnyEvent::DNS::resolver->resolve (
		1194	"google.com", "*", my $cv = AnyEvent->condvar);
		1195	warn Dumper [$cv->recv];
1069		1196
		1197	# shortened result:
1070	[	1198	# [
		1199	# [ 'google.com', 'soa', 'in', 'ns1.google.com', 'dns-admin.google.com',
		1200	# 2008052701, 7200, 1800, 1209600, 300 ],
1071	[	1201	# [
1072	'ruth.schmorp.de',	1202	# 'google.com', 'txt', 'in',
1073	'a',	1203	# 'v=spf1 include:_netblocks.google.com ~all'
1074	'in',	1204	# ],
1075	'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' ],
1076	]	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' ]
1077	]	1216	# ]
1078		1217
		1218	# resolve any records, but return only a and aaaa records:
1079	$res->resolve ("test1.laendle", "*",	1219	$res->resolve ("test1.laendle", "*",
1080	accept => ["a", "aaaa"],	1220	accept => ["a", "aaaa"],
1081	sub {	1221	sub {
1082	warn Dumper [@_];	1222	warn Dumper [@_];
1083	}	1223	}
1084	);	1224	);
1085		1225
1086	[	1226	# result:
1087	[	1227	# [
1088	'test1.laendle',	1228	# [ 'test1.laendle', 'a', 'in', '10.0.0.255' ],
1089	'a',	1229	# [ 'test1.laendle', 'aaaa', 'in', '3ffe:1900:4545:0002:0240:0000:0000:f7e1' ]
1090	'in',
1091	'10.0.0.255'
1092	],
1093	[
1094	'test1.laendle',
1095	'aaaa',
1096	'in',
1097	'3ffe:1900:4545:0002:0240:0000:0000:f7e1'
1098	]	1230	# ]
1099	]
1100		1231
1101	=cut	1232	=cut
1102		1233
1103	sub resolve($%) {	1234	sub resolve($%) {
1104	my $cb = pop;	1235	my $cb = pop;
…		…
1117	my %atype = $opt{accept}	1248	my %atype = $opt{accept}
1118	? map +($_ => 1), @{ $opt{accept} }	1249	? map +($_ => 1), @{ $opt{accept} }
1119	: ($qtype => 1);	1250	: ($qtype => 1);
1120		1251
1121	# advance in searchlist	1252	# advance in searchlist
1122	my $do_search; $do_search = sub {	1253	my ($do_search, $do_req);
		1254
		1255	$do_search = sub {
1123	@search	1256	@search
1124	or return $cb->();	1257	or (undef $do_search), (undef $do_req), return $cb->();
1125		1258
1126	(my $name = lc "$qname." . shift @search) =~ s/\.$//;	1259	(my $name = lc "$qname." . shift @search) =~ s/\.$//;
1127	my $depth = 2;	1260	my $depth = 10;
1128		1261
1129	# advance in cname-chain	1262	# advance in cname-chain
1130	my $do_req; $do_req = sub {	1263	$do_req = sub {
1131	$self->request ({	1264	$self->request ({
1132	rd => 1,	1265	rd => 1,
1133	qd => [[$name, $qtype, $class]],	1266	qd => [[$name, $qtype, $class]],
1134	}, sub {	1267	}, sub {
1135	my ($res) = @_	1268	my ($res) = @_
…		…
1139		1272
1140	while () {	1273	while () {
1141	# results found?	1274	# results found?
1142	my @rr = grep $name eq lc $_->[0] && ($atype{"*"} \|\| $atype{$_->[1]}), @{ $res->{an} };	1275	my @rr = grep $name eq lc $_->[0] && ($atype{"*"} \|\| $atype{$_->[1]}), @{ $res->{an} };
1143		1276
1144	return $cb->(@rr)	1277	(undef $do_search), (undef $do_req), return $cb->(@rr)
1145	if @rr;	1278	if @rr;
1146		1279
1147	# see if there is a cname we can follow	1280	# see if there is a cname we can follow
1148	my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} };	1281	my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} };
1149		1282
…		…
1170	};	1303	};
1171		1304
1172	$do_search->();	1305	$do_search->();
1173	}	1306	}
1174		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
1175	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
1176		1340
1177	1;	1341	1;
1178		1342
1179	=back	1343	=back
1180		1344
1181	=head1 AUTHOR	1345	=head1 AUTHOR
1182		1346
1183	Marc Lehmann <schmorp@schmorp.de>	1347	Marc Lehmann <schmorp@schmorp.de>
1184	http://home.schmorp.de/	1348	http://home.schmorp.de/
1185		1349
1186	=cut	1350	=cut
1187		1351

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.19 by root, Fri May 23 23:37:13 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.19 by root, Fri May 23 23:37:13 2008 UTC vs.
Revision 1.96 by root, Mon Jun 29 21:00:32 2009 UTC