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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.38 by root, Thu May 29 01:46:56 2008 UTC vs.
Revision 1.61 by root, Wed Jun 4 09:55:16 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
…		…
35		35
36	use AnyEvent ();	36	use AnyEvent ();
37	use AnyEvent::Handle ();	37	use AnyEvent::Handle ();
38	use AnyEvent::Util qw(AF_INET6);	38	use AnyEvent::Util qw(AF_INET6);
39		39
		40	our $VERSION = 4.12;
		41
40	our @DNS_FALLBACK = (v208.67.220.220, v208.67.222.222);	42	our @DNS_FALLBACK = (v208.67.220.220, v208.67.222.222);
41		43
42	=item AnyEvent::DNS::a $domain, $cb->(@addrs)	44	=item AnyEvent::DNS::a $domain, $cb->(@addrs)
43		45
44	Tries to resolve the given domain to IPv4 address(es).	46	Tries to resolve the given domain to IPv4 address(es).
…		…
63	=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)	65	=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)
64		66
65	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
66	of service records.	68	of service records.
67		69
68	Each srv_rr is an array reference with the following contents:	70	Each C<$srv_rr> is an array reference with the following contents:
69	C<[$priority, $weight, $transport, $target]>.	71	C<[$priority, $weight, $transport, $target]>.
70		72
71	They will be sorted with lowest priority, highest weight first (TODO:	73	They will be sorted with lowest priority first, then randomly
72	should use the RFC algorithm to reorder same-priority records for weight).	74	distributed by weight as per RFC 2782.
73		75
74	Example:	76	Example:
75		77
76	AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...	78	AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...
77	# @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )	79	# @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )
78		80
79	=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)
80		93
81	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)
82	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.
83		108
84	Example:	109	Example:
85		110
86	AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };	111	AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };
87	# => f.root-servers.net	112	# => f.root-servers.net
88
89	=item AnyEvent::DNS::any $domain, $cb->(@rrs)
90
91	Tries to resolve the given domain and passes all resource records found to
92	the callback.
93		113
94	=cut	114	=cut
95		115
96	sub MAX_PKT() { 4096 } # max packet size we advertise and accept	116	sub MAX_PKT() { 4096 } # max packet size we advertise and accept
97		117
…		…
142	sub srv($$$$) {	162	sub srv($$$$) {
143	my ($service, $proto, $domain, $cb) = @_;	163	my ($service, $proto, $domain, $cb) = @_;
144		164
145	# todo, ask for any and check glue records	165	# todo, ask for any and check glue records
146	resolver->resolve ("_$service._$proto.$domain" => "srv", sub {	166	resolver->resolve ("_$service._$proto.$domain" => "srv", sub {
147	$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->[0] <=> $b->[0] } 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);
148	});	194	});
149	}	195	}
150		196
151	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($$) {
152	my ($ip, $cb) = @_;	239	my ($ip, $cb) = @_;
153		240
154	$ip = AnyEvent::Socket::parse_address ($ip)	241	$ip = _munge_ptr AnyEvent::Socket::parse_address ($ip)
155	or return $cb->();	242	or return $cb->();
156
157	my $af = AnyEvent::Socket::address_family ($ip);
158
159	if ($af == AF_INET) {
160	$ip = join ".", (reverse split /\./, $ip), "in-addr.arpa.";
161	} elsif ($af == AF_INET6) {
162	$ip = join ".", (reverse split //, unpack "H*", $ip), "ip6.arpa.";
163	} else {
164	return $cb->();
165	}
166		243
167	resolver->resolve ($ip => "ptr", sub {	244	resolver->resolve ($ip => "ptr", sub {
168	$cb->(map $_->[3], @_);	245	$cb->(map $_->[3], @_);
169	});	246	});
170	}	247	}
171		248
172	sub any($$) {	249	sub reverse_verify($$) {
173	my ($domain, $cb) = @_;	250	my ($ip, $cb) = @_;
		251
		252	my $ipn = AnyEvent::Socket::parse_address ($ip)
		253	or return $cb->();
174		254
175	resolver->resolve ($domain => "*", $cb);	255	my $af = AnyEvent::Socket::address_family ($ipn);
		256
		257	my @res;
		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;
		268
		269	# () around AF_INET to work around bug in 5.8
		270	resolver->resolve ("$name." => ($af == (AF_INET) ? "a" : "aaaa"), sub {
		271	for (@_) {
		272	push @res, $name
		273	if $_->[3] eq $ip;
		274	}
		275	$cb->(@res) unless --$cnt;
		276	});
		277	}
		278
		279	$cb->() unless $cnt;
		280	};
