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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.42 by root, Thu May 29 06:17:52 2008 UTC vs.
Revision 1.90 by root, Wed May 6 03:45:27 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.4;
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
…		…
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;
…		…
581	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
582	tries to resolve the name without any suffixes first.	693	tries to resolve the name without any suffixes first.
583		694
584	=item max_outstanding => $integer	695	=item max_outstanding => $integer
585		696
586	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
587	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>
588	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,
589	until some other requests have been resolved.	700	then the additional requests will be queued until some other requests have
		701	been resolved.
590		702
591	=item reuse => $seconds	703	=item reuse => $seconds
592		704
593	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
594	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
595	immediately.	707	immediately.
596		708
597	=back	709	=back
598		710
599	=cut	711	=cut
600		712
601	sub new {	713	sub new {
602	my ($class, %arg) = @_;	714	my ($class, %arg) = @_;
603
604	# try to create a ipv4 and an ipv6 socket
605	# only fail when we cnanot create either
606
607	socket my $fh4, AF_INET , &Socket::SOCK_DGRAM, 0;
608	socket my $fh6, AF_INET6, &Socket::SOCK_DGRAM, 0;
609
610	$fh4 \|\| $fh6
611	or Carp::croak "unable to create either an IPv6 or an IPv4 socket";
612		715
613	my $self = bless {	716	my $self = bless {
614	server => [],	717	server => [],
615	timeout => [2, 5, 5],	718	timeout => [2, 5, 5],
616	search => [],	719	search => [],
617	ndots => 1,	720	ndots => 1,
618	max_outstanding => 10,	721	max_outstanding => 10,
619	reuse => 300, # reuse id's after 5 minutes only, if possible	722	reuse => 300,
620	%arg,	723	%arg,
621	reuse_q => [],	724	reuse_q => [],
622	}, $class;	725	}, $class;
623		726
624	# search should default to gethostname's domain	727	# search should default to gethostname's domain
625	# but perl lacks a good posix module	728	# but perl lacks a good posix module
626		729
		730	# try to create an ipv4 and an ipv6 socket
		731	# only fail when we cannot create either
		732	my $got_socket;
		733
627	Scalar::Util::weaken (my $wself = $self);	734	Scalar::Util::weaken (my $wself = $self);
628		735
629	if ($fh4) {	736	if (socket my $fh4, AF_INET , &Socket::SOCK_DGRAM, 0) {
		737	++$got_socket;
		738
630	AnyEvent::Util::fh_nonblocking $fh4, 1;	739	AnyEvent::Util::fh_nonblocking $fh4, 1;
631	$self->{fh4} = $fh4;	740	$self->{fh4} = $fh4;
632	$self->{rw4} = AnyEvent->io (fh => $fh4, poll => "r", cb => sub {	741	$self->{rw4} = AnyEvent->io (fh => $fh4, poll => "r", cb => sub {
633	if (my $peer = recv $fh4, my $pkt, MAX_PKT, 0) {	742	if (my $peer = recv $fh4, my $pkt, MAX_PKT, 0) {
634	$wself->_recv ($pkt, $peer);	743	$wself->_recv ($pkt, $peer);
635	}	744	}
636	});	745	});
637	}	746	}
638		747
639	if ($fh6) {	748	if (AF_INET6 && socket my $fh6, AF_INET6, &Socket::SOCK_DGRAM, 0) {
		749	++$got_socket;
		750
640	$self->{fh6} = $fh6;	751	$self->{fh6} = $fh6;
641	AnyEvent::Util::fh_nonblocking $fh6, 1;	752	AnyEvent::Util::fh_nonblocking $fh6, 1;
642	$self->{rw6} = AnyEvent->io (fh => $fh6, poll => "r", cb => sub {	753	$self->{rw6} = AnyEvent->io (fh => $fh6, poll => "r", cb => sub {
643	if (my $peer = recv $fh6, my $pkt, MAX_PKT, 0) {	754	if (my $peer = recv $fh6, my $pkt, MAX_PKT, 0) {
644	$wself->_recv ($pkt, $peer);	755	$wself->_recv ($pkt, $peer);
645	}	756	}
646	});	757	});
647	}	758	}
		759
		760	$got_socket
		761	or Carp::croak "unable to create either an IPv4 or an IPv6 socket";
648		762
649	$self->_compile;	763	$self->_compile;
650		764
651	$self	765	$self
652	}	766	}
…		…
729	# - the registry thing needs separate code on win32 native vs. cygwin	843	# - the registry thing needs separate code on win32 native vs. cygwin
730	# - the registry layout differs between windows versions	844	# - the registry layout differs between windows versions
731	# - calling windows api functions doesn't work on cygwin	845	# - calling windows api functions doesn't work on cygwin
732	# - ipconfig uses locale-specific messages	846	# - ipconfig uses locale-specific messages
733		847
734	# we use ipconfig parsing because, despite all it's brokenness,	848	# we use ipconfig parsing because, despite all its brokenness,
735	# it seems most stable in practise.	849	# it seems most stable in practise.
736	# for good measure, we append a fallback nameserver to our list.	850	# for good measure, we append a fallback nameserver to our list.
737		851
738	if (open my $fh, "ipconfig /all \|") {	852	if (open my $fh, "ipconfig /all \|") {
739	# parsing strategy: we go through the output and look for	853	# parsing strategy: we go through the output and look for
…		…
748	} elsif (/^\S/ \|\| /^\s[^:]{16,}: /) {	862	} elsif (/^\S/ \|\| /^\s[^:]{16,}: /) {
749	$dns = 0;	863	$dns = 0;
750	}	864	}
751	if ($dns && /^\s(\S+)\s$/) {	865	if ($dns && /^\s(\S+)\s$/) {
752	my $s = $1;	866	my $s = $1;
753	$s =~ s/%\d+(?!\S)//; # get rid of scope id	867	$s =~ s/%\d+(?!\S)//; # get rid of ipv6 scope id
754	if (my $ipn = AnyEvent::Socket::parse_address ($s)) {	868	if (my $ipn = AnyEvent::Socket::parse_address ($s)) {
755	push @{ $self->{server} }, $ipn;	869	push @{ $self->{server} }, $ipn;
756	} else {	870	} else {
757	push @{ $self->{search} }, $s;	871	push @{ $self->{search} }, $s;
758	}	872	}
…		…
772	$self->parse_resolv_conf (<$fh>);	886	$self->parse_resolv_conf (<$fh>);
773	}	887	}
774	}	888	}
775	}	889	}
776		890
		891	=item $resolver->timeout ($timeout, ...)
		892
		893	Sets the timeout values. See the C<timeout> constructor argument (and note
		894	that this method uses the values itself, not an array-reference).
		895
		896	=cut
		897
		898	sub timeout {
		899	my ($self, @timeout) = @_;
		900
		901	$self->{timeout} = \@timeout;
		902	$self->_compile;
		903	}
		904
		905	=item $resolver->max_outstanding ($nrequests)
		906
		907	Sets the maximum number of outstanding requests to C<$nrequests>. See the
		908	C<max_outstanding> constructor argument.
		909
		910	=cut
		911
		912	sub max_outstanding {
		913	my ($self, $max) = @_;
		914
		915	$self->{max_outstanding} = $max;
		916	$self->_scheduler;
		917	}
		918
