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

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

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.37 by root, Thu May 29 00:30:15 2008 UTC vs. Revision 1.64 by elmex, Thu Jun 5 07:11:40 2008 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.37 by root, Thu May 29 00:30:15 2008 UTC vs.
Revision 1.64 by elmex, Thu Jun 5 07:11:40 2008 UTC