176	}	281	}
177		282
178	#################################################################################	283	#################################################################################
179		284
180	=back	285	=back
…		…
185		290
186	=item $AnyEvent::DNS::EDNS0	291	=item $AnyEvent::DNS::EDNS0
187		292
188	This variable decides whether dns_pack automatically enables EDNS0	293	This variable decides whether dns_pack automatically enables EDNS0
189	support. By default, this is disabled (C<0>), unless overridden by	294	support. By default, this is disabled (C<0>), unless overridden by
190	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
191	EDNS0 in all requests.	296	EDNS0 in all requests.
192		297
193	=cut	298	=cut
194		299
195	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
…		…
246	minfo => 14,	351	minfo => 14,
247	mx => 15,	352	mx => 15,
248	txt => 16,	353	txt => 16,
249	aaaa => 28,	354	aaaa => 28,
250	srv => 33,	355	srv => 33,
		356	naptr => 35, # rfc2915
251	opt => 41,	357	opt => 41,
252	spf => 99,	358	spf => 99,
253	tkey => 249,	359	tkey => 249,
254	tsig => 250,	360	tsig => 250,
255	ixfr => 251,	361	ixfr => 251,
…		…
268	"*" => 255,	374	"*" => 255,
269	);	375	);
270		376
271	our %class_str = reverse %class_id;	377	our %class_str = reverse %class_id;
272		378
273	# names MUST have a trailing dot
274	sub _enc_name($) {	379	sub _enc_name($) {
275	pack "(C/a)", (split /\./, shift), ""	380	pack "(C/a)", (split /\./, shift), ""
276	}	381	}
277		382
278	sub _enc_qd() {	383	sub _enc_qd() {
…		…
285	die "encoding of resource records is not supported";	390	die "encoding of resource records is not supported";
286	}	391	}
287		392
288	=item $pkt = AnyEvent::DNS::dns_pack $dns	393	=item $pkt = AnyEvent::DNS::dns_pack $dns
289		394
290	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
291	recommended, then everything will be totally clear. Or maybe not.	396	recommended, then everything will be totally clear. Or maybe not.
292		397
293	Resource records are not yet encodable.	398	Resource records are not yet encodable.
294		399
295	Examples:	400	Examples:
296		401
297	# very simple request, using lots of default values:	402	# very simple request, using lots of default values:
298	{ rd => 1, qd => [ [ "host.domain", "a"] ] }	403	{ rd => 1, qd => [ [ "host.domain", "a"] ] }
299		404
300	# more complex example, showing how flags etc. are named:	405	# more complex example, showing how flags etc. are named:
301		406
302	{	407	{
303	id => 10000,	408	id => 10000,
304	op => "query",	409	op => "query",
305	rc => "nxdomain",	410	rc => "nxdomain",
306		411
307	# flags	412	# flags
308	qr => 1,	413	qr => 1,
309	aa => 0,	414	aa => 0,
310	tc => 0,	415	tc => 0,
311	rd => 0,	416	rd => 0,
312	ra => 0,	417	ra => 0,
313	ad => 0,	418	ad => 0,
314	cd => 0,	419	cd => 0,
315		420
316	qd => [@rr], # query section	421	qd => [@rr], # query section
317	an => [@rr], # answer section	422	an => [@rr], # answer section
318	ns => [@rr], # authority section	423	ns => [@rr], # authority section
319	ar => [@rr], # additional records section	424	ar => [@rr], # additional records section
320	}	425	}
321		426
322	=cut	427	=cut
323		428
324	sub dns_pack($) {	429	sub dns_pack($) {
325	my ($req) = @_;	430	my ($req) = @_;
…		…
338	+ $rcode_id{$req->{rc}} * 0x0001,	443	+ $rcode_id{$req->{rc}} * 0x0001,
339		444
340	scalar @{ $req->{qd} \|\| [] },	445	scalar @{ $req->{qd} \|\| [] },
341	scalar @{ $req->{an} \|\| [] },	446	scalar @{ $req->{an} \|\| [] },
342	scalar @{ $req->{ns} \|\| [] },	447	scalar @{ $req->{ns} \|\| [] },
343	$EDNS0 + scalar @{ $req->{ar} \|\| [] }, # include EDNS0 option here	448	$EDNS0 + scalar @{ $req->{ar} \|\| [] }, # EDNS0 option included here
344		449
345	(join "", map _enc_qd, @{ $req->{qd} \|\| [] }),	450	(join "", map _enc_qd, @{ $req->{qd} \|\| [] }),
346	(join "", map _enc_rr, @{ $req->{an} \|\| [] }),	451	(join "", map _enc_rr, @{ $req->{an} \|\| [] }),
347	(join "", map _enc_rr, @{ $req->{ns} \|\| [] }),	452	(join "", map _enc_rr, @{ $req->{ns} \|\| [] }),
348	(join "", map _enc_rr, @{ $req->{ar} \|\| [] }),	453	(join "", map _enc_rr, @{ $req->{ar} \|\| [] }),
349		454
350	($EDNS0 ? pack "C nnNn", 0, 41, MAX_PKT, 0, 0 : "") # EDNS0, 4kiB udp payload size	455	($EDNS0 ? pack "C nnNn", 0, 41, MAX_PKT, 0, 0 : "") # EDNS0 option
351	}	456	}
352		457
353	our $ofs;	458	our $ofs;
354	our $pkt;	459	our $pkt;
355		460
…		…
400	13 => sub { unpack "C/a* C/a*", $_ }, # hinfo	505	13 => sub { unpack "C/a* C/a*", $_ }, # hinfo
401	15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_name) }, # mx	506	15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_name) }, # mx
402	16 => sub { unpack "(C/a)", $_ }, # txt	507	16 => sub { unpack "(C/a)", $_ }, # txt
403	28 => sub { AnyEvent::Socket::format_address ($_) }, # aaaa	508	28 => sub { AnyEvent::Socket::format_address ($_) }, # aaaa
404	33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_name) }, # srv	509	33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_name) }, # srv
		510	35 => sub { # naptr
		511	my ($order, $preference, $flags, $service, $regexp, $offset) = unpack "nn C/a* C/a* C/a* .", $_;
		512	local $ofs = $ofs + $offset - length;
		513	($order, $preference, $flags, $service, $regexp, _dec_name)
		514	},