777	sub _compile {	919	sub _compile {
778	my $self = shift;	920	my $self = shift;
779		921
780	my %search; $self->{search} = [grep 0 < length, grep !$search{$_}++, @{ $self->{search} }];	922	my %search; $self->{search} = [grep 0 < length, grep !$search{$_}++, @{ $self->{search} }];
781	my %server; $self->{server} = [grep 0 < length, grep !$server{$_}++, @{ $self->{server} }];	923	my %server; $self->{server} = [grep 0 < length, grep !$server{$_}++, @{ $self->{server} }];
…		…
858		1000
859	$self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {	1001	$self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {
860	$NOW = time;	1002	$NOW = time;
861		1003
862	# timeout, try next	1004	# timeout, try next
863	&$do_retry;	1005	&$do_retry if $do_retry;
864	}), sub {	1006	}), sub {
865	my ($res) = @_;	1007	my ($res) = @_;
866		1008
867	if ($res->{tc}) {	1009	if ($res->{tc}) {
868	# success, but truncated, so use tcp	1010	# success, but truncated, so use tcp
869	AnyEvent::Socket::tcp_connect (AnyEvent::Socket::format_address ($server), DOMAIN_PORT, sub {	1011	AnyEvent::Socket::tcp_connect (AnyEvent::Socket::format_address ($server), DOMAIN_PORT, sub {
		1012	return unless $do_retry; # some other request could have invalidated us already
		1013
870	my ($fh) = @_	1014	my ($fh) = @_
871	or return &$do_retry;	1015	or return &$do_retry;
872		1016
873	my $handle = new AnyEvent::Handle	1017	my $handle; $handle = new AnyEvent::Handle
874	fh => $fh,	1018	fh => $fh,
		1019	timeout => $timeout,
875	on_error => sub {	1020	on_error => sub {
		1021	undef $handle;
		1022	return unless $do_retry; # some other request could have invalidated us already
876	# failure, try next	1023	# failure, try next
877	&$do_retry;	1024	&$do_retry;
878	};	1025	};
879		1026
880	$handle->push_write (pack "n/a", $req->[0]);	1027	$handle->push_write (pack "n/a", $req->[0]);
881	$handle->push_read (chunk => 2, sub {	1028	$handle->push_read (chunk => 2, sub {
882	$handle->unshift_read (chunk => (unpack "n", $_[1]), sub {	1029	$handle->unshift_read (chunk => (unpack "n", $_[1]), sub {
		1030	undef $handle;
883	$self->_feed ($_[1]);	1031	$self->_feed ($_[1]);
884	});	1032	});
885	});	1033	});
886	shutdown $fh, 1;
887		1034
888	}, sub { $timeout });	1035	}, sub { $timeout });
889		1036
890	} else {	1037	} else {
891	# success	1038	# success
…		…
907	}	1054	}
908		1055
909	sub _scheduler {	1056	sub _scheduler {
910	my ($self) = @_;	1057	my ($self) = @_;
911		1058
		1059	no strict 'refs';
		1060
912	$NOW = time;	1061	$NOW = time;
913		1062
914	# first clear id reuse queue	1063	# first clear id reuse queue
915	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }	1064	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }
916	while @{ $self->{reuse_q} } && $self->{reuse_q}[0][0] <= $NOW;	1065	while @{ $self->{reuse_q} } && $self->{reuse_q}[0][0] <= $NOW;
…		…
924	$self->_scheduler;	1073	$self->_scheduler;
925	});	1074	});
926	last;	1075	last;
927	}	1076	}
928		1077
929	my $req = shift @{ $self->{queue} }	1078	if (my $req = shift @{ $self->{queue} }) {
930	or last;	1079	# found a request in the queue, execute it
931
932	while () {	1080	while () {
933	$req->[2] = int rand 65536;	1081	$req->[2] = int rand 65536;
934	last unless exists $self->{id}{$req->[2]};	1082	last unless exists $self->{id}{$req->[2]};
		1083	}
		1084
		1085	++$self->{outstanding};
		1086	$self->{id}{$req->[2]} = 1;
		1087	substr $req->[0], 0, 2, pack "n", $req->[2];
		1088
		1089	$self->_exec ($req);
		1090
		1091	} elsif (my $cb = shift @{ $self->{wait} }) {
		1092	# found a wait_for_slot callback, call that one first
		1093	$cb->($self);
		1094
		1095	} else {
		1096	# nothing to do, just exit
		1097	last;
935	}	1098	}
936
937	++$self->{outstanding};
938	$self->{id}{$req->[2]} = 1;
939	substr $req->[0], 0, 2, pack "n", $req->[2];
940
941	$self->_exec ($req);
942	}	1099	}
943	}	1100	}
944		1101
945	=item $resolver->request ($req, $cb->($res))	1102	=item $resolver->request ($req, $cb->($res))
946		1103
		1104	This is the main low-level workhorse for sending DNS requests.
		1105
