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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.39 by root, Thu May 29 03:45:37 2008 UTC vs.
Revision 1.96 by root, Mon Jun 29 21:00:32 2009 UTC

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

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.39 by root, Thu May 29 03:45:37 2008 UTC vs. Revision 1.96 by root, Mon Jun 29 21:00:32 2009 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.39 by root, Thu May 29 03:45:37 2008 UTC vs.
Revision 1.96 by root, Mon Jun 29 21:00:32 2009 UTC