405	99 => sub { unpack "(C/a)", $_ }, # spf	515	99 => sub { unpack "(C/a)", $_ }, # spf
406	);	516	);
407		517
408	sub _dec_rr {	518	sub _dec_rr {
409	my $name = _dec_name;	519	my $name = _dec_name;
…		…
423		533
424	Unpacks a DNS packet into a perl data structure.	534	Unpacks a DNS packet into a perl data structure.
425		535
426	Examples:	536	Examples:
427		537
428	# an unsuccessful reply	538	# an unsuccessful reply
429	{	539	{
430	'qd' => [	540	'qd' => [
431	[ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]	541	[ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]
432	],	542	],
433	'rc' => 'nxdomain',	543	'rc' => 'nxdomain',
434	'ar' => [],	544	'ar' => [],
435	'ns' => [	545	'ns' => [
436	[	546	[
437	'uni-karlsruhe.de',	547	'uni-karlsruhe.de',
438	'soa',	548	'soa',
439	'in',	549	'in',
440	'netserv.rz.uni-karlsruhe.de',	550	'netserv.rz.uni-karlsruhe.de',
441	'hostmaster.rz.uni-karlsruhe.de',	551	'hostmaster.rz.uni-karlsruhe.de',
442	2008052201, 10800, 1800, 2592000, 86400	552	2008052201, 10800, 1800, 2592000, 86400
443	]	553	]
444	],	554	],
445	'tc' => '',	555	'tc' => '',
446	'ra' => 1,	556	'ra' => 1,
447	'qr' => 1,	557	'qr' => 1,
448	'id' => 45915,	558	'id' => 45915,
449	'aa' => '',	559	'aa' => '',
450	'an' => [],	560	'an' => [],
451	'rd' => 1,	561	'rd' => 1,
452	'op' => 'query'	562	'op' => 'query'
453	}	563	}
454		564
455	# a successful reply	565	# a successful reply
456		566
457	{	567	{
458	'qd' => [ [ 'www.google.de', 'a', 'in' ] ],	568	'qd' => [ [ 'www.google.de', 'a', 'in' ] ],
459	'rc' => 0,	569	'rc' => 0,
460	'ar' => [	570	'ar' => [
461	[ 'a.l.google.com', 'a', 'in', '209.85.139.9' ],	571	[ 'a.l.google.com', 'a', 'in', '209.85.139.9' ],
462	[ 'b.l.google.com', 'a', 'in', '64.233.179.9' ],	572	[ 'b.l.google.com', 'a', 'in', '64.233.179.9' ],
463	[ 'c.l.google.com', 'a', 'in', '64.233.161.9' ],	573	[ 'c.l.google.com', 'a', 'in', '64.233.161.9' ],
464	],	574	],
465	'ns' => [	575	'ns' => [
466	[ 'l.google.com', 'ns', 'in', 'a.l.google.com' ],	576	[ 'l.google.com', 'ns', 'in', 'a.l.google.com' ],
467	[ 'l.google.com', 'ns', 'in', 'b.l.google.com' ],	577	[ 'l.google.com', 'ns', 'in', 'b.l.google.com' ],
468	],	578	],
469	'tc' => '',	579	'tc' => '',
470	'ra' => 1,	580	'ra' => 1,
471	'qr' => 1,	581	'qr' => 1,
472	'id' => 64265,	582	'id' => 64265,
473	'aa' => '',	583	'aa' => '',
474	'an' => [	584	'an' => [
475	[ 'www.google.de', 'cname', 'in', 'www.google.com' ],	585	[ 'www.google.de', 'cname', 'in', 'www.google.com' ],
476	[ 'www.google.com', 'cname', 'in', 'www.l.google.com' ],	586	[ 'www.google.com', 'cname', 'in', 'www.l.google.com' ],
477	[ 'www.l.google.com', 'a', 'in', '66.249.93.104' ],	587	[ 'www.l.google.com', 'a', 'in', '66.249.93.104' ],
478	[ 'www.l.google.com', 'a', 'in', '66.249.93.147' ],	588	[ 'www.l.google.com', 'a', 'in', '66.249.93.147' ],
479	],	589	],
480	'rd' => 1,	590	'rd' => 1,
481	'op' => 0	591	'op' => 0
482	}	592	}
483		593
484	=cut	594	=cut
485		595
486	sub dns_unpack($) {	596	sub dns_unpack($) {
487	local $pkt = shift;	597	local $pkt = shift;
…		…
558		668
559	=over 4	669	=over 4
560		670
561	=item server => [...]	671	=item server => [...]
562		672
563	A list of server addresses (default: C<v127.0.0.1>) in network format (4	673	A list of server addresses (default: C<v127.0.0.1>) in network format
564	octets for IPv4, 16 octets for IPv6 - not yet supported).	674	(i.e. as returned by C<AnyEvent::Socket::parse_address> - both IPv4 and
		675	IPv6 are supported).
565		676
566	=item timeout => [...]	677	=item timeout => [...]
567		678
568	A list of timeouts to use (also determines the number of retries). To make	679	A list of timeouts to use (also determines the number of retries). To make
569	three retries with individual time-outs of 2, 5 and 5 seconds, use C<[2,	680	three retries with individual time-outs of 2, 5 and 5 seconds, use C<[2,
…		…
578	The number of dots (default: C<1>) that a name must have so that the resolver	689	The number of dots (default: C<1>) that a name must have so that the resolver
579	tries to resolve the name without any suffixes first.	690	tries to resolve the name without any suffixes first.
580		691
581	=item max_outstanding => $integer	692	=item max_outstanding => $integer
582		693
583	Most name servers do not handle many parallel requests very well. This option	694	Most name servers do not handle many parallel requests very well. This
584	limits the number of outstanding requests to C<$n> (default: C<10>), that means	695	option limits the number of outstanding requests to C<$integer>
585	if you request more than this many requests, then the additional requests will be queued	696	(default: C<10>), that means if you request more than this many requests,
586	until some other requests have been resolved.	697	then the additional requests will be queued until some other requests have
		698	been resolved.
587		699
588	=item reuse => $seconds	700	=item reuse => $seconds
589		701
590	The number of seconds (default: C<300>) that a query id cannot be re-used	702	The number of seconds (default: C<300>) that a query id cannot be re-used
591	after a timeout. If there as no time-out then query id's can be reused	703	after a timeout. If there was no time-out then query ids can be reused
592	immediately.	704	immediately.
593		705
594	=back	706	=back
595		707
596	=cut	708	=cut
…		…
611	server => [],	723	server => [],
612	timeout => [2, 5, 5],	724	timeout => [2, 5, 5],
613	search => [],	725	search => [],
614	ndots => 1,	726	ndots => 1,
615	max_outstanding => 10,	727	max_outstanding => 10,
616	reuse => 300, # reuse id's after 5 minutes only, if possible	728	reuse => 300,
617	%arg,	729	%arg,
618	reuse_q => [],	730	reuse_q => [],
619	}, $class;	731	}, $class;
620		732
621	# search should default to gethostname's domain	733	# search should default to gethostname's domain
…		…
726	# - the registry thing needs separate code on win32 native vs. cygwin	838	# - the registry thing needs separate code on win32 native vs. cygwin
727	# - the registry layout differs between windows versions	839	# - the registry layout differs between windows versions
728	# - calling windows api functions doesn't work on cygwin	840	# - calling windows api functions doesn't work on cygwin
729	# - ipconfig uses locale-specific messages	841	# - ipconfig uses locale-specific messages
730		842
731	# we use ipconfig parsing because, despite all it's brokenness,	843	# we use ipconfig parsing because, despite all its brokenness,
732	# it seems most stable in practise.	844	# it seems most stable in practise.
733	# for good measure, we append a fallback nameserver to our list.	845	# for good measure, we append a fallback nameserver to our list.
734		846
735	if (open my $fh, "ipconfig /all \|") {	847	if (open my $fh, "ipconfig /all \|") {
736	# parsing strategy: we go through the output and look for	848	# parsing strategy: we go through the output and look for
…		…
745	} elsif (/^\S/ \|\| /^\s[^:]{16,}: /) {	857	} elsif (/^\S/ \|\| /^\s[^:]{16,}: /) {
746	$dns = 0;	858	$dns = 0;
747	}	859	}
748	if ($dns && /^\s(\S+)\s$/) {	860	if ($dns && /^\s(\S+)\s$/) {
749	my $s = $1;	861	my $s = $1;
750	$s =~ s/%\d+(?!\S)//; # get rid of scope id	862	$s =~ s/%\d+(?!\S)//; # get rid of ipv6 scope id
751	if (my $ipn = AnyEvent::Socket::parse_address ($s)) {	863	if (my $ipn = AnyEvent::Socket::parse_address ($s)) {
752	push @{ $self->{server} }, $ipn;	864	push @{ $self->{server} }, $ipn;
753	} else {	865	} else {
754	push @{ $self->{search} }, $s;	866	push @{ $self->{search} }, $s;
755	}	867	}
…		…
769	$self->parse_resolv_conf (<$fh>);	881	$self->parse_resolv_conf (<$fh>);
770	}	882	}
771	}	883	}
772	}	884	}
773		885
		886	=item $resolver->timeout ($timeout, ...)
		887
		888	Sets the timeout values. See the C<timeout> constructor argument (and note
		889	that this method uses the values itself, not an array-reference).
		890
		891	=cut
		892
		893	sub timeout {
		894	my ($self, @timeout) = @_;
		895
		896	$self->{timeout} = \@timeout;
		897	$self->_compile;
		898	}
		899
		900	=item $resolver->max_outstanding ($nrequests)
		901
		902	Sets the maximum number of outstanding requests to C<$nrequests>. See the
		903	C<max_outstanding> constructor argument.
		904
		905	=cut
		906
		907	sub max_outstanding {
		908	my ($self, $max) = @_;
		909
		910	$self->{max_outstanding} = $max;
		911	$self->_scheduler;
		912	}
		913
