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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.27 by root, Sat May 24 23:10:18 2008 UTC vs.
Revision 1.105 by root, Fri Jul 17 14:57:03 2009 UTC

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

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.27 by root, Sat May 24 23:10:18 2008 UTC vs. Revision 1.105 by root, Fri Jul 17 14:57:03 2009 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.27 by root, Sat May 24 23:10:18 2008 UTC vs.
Revision 1.105 by root, Fri Jul 17 14:57:03 2009 UTC