947	Sends a single request (a hash-ref formated as specified for	1106	This function sends a single request (a hash-ref formated as specified
948	C<dns_pack>) to the configured nameservers including	1107	for C<dns_pack>) to the configured nameservers in turn until it gets a
		1108	response. It handles timeouts, retries and automatically falls back to
		1109	virtual circuit mode (TCP) when it receives a truncated reply.
		1110
949	retries. Calls the callback with the decoded response packet if a reply	1111	Calls the callback with the decoded response packet if a reply was
950	was received, or no arguments on timeout.	1112	received, or no arguments in case none of the servers answered.
951		1113
952	=cut	1114	=cut
953		1115
954	sub request($$) {	1116	sub request($$) {
955	my ($self, $req, $cb) = @_;	1117	my ($self, $req, $cb) = @_;
956		1118
957	push @{ $self->{queue} }, [dns_pack $req, $cb];	1119	push @{ $self->{queue} }, [dns_pack $req, $cb];
958	$self->_scheduler;	1120	$self->_scheduler;
959	}	1121	}
960		1122
961	=item $resolver->resolve ($qname, $qtype, %options, $cb->($rcode, @rr))	1123	=item $resolver->resolve ($qname, $qtype, %options, $cb->(@rr))
962		1124
963	Queries the DNS for the given domain name C<$qname> of type C<$qtype> (a	1125	Queries the DNS for the given domain name C<$qname> of type C<$qtype>.
964	qtype of "*" is supported and means "any").	1126
		1127	A C<$qtype> is either a numerical query type (e.g. C<1> for A records) or
		1128	a lowercase name (you have to look at the source to see which aliases are
		1129	supported, but all types from RFC 1035, C<aaaa>, C<srv>, C<spf> and a few
		1130	more are known to this module). A C<$qtype> of "*" is supported and means
		1131	"any" record type.