774	sub _compile {	914	sub _compile {
775	my $self = shift;	915	my $self = shift;
776		916
777	my %search; $self->{search} = [grep 0 < length, grep !$search{$_}++, @{ $self->{search} }];	917	my %search; $self->{search} = [grep 0 < length, grep !$search{$_}++, @{ $self->{search} }];
778	my %server; $self->{server} = [grep 0 < length, grep !$server{$_}++, @{ $self->{server} }];	918	my %server; $self->{server} = [grep 0 < length, grep !$server{$_}++, @{ $self->{server} }];
…		…
862	my ($res) = @_;	1002	my ($res) = @_;
863		1003
864	if ($res->{tc}) {	1004	if ($res->{tc}) {
865	# success, but truncated, so use tcp	1005	# success, but truncated, so use tcp
866	AnyEvent::Socket::tcp_connect (AnyEvent::Socket::format_address ($server), DOMAIN_PORT, sub {	1006	AnyEvent::Socket::tcp_connect (AnyEvent::Socket::format_address ($server), DOMAIN_PORT, sub {
		1007	return unless $do_retry; # some other request could have invalidated us already
		1008
867	my ($fh) = @_	1009	my ($fh) = @_
868	or return &$do_retry;	1010	or return &$do_retry;
869		1011
870	my $handle = new AnyEvent::Handle	1012	my $handle; $handle = new AnyEvent::Handle
871	fh => $fh,	1013	fh => $fh,
		1014	timeout => $timeout,
872	on_error => sub {	1015	on_error => sub {
		1016	undef $handle;
		1017	return unless $do_retry; # some other request could have invalidated us already
873	# failure, try next	1018	# failure, try next
874	&$do_retry;	1019	&$do_retry;
875	};	1020	};
876		1021
877	$handle->push_write (pack "n/a", $req->[0]);	1022	$handle->push_write (pack "n/a", $req->[0]);
878	$handle->push_read (chunk => 2, sub {	1023	$handle->push_read (chunk => 2, sub {
879	$handle->unshift_read (chunk => (unpack "n", $_[1]), sub {	1024	$handle->unshift_read (chunk => (unpack "n", $_[1]), sub {
		1025	undef $handle;
880	$self->_feed ($_[1]);	1026	$self->_feed ($_[1]);
881	});	1027	});
882	});	1028	});
883	shutdown $fh, 1;
884		1029
885	}, sub { $timeout });	1030	}, sub { $timeout });
886		1031
887	} else {	1032	} else {
888	# success	1033	# success
…		…
891	}	1036	}
892	}];	1037	}];
893		1038
894	my $sa = AnyEvent::Socket::pack_sockaddr (DOMAIN_PORT, $server);	1039	my $sa = AnyEvent::Socket::pack_sockaddr (DOMAIN_PORT, $server);
895		1040
896	my $fh = (Socket::sockaddr_family $sa) == AF_INET	1041	my $fh = AF_INET == Socket::sockaddr_family ($sa)
897	? $self->{fh4} : $self->{fh6}	1042	? $self->{fh4} : $self->{fh6}
898	or return &$do_retry;	1043	or return &$do_retry;
899		1044
900	send $fh, $req->[0], 0, $sa;	1045	send $fh, $req->[0], 0, $sa;
901	};	1046	};
…		…
903	&$do_retry;	1048	&$do_retry;
904	}	1049	}
905		1050
906	sub _scheduler {	1051	sub _scheduler {
907	my ($self) = @_;	1052	my ($self) = @_;
		1053
		1054	no strict 'refs';
908		1055
909	$NOW = time;	1056	$NOW = time;
910		1057
911	# first clear id reuse queue	1058	# first clear id reuse queue
912	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }	1059	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }
…		…
921	$self->_scheduler;	1068	$self->_scheduler;
922	});	1069	});
923	last;	1070	last;
924	}	1071	}
925		1072
926	my $req = shift @{ $self->{queue} }	1073	if (my $req = shift @{ $self->{queue} }) {
927	or last;	1074	# found a request in the queue, execute it
928
929	while () {	1075	while () {
930	$req->[2] = int rand 65536;	1076	$req->[2] = int rand 65536;
931	last unless exists $self->{id}{$req->[2]};	1077	last unless exists $self->{id}{$req->[2]};
		1078	}
		1079
		1080	++$self->{outstanding};
		1081	$self->{id}{$req->[2]} = 1;
		1082	substr $req->[0], 0, 2, pack "n", $req->[2];
		1083
		1084	$self->_exec ($req);
		1085
		1086	} elsif (my $cb = shift @{ $self->{wait} }) {
		1087	# found a wait_for_slot callback, call that one first
		1088	$cb->($self);
		1089
		1090	} else {
		1091	# nothing to do, just exit
		1092	last;
932	}	1093	}
933
934	++$self->{outstanding};
935	$self->{id}{$req->[2]} = 1;
936	substr $req->[0], 0, 2, pack "n", $req->[2];
937
938	$self->_exec ($req);
939	}	1094	}
940	}	1095	}
941		1096
942	=item $resolver->request ($req, $cb->($res))	1097	=item $resolver->request ($req, $cb->($res))
943		1098
		1099	This is the main low-level workhorse for sending DNS requests.
		1100
