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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.32 by root, Mon May 26 02:18:41 2008 UTC vs.
Revision 1.75 by root, Thu Aug 21 23:48:35 2008 UTC

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

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.32 by root, Mon May 26 02:18:41 2008 UTC vs. Revision 1.75 by root, Thu Aug 21 23:48:35 2008 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.32 by root, Mon May 26 02:18:41 2008 UTC vs.
Revision 1.75 by root, Thu Aug 21 23:48:35 2008 UTC