965		1132
966	The callback will be invoked with a list of matching result records or	1133	The callback will be invoked with a list of matching result records or
967	none on any error or if the name could not be found.	1134	none on any error or if the name could not be found.
968		1135
969	CNAME chains (although illegal) are followed up to a length of 8.	1136	CNAME chains (although illegal) are followed up to a length of 10.
		1137
		1138	The callback will be invoked with arraryefs of the form C<[$name, $type,
		1139	$class, @data>], where C<$name> is the domain name, C<$type> a type string
		1140	or number, C<$class> a class name and @data is resource-record-dependent
		1141	data. For C<a> records, this will be the textual IPv4 addresses, for C<ns>
		1142	or C<cname> records this will be a domain name, for C<txt> records these
		1143	are all the strings and so on.
		1144
		1145	All types mentioned in RFC 1035, C<aaaa>, C<srv>, C<naptr> and C<spf> are
		1146	decoded. All resource records not known to this module will have
		1147	the raw C<rdata> field as fourth entry.
970		1148
971	Note that this resolver is just a stub resolver: it requires a name server	1149	Note that this resolver is just a stub resolver: it requires a name server
972	supporting recursive queries, will not do any recursive queries itself and	1150	supporting recursive queries, will not do any recursive queries itself and
973	is not secure when used against an untrusted name server.	1151	is not secure when used against an untrusted name server.
974		1152
…		…
978		1156
979	=item search => [$suffix...]	1157	=item search => [$suffix...]
980		1158
981	Use the given search list (which might be empty), by appending each one	1159	Use the given search list (which might be empty), by appending each one
982	in turn to the C<$qname>. If this option is missing then the configured	1160	in turn to the C<$qname>. If this option is missing then the configured
983	C<ndots> and C<search> define its value. If the C<$qname> ends in a dot,	1161	C<ndots> and C<search> values define its value (depending on C<ndots>, the
984	then the searchlist will be ignored.	1162	empty suffix will be prepended or appended to that C<search> value). If
		1163	the C<$qname> ends in a dot, then the searchlist will be ignored.
985		1164
986	=item accept => [$type...]	1165	=item accept => [$type...]
987		1166
988	Lists the acceptable result types: only result types in this set will be	1167	Lists the acceptable result types: only result types in this set will be
989	accepted and returned. The default includes the C<$qtype> and nothing	1168	accepted and returned. The default includes the C<$qtype> and nothing
990	else.	1169	else. If this list includes C<cname>, then CNAME-chains will not be
		1170	followed (because you asked for the CNAME record).
991		1171
992	=item class => "class"	1172	=item class => "class"
993		1173
994	Specify the query class ("in" for internet, "ch" for chaosnet and "hs" for	1174	Specify the query class ("in" for internet, "ch" for chaosnet and "hs" for
995	hesiod are the only ones making sense). The default is "in", of course.	1175	hesiod are the only ones making sense). The default is "in", of course.
996		1176
997	=back	1177	=back
998		1178
999	Examples:	1179	Examples:
1000		1180
1001	$res->resolve ("ruth.plan9.de", "a", sub {	1181	# full example, you can paste this into perl:
1002	warn Dumper [@_];	1182	use Data::Dumper;
1003	});	1183	use AnyEvent::DNS;
		1184	AnyEvent::DNS::resolver->resolve (
		1185	"google.com", "*", my $cv = AnyEvent->condvar);
		1186	warn Dumper [$cv->recv];
1004		1187
		1188	# shortened result:
1005	[	1189	# [
		1190	# [ 'google.com', 'soa', 'in', 'ns1.google.com', 'dns-admin.google.com',
		1191	# 2008052701, 7200, 1800, 1209600, 300 ],
1006	[	1192	# [
1007	'ruth.schmorp.de',	1193	# 'google.com', 'txt', 'in',
1008	'a',	1194	# 'v=spf1 include:_netblocks.google.com ~all'
1009	'in',	1195	# ],
1010	'129.13.162.95'	1196	# [ 'google.com', 'a', 'in', '64.233.187.99' ],
		1197	# [ 'google.com', 'mx', 'in', 10, 'smtp2.google.com' ],
		1198	# [ 'google.com', 'ns', 'in', 'ns2.google.com' ],
1011	]	1199	# ]
		1200
		1201	# resolve a records:
		1202	$res->resolve ("ruth.plan9.de", "a", sub { warn Dumper [@_] });
		1203
		1204	# result:
		1205	# [
		1206	# [ 'ruth.schmorp.de', 'a', 'in', '129.13.162.95' ]
1012	]	1207	# ]
1013		1208
		1209	# resolve any records, but return only a and aaaa records:
1014	$res->resolve ("test1.laendle", "*",	1210	$res->resolve ("test1.laendle", "*",
1015	accept => ["a", "aaaa"],	1211	accept => ["a", "aaaa"],
1016	sub {	1212	sub {
1017	warn Dumper [@_];	1213	warn Dumper [@_];
1018	}	1214	}
1019	);	1215	);
1020		1216
1021	[	1217	# result:
1022	[	1218	# [
1023	'test1.laendle',	1219	# [ 'test1.laendle', 'a', 'in', '10.0.0.255' ],
1024	'a',	1220	# [ 'test1.laendle', 'aaaa', 'in', '3ffe:1900:4545:0002:0240:0000:0000:f7e1' ]
1025	'in',
1026	'10.0.0.255'
1027	],
1028	[
1029	'test1.laendle',
1030	'aaaa',
1031	'in',
1032	'3ffe:1900:4545:0002:0240:0000:0000:f7e1'
1033	]	1221	# ]
1034	]
1035		1222
1036	=cut	1223	=cut
1037		1224
1038	sub resolve($%) {	1225	sub resolve($%) {
1039	my $cb = pop;	1226	my $cb = pop;
…		…
1059	$do_search = sub {	1246	$do_search = sub {
1060	@search	1247	@search
1061	or (undef $do_search), (undef $do_req), return $cb->();	1248	or (undef $do_search), (undef $do_req), return $cb->();
1062		1249
1063	(my $name = lc "$qname." . shift @search) =~ s/\.$//;	1250	(my $name = lc "$qname." . shift @search) =~ s/\.$//;
1064	my $depth = 2;	1251	my $depth = 10;
1065		1252
1066	# advance in cname-chain	1253	# advance in cname-chain
1067	$do_req = sub {	1254	$do_req = sub {
1068	$self->request ({	1255	$self->request ({
1069	rd => 1,	1256	rd => 1,
…		…
1107	};	1294	};
1108		1295
1109	$do_search->();	1296	$do_search->();
1110	}	1297	}
1111		1298
		1299	=item $resolver->wait_for_slot ($cb->($resolver))
		1300
		1301	Wait until a free request slot is available and call the callback with the
		1302	resolver object.
		1303
		1304	A request slot is used each time a request is actually sent to the
		1305	nameservers: There are never more than C<max_outstanding> of them.
		1306
		1307	Although you can submit more requests (they will simply be queued until
		1308	a request slot becomes available), sometimes, usually for rate-limiting
		1309	purposes, it is useful to instead wait for a slot before generating the
		1310	request (or simply to know when the request load is low enough so one can
		1311	submit requests again).
		1312
		1313	This is what this method does: The callback will be called when submitting
		1314	a DNS request will not result in that request being queued. The callback
		1315	may or may not generate any requests in response.
		1316
		1317	Note that the callback will only be invoked when the request queue is
		1318	empty, so this does not play well if somebody else keeps the request queue
		1319	full at all times.
		1320
		1321	=cut
		1322
		1323	sub wait_for_slot {
		1324	my ($self, $cb) = @_;
		1325
		1326	push @{ $self->{wait} }, $cb;
		1327	$self->_scheduler;
		1328	}
		1329
1112	use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end	1330	use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end
1113		1331
1114	1;	1332	1;
1115		1333
1116	=back	1334	=back
1117		1335
1118	=head1 AUTHOR	1336	=head1 AUTHOR
1119		1337
1120	Marc Lehmann <schmorp@schmorp.de>	1338	Marc Lehmann <schmorp@schmorp.de>
1121	http://home.schmorp.de/	1339	http://home.schmorp.de/
1122		1340
1123	=cut	1341	=cut
1124		1342

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.42 by root, Thu May 29 06:17:52 2008 UTC vs. Revision 1.90 by root, Wed May 6 03:45:27 2009 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.42 by root, Thu May 29 06:17:52 2008 UTC vs.
Revision 1.90 by root, Wed May 6 03:45:27 2009 UTC