944	Sends a single request (a hash-ref formated as specified for	1101	This function sends a single request (a hash-ref formated as specified
945	C<dns_pack>) to the configured nameservers including	1102	for C<dns_pack>) to the configured nameservers in turn until it gets a
		1103	response. It handles timeouts, retries and automatically falls back to
		1104	virtual circuit mode (TCP) when it receives a truncated reply.
		1105
946	retries. Calls the callback with the decoded response packet if a reply	1106	Calls the callback with the decoded response packet if a reply was
947	was received, or no arguments on timeout.	1107	received, or no arguments in case none of the servers answered.
948		1108
949	=cut	1109	=cut
950		1110
951	sub request($$) {	1111	sub request($$) {
952	my ($self, $req, $cb) = @_;	1112	my ($self, $req, $cb) = @_;
…		…
955	$self->_scheduler;	1115	$self->_scheduler;
956	}	1116	}
957		1117
958	=item $resolver->resolve ($qname, $qtype, %options, $cb->($rcode, @rr))	1118	=item $resolver->resolve ($qname, $qtype, %options, $cb->($rcode, @rr))
959		1119
960	Queries the DNS for the given domain name C<$qname> of type C<$qtype> (a	1120	Queries the DNS for the given domain name C<$qname> of type C<$qtype>.
961	qtype of "*" is supported and means "any").	1121
		1122	A C<$qtype> is either a numerical query type (e.g. C<1> for A records) or
		1123	a lowercase name (you have to look at the source to see which aliases are
		1124	supported, but all types from RFC 1035, C<aaaa>, C<srv>, C<spf> and a few
		1125	more are known to this module). A C<$qtype> of "*" is supported and means
		1126	"any" record type.
962		1127
963	The callback will be invoked with a list of matching result records or	1128	The callback will be invoked with a list of matching result records or
964	none on any error or if the name could not be found.	1129	none on any error or if the name could not be found.
965		1130
966	CNAME chains (although illegal) are followed up to a length of 8.	1131	CNAME chains (although illegal) are followed up to a length of 10.
		1132
		1133	The callback will be invoked with an result code in string form (noerror,
		1134	formerr, servfail, nxdomain, notimp, refused and so on), or numerical
		1135	form if the result code is not supported. The remaining arguments are
		1136	arraryefs of the form C<[$name, $type, $class, @data>], where C<$name> is
		1137	the domain name, C<$type> a type string or number, C<$class> a class name
		1138	and @data is resource-record-dependent data. For C<a> records, this will
		1139	be the textual IPv4 addresses, for C<ns> or C<cname> records this will be
		1140	a domain name, for C<txt> records these are all the strings and so on.
		1141
		1142	All types mentioned in RFC 1035, C<aaaa>, C<srv>, C<naptr> and C<spf> are
		1143	decoded. All resource records not known to this module will have
		1144	the raw C<rdata> field as fourth entry.
967		1145
968	Note that this resolver is just a stub resolver: it requires a name server	1146	Note that this resolver is just a stub resolver: it requires a name server
969	supporting recursive queries, will not do any recursive queries itself and	1147	supporting recursive queries, will not do any recursive queries itself and
970	is not secure when used against an untrusted name server.	1148	is not secure when used against an untrusted name server.
971		1149
…		…
975		1153
976	=item search => [$suffix...]	1154	=item search => [$suffix...]
977		1155
978	Use the given search list (which might be empty), by appending each one	1156	Use the given search list (which might be empty), by appending each one
979	in turn to the C<$qname>. If this option is missing then the configured	1157	in turn to the C<$qname>. If this option is missing then the configured
980	C<ndots> and C<search> define its value. If the C<$qname> ends in a dot,	1158	C<ndots> and C<search> values define its value (depending on C<ndots>, the
981	then the searchlist will be ignored.	1159	empty suffix will be prepended or appended to that C<search> value). If
		1160	the C<$qname> ends in a dot, then the searchlist will be ignored.
982		1161
983	=item accept => [$type...]	1162	=item accept => [$type...]
984		1163
985	Lists the acceptable result types: only result types in this set will be	1164	Lists the acceptable result types: only result types in this set will be
986	accepted and returned. The default includes the C<$qtype> and nothing	1165	accepted and returned. The default includes the C<$qtype> and nothing
987	else.	1166	else. If this list includes C<cname>, then CNAME-chains will not be
		1167	followed (because you asked for the CNAME record).
988		1168
989	=item class => "class"	1169	=item class => "class"
990		1170
991	Specify the query class ("in" for internet, "ch" for chaosnet and "hs" for	1171	Specify the query class ("in" for internet, "ch" for chaosnet and "hs" for
992	hesiod are the only ones making sense). The default is "in", of course.	1172	hesiod are the only ones making sense). The default is "in", of course.
993		1173
994	=back	1174	=back
995		1175
996	Examples:	1176	Examples:
997		1177
998	$res->resolve ("ruth.plan9.de", "a", sub {	1178	# full example, you can paste this into perl:
999	warn Dumper [@_];	1179	use Data::Dumper;
1000	});	1180	use AnyEvent::DNS;
		1181	AnyEvent::DNS::resolver->resolve (
		1182	"google.com", "*", my $cv = AnyEvent->condvar);
		1183	warn Dumper [$cv->recv];
1001		1184
		1185	# shortened result:
