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

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

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.24 by root, Sat May 24 02:50:45 2008 UTC vs. Revision 1.92 by root, Sun Jun 7 16:48:38 2009 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.24 by root, Sat May 24 02:50:45 2008 UTC vs.
Revision 1.92 by root, Sun Jun 7 16:48:38 2009 UTC