1002	[	1186	# [
		1187	# [ 'google.com', 'soa', 'in', 'ns1.google.com', 'dns-admin.google.com',
		1188	# 2008052701, 7200, 1800, 1209600, 300 ],
1003	[	1189	# [
1004	'ruth.schmorp.de',	1190	# 'google.com', 'txt', 'in',
1005	'a',	1191	# 'v=spf1 include:_netblocks.google.com ~all'
1006	'in',	1192	# ],
1007	'129.13.162.95'	1193	# [ 'google.com', 'a', 'in', '64.233.187.99' ],
		1194	# [ 'google.com', 'mx', 'in', 10, 'smtp2.google.com' ],
		1195	# [ 'google.com', 'ns', 'in', 'ns2.google.com' ],
1008	]	1196	# ]
		1197
		1198	# resolve a records:
		1199	$res->resolve ("ruth.plan9.de", "a", sub { warn Dumper [@_] });
		1200
		1201	# result:
		1202	# [
		1203	# [ 'ruth.schmorp.de', 'a', 'in', '129.13.162.95' ]
1009	]	1204	# ]
1010		1205
		1206	# resolve any records, but return only a and aaaa records:
1011	$res->resolve ("test1.laendle", "*",	1207	$res->resolve ("test1.laendle", "*",
1012	accept => ["a", "aaaa"],	1208	accept => ["a", "aaaa"],
1013	sub {	1209	sub {
1014	warn Dumper [@_];	1210	warn Dumper [@_];
1015	}	1211	}
1016	);	1212	);
1017		1213
1018	[	1214	# result:
1019	[	1215	# [
1020	'test1.laendle',	1216	# [ 'test1.laendle', 'a', 'in', '10.0.0.255' ],
1021	'a',	1217	# [ 'test1.laendle', 'aaaa', 'in', '3ffe:1900:4545:0002:0240:0000:0000:f7e1' ]
1022	'in',
1023	'10.0.0.255'
1024	],
1025	[
1026	'test1.laendle',
1027	'aaaa',
1028	'in',
1029	'3ffe:1900:4545:0002:0240:0000:0000:f7e1'
1030	]	1218	# ]
1031	]
1032		1219
1033	=cut	1220	=cut
1034		1221
1035	sub resolve($%) {	1222	sub resolve($%) {
1036	my $cb = pop;	1223	my $cb = pop;
…		…
1056	$do_search = sub {	1243	$do_search = sub {
1057	@search	1244	@search
1058	or (undef $do_search), (undef $do_req), return $cb->();	1245	or (undef $do_search), (undef $do_req), return $cb->();
1059		1246
1060	(my $name = lc "$qname." . shift @search) =~ s/\.$//;	1247	(my $name = lc "$qname." . shift @search) =~ s/\.$//;
1061	my $depth = 2;	1248	my $depth = 10;
1062		1249
1063	# advance in cname-chain	1250	# advance in cname-chain
1064	$do_req = sub {	1251	$do_req = sub {
1065	$self->request ({	1252	$self->request ({
1066	rd => 1,	1253	rd => 1,
…		…
1104	};	1291	};
1105		1292
1106	$do_search->();	1293	$do_search->();
1107	}	1294	}
1108		1295
		1296	=item $resolver->wait_for_slot ($cb->($resolver))
		1297
		1298	Wait until a free request slot is available and call the callback with the
		1299	resolver object.
		1300
		1301	A request slot is used each time a request is actually sent to the
		1302	nameservers: There are never more than C<max_outstanding> of them.
		1303
		1304	Although you can submit more requests (they will simply be queued until
		1305	a request slot becomes available), sometimes, usually for rate-limiting
		1306	purposes, it is useful to instead wait for a slot before generating the
		1307	request (or simply to know when the request load is low enough so one can
		1308	submit requests again).
		1309
		1310	This is what this method does: The callback will be called when submitting
		1311	a DNS request will not result in that request being queued. The callback
		1312	may or may not generate any requests in response.
		1313
		1314	Note that the callback will only be invoked when the request queue is
		1315	empty, so this does not play well if somebody else keeps the request queue
		1316	full at all times.
		1317
		1318	=cut
		1319
		1320	sub wait_for_slot {
		1321	my ($self, $cb) = @_;
		1322
		1323	push @{ $self->{wait} }, $cb;
		1324	$self->_scheduler;
		1325	}
		1326
1109	use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end	1327	use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end
1110		1328
1111	1;	1329	1;
1112		1330
1113	=back	1331	=back
1114		1332
1115	=head1 AUTHOR	1333	=head1 AUTHOR
1116		1334
1117	Marc Lehmann <schmorp@schmorp.de>	1335	Marc Lehmann <schmorp@schmorp.de>
1118	http://home.schmorp.de/	1336	http://home.schmorp.de/
1119		1337
1120	=cut	1338	=cut
1121		1339

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.38 by root, Thu May 29 01:46:56 2008 UTC vs. Revision 1.61 by root, Wed Jun 4 09:55:16 2008 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.38 by root, Thu May 29 01:46:56 2008 UTC vs.
Revision 1.61 by root, Wed Jun 4 09:55:16 2008 UTC