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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.4 by root, Fri May 23 04:10:40 2008 UTC vs.
Revision 1.38 by root, Thu May 29 01:46:56 2008 UTC

…		…
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
		9	my $cv = AnyEvent->condvar;
		10	AnyEvent::DNS::a "www.google.de", $cv;
		11	# ... later
		12	my @addrs = $cv->recv;
8		13
9	=head1 DESCRIPTION	14	=head1 DESCRIPTION
10		15
11	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
12	as a fully asynchronous and high-performance pure-perl stub resolver.	17	as a fully asynchronous and high-performance pure-perl stub resolver.
13		18
		19	The stub resolver supports DNS over UDP, optional EDNS0 support for up to
		20	4kiB datagrams and automatically falls back to virtual circuit mode for
		21	large responses.
		22
14	=head2 CONVENIENCE FUNCTIONS	23	=head2 CONVENIENCE FUNCTIONS
15		24
16	=over 4	25	=over 4
17		26
18	=cut	27	=cut
…		…
20	package AnyEvent::DNS;	29	package AnyEvent::DNS;
21		30
22	no warnings;	31	no warnings;
23	use strict;	32	use strict;
24		33
		34	use Socket qw(AF_INET SOCK_DGRAM SOCK_STREAM);
		35
25	use AnyEvent::Util ();	36	use AnyEvent ();
		37	use AnyEvent::Handle ();
		38	use AnyEvent::Util qw(AF_INET6);
26		39
27	=item AnyEvent::DNS::addr $node, $service, $family, $type, $cb->(@addrs)	40	our @DNS_FALLBACK = (v208.67.220.220, v208.67.222.222);
28
29	NOT YET IMPLEMENTED
30
31	Tries to resolve the given nodename and service name into sockaddr
32	structures usable to connect to this node and service in a
33	protocol-independent way. It works similarly to the getaddrinfo posix
34	function.
35
36	Example:
37
38	AnyEvent::DNS::addr "google.com", "http", AF_UNSPEC, SOCK_STREAM, sub { ... };
39		41
40	=item AnyEvent::DNS::a $domain, $cb->(@addrs)	42	=item AnyEvent::DNS::a $domain, $cb->(@addrs)
41		43
42	Tries to resolve the given domain to IPv4 address(es).	44	Tries to resolve the given domain to IPv4 address(es).
		45
		46	=item AnyEvent::DNS::aaaa $domain, $cb->(@addrs)
		47
		48	Tries to resolve the given domain to IPv6 address(es).
43		49
44	=item AnyEvent::DNS::mx $domain, $cb->(@hostnames)	50	=item AnyEvent::DNS::mx $domain, $cb->(@hostnames)
45		51
46	Tries to resolve the given domain into a sorted (lower preference value	52	Tries to resolve the given domain into a sorted (lower preference value
47	first) list of domain names.	53	first) list of domain names.
…		…
57	=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)	63	=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)
58		64
59	Tries to resolve the given service, protocol and domain name into a list	65	Tries to resolve the given service, protocol and domain name into a list
60	of service records.	66	of service records.
61		67
62	Each srv_rr is an arrayref with the following contents:	68	Each srv_rr is an array reference with the following contents:
63	C<[$priority, $weight, $transport, $target]>.	69	C<[$priority, $weight, $transport, $target]>.
64		70
65	They will be sorted with lowest priority, highest weight first (TODO:	71	They will be sorted with lowest priority, highest weight first (TODO:
66	should use the rfc algorithm to reorder same-priority records for weight).	72	should use the RFC algorithm to reorder same-priority records for weight).
67		73
68	Example:	74	Example:
69		75
70	AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...	76	AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...
71	# @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )	77	# @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )
…		…
73	=item AnyEvent::DNS::ptr $ipv4_or_6, $cb->(@hostnames)	79	=item AnyEvent::DNS::ptr $ipv4_or_6, $cb->(@hostnames)
74		80
75	Tries to reverse-resolve the given IPv4 or IPv6 address (in textual form)	81	Tries to reverse-resolve the given IPv4 or IPv6 address (in textual form)
76	into it's hostname(s).	82	into it's hostname(s).
77		83
78	Requires the Socket6 module for IPv6 support.
79
80	Example:	84	Example:
81		85
82	AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };	86	AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };
83	# => f.root-servers.net	87	# => f.root-servers.net
84		88
		89	=item AnyEvent::DNS::any $domain, $cb->(@rrs)
		90
		91	Tries to resolve the given domain and passes all resource records found to
		92	the callback.
		93
85	=cut	94	=cut
		95
		96	sub MAX_PKT() { 4096 } # max packet size we advertise and accept
		97
		98	sub DOMAIN_PORT() { 53 } # if this changes drop me a note
86		99
87	sub resolver;	100	sub resolver;
88		101
89	sub a($$) {	102	sub a($$) {
90	my ($domain, $cb) = @_;	103	my ($domain, $cb) = @_;
91		104
92	resolver->resolve ($domain => "a", sub {	105	resolver->resolve ($domain => "a", sub {
		106	$cb->(map $_->[3], @_);
		107	});
		108	}
		109
		110	sub aaaa($$) {
		111	my ($domain, $cb) = @_;
		112
		113	resolver->resolve ($domain => "aaaa", sub {
93	$cb->(map $_->[3], @_);	114	$cb->(map $_->[3], @_);
94	});	115	});
95	}	116	}
96		117
97	sub mx($$) {	118	sub mx($$) {
…		…
128	}	149	}
129		150
130	sub ptr($$) {	151	sub ptr($$) {
131	my ($ip, $cb) = @_;	152	my ($ip, $cb) = @_;
132		153
133	my $name;	154	$ip = AnyEvent::Socket::parse_address ($ip)
		155	or return $cb->();
134		156
135	if (AnyEvent::Util::dotted_quad $ip) {	157	my $af = AnyEvent::Socket::address_family ($ip);
		158
		159	if ($af == AF_INET) {
136	$name = join ".", (reverse split /\./, $ip), "in-addr.arpa.";	160	$ip = join ".", (reverse split /\./, $ip), "in-addr.arpa.";
		161	} elsif ($af == AF_INET6) {
		162	$ip = join ".", (reverse split //, unpack "H*", $ip), "ip6.arpa.";
137	} else {	163	} else {
138	require Socket6;	164	return $cb->();
139	$name = join ".",
140	(reverse split //,
141	unpack "H*", Socket6::inet_pton (Socket::AF_INET6, $ip)),
142	"ip6.arpa.";
143	}	165	}
144		166
145	resolver->resolve ($name => "ptr", sub {	167	resolver->resolve ($ip => "ptr", sub {
146	$cb->(map $_->[3], @_);	168	$cb->(map $_->[3], @_);
147	});	169	});
148	}	170	}
149		171
		172	sub any($$) {
		173	my ($domain, $cb) = @_;
		174
		175	resolver->resolve ($domain => "*", $cb);
		176	}
		177
		178	#################################################################################
		179
		180	=back
		181
150	=head2 DNS EN-/DECODING FUNCTIONS	182	=head2 LOW-LEVEL DNS EN-/DECODING FUNCTIONS
151		183
152	=over 4	184	=over 4
153		185
		186	=item $AnyEvent::DNS::EDNS0
		187
		188	This variable decides whether dns_pack automatically enables EDNS0
		189	support. By default, this is disabled (C<0>), unless overridden by
		190	C<$ENV{PERL_ANYEVENT_EDNS0>), but when set to C<1>, AnyEvent::DNS will use
		191	EDNS0 in all requests.
		192
154	=cut	193	=cut
		194
		195	our $EDNS0 = $ENV{PERL_ANYEVENT_EDNS0} * 1; # set to 1 to enable (partial) edns0
155		196
156	our %opcode_id = (	197	our %opcode_id = (
157	query => 0,	198	query => 0,
158	iquery => 1,	199	iquery => 1,
159	status => 2,	200	status => 2,
		201	notify => 4,
		202	update => 5,
160	map +($_ => $_), 3..15	203	map +($_ => $_), 3, 6..15
161	);	204	);
162		205
163	our %opcode_str = reverse %opcode_id;	206	our %opcode_str = reverse %opcode_id;
164		207
165	our %rcode_id = (	208	our %rcode_id = (
166	noerror => 0,	209	noerror => 0,
167	formerr => 1,	210	formerr => 1,
168	servfail => 2,	211	servfail => 2,
169	nxdomain => 3,	212	nxdomain => 3,
170	notimp => 4,	213	notimp => 4,
171	refused => 5,	214	refused => 5,
		215	yxdomain => 6, # Name Exists when it should not [RFC 2136]
		216	yxrrset => 7, # RR Set Exists when it should not [RFC 2136]
		217	nxrrset => 8, # RR Set that should exist does not [RFC 2136]
		218	notauth => 9, # Server Not Authoritative for zone [RFC 2136]
		219	notzone => 10, # Name not contained in zone [RFC 2136]
		220	# EDNS0 16 BADVERS Bad OPT Version [RFC 2671]
		221	# EDNS0 16 BADSIG TSIG Signature Failure [RFC 2845]
		222	# EDNS0 17 BADKEY Key not recognized [RFC 2845]
		223	# EDNS0 18 BADTIME Signature out of time window [RFC 2845]
		224	# EDNS0 19 BADMODE Bad TKEY Mode [RFC 2930]
		225	# EDNS0 20 BADNAME Duplicate key name [RFC 2930]
		226	# EDNS0 21 BADALG Algorithm not supported [RFC 2930]
172	map +($_ => $_), 6..15	227	map +($_ => $_), 11..15
173	);	228	);
174		229
175	our %rcode_str = reverse %rcode_id;	230	our %rcode_str = reverse %rcode_id;
176		231
177	our %type_id = (	232	our %type_id = (
…		…
191	minfo => 14,	246	minfo => 14,
192	mx => 15,	247	mx => 15,
193	txt => 16,	248	txt => 16,
194	aaaa => 28,	249	aaaa => 28,
195	srv => 33,	250	srv => 33,
		251	opt => 41,
		252	spf => 99,
		253	tkey => 249,
		254	tsig => 250,
		255	ixfr => 251,
196	axfr => 252,	256	axfr => 252,
197	mailb => 253,	257	mailb => 253,
198	"*" => 255,	258	"*" => 255,
199	);	259	);
200		260
201	our %type_str = reverse %type_id;	261	our %type_str = reverse %type_id;
202		262
203	our %class_id = (	263	our %class_id = (
204	in => 1,	264	in => 1,
205	ch => 3,	265	ch => 3,
206	hs => 4,	266	hs => 4,
		267	none => 254,
207	"*" => 255,	268	"*" => 255,
208	);	269	);
209		270
210	our %class_str = reverse %class_id;	271	our %class_str = reverse %class_id;
211		272
212	# names MUST have a trailing dot	273	# names MUST have a trailing dot
213	sub _enc_qname($) {	274	sub _enc_name($) {
214	pack "(C/a)*", (split /\./, shift), ""	275	pack "(C/a)", (split /\./, shift), ""
215	}	276	}
216		277
217	sub _enc_qd() {	278	sub _enc_qd() {
218	(_enc_qname $_->[0]) . pack "nn",	279	(_enc_name $_->[0]) . pack "nn",
219	($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}),	280	($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}),
220	($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] \|\| "in"})	281	($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] \|\| "in"})
221	}	282	}
222		283
223	sub _enc_rr() {	284	sub _enc_rr() {
…		…
247	qr => 1,	308	qr => 1,
248	aa => 0,	309	aa => 0,
249	tc => 0,	310	tc => 0,
250	rd => 0,	311	rd => 0,
251	ra => 0,	312	ra => 0,
		313	ad => 0,
		314	cd => 0,
252		315
253	qd => [@rr], # query section	316	qd => [@rr], # query section
254	an => [@rr], # answer section	317	an => [@rr], # answer section
255	ns => [@rr], # authority section	318	ns => [@rr], # authority section
256	ar => [@rr], # additional records section	319	ar => [@rr], # additional records section
…		…
259	=cut	322	=cut
260		323
261	sub dns_pack($) {	324	sub dns_pack($) {
262	my ($req) = @_;	325	my ($req) = @_;
263		326
264	pack "nn nnnn a* a* a* a*",	327	pack "nn nnnn a* a* a* a* a*",
265	$req->{id},	328	$req->{id},
266		329
267	! !$req->{qr} * 0x8000	330	! !$req->{qr} * 0x8000
268	+ $opcode_id{$req->{op}} * 0x0800	331	+ $opcode_id{$req->{op}} * 0x0800
269	+ ! !$req->{aa} * 0x0400	332	+ ! !$req->{aa} * 0x0400
270	+ ! !$req->{tc} * 0x0200	333	+ ! !$req->{tc} * 0x0200
271	+ ! !$req->{rd} * 0x0100	334	+ ! !$req->{rd} * 0x0100
272	+ ! !$req->{ra} * 0x0080	335	+ ! !$req->{ra} * 0x0080
		336	+ ! !$req->{ad} * 0x0020
		337	+ ! !$req->{cd} * 0x0010
273	+ $rcode_id{$req->{rc}} * 0x0001,	338	+ $rcode_id{$req->{rc}} * 0x0001,
274		339
275	scalar @{ $req->{qd} \|\| [] },	340	scalar @{ $req->{qd} \|\| [] },
276	scalar @{ $req->{an} \|\| [] },	341	scalar @{ $req->{an} \|\| [] },
277	scalar @{ $req->{ns} \|\| [] },	342	scalar @{ $req->{ns} \|\| [] },
278	scalar @{ $req->{ar} \|\| [] },	343	$EDNS0 + scalar @{ $req->{ar} \|\| [] }, # include EDNS0 option here
279		344
280	(join "", map _enc_qd, @{ $req->{qd} \|\| [] }),	345	(join "", map _enc_qd, @{ $req->{qd} \|\| [] }),
281	(join "", map _enc_rr, @{ $req->{an} \|\| [] }),	346	(join "", map _enc_rr, @{ $req->{an} \|\| [] }),
282	(join "", map _enc_rr, @{ $req->{ns} \|\| [] }),	347	(join "", map _enc_rr, @{ $req->{ns} \|\| [] }),
283	(join "", map _enc_rr, @{ $req->{ar} \|\| [] });	348	(join "", map _enc_rr, @{ $req->{ar} \|\| [] }),
		349
		350	($EDNS0 ? pack "C nnNn", 0, 41, MAX_PKT, 0, 0 : "") # EDNS0, 4kiB udp payload size
284	}	351	}
285		352
286	our $ofs;	353	our $ofs;
287	our $pkt;	354	our $pkt;
288		355
289	# bitches	356	# bitches
290	sub _dec_qname {	357	sub _dec_name {
291	my @res;	358	my @res;
292	my $redir;	359	my $redir;
293	my $ptr = $ofs;	360	my $ptr = $ofs;
294	my $cnt;	361	my $cnt;
295		362
296	while () {	363	while () {
297	return undef if ++$cnt >= 256; # to avoid DoS attacks	364	return undef if ++$cnt >= 256; # to avoid DoS attacks
298		365
299	my $len = ord substr $pkt, $ptr++, 1;	366	my $len = ord substr $pkt, $ptr++, 1;
300		367
301	if ($len & 0xc0) {	368	if ($len >= 0xc0) {
302	$ptr++;	369	$ptr++;
303	$ofs = $ptr if $ptr > $ofs;	370	$ofs = $ptr if $ptr > $ofs;
304	$ptr = (unpack "n", substr $pkt, $ptr - 2, 2) & 0x3fff;	371	$ptr = (unpack "n", substr $pkt, $ptr - 2, 2) & 0x3fff;
305	} elsif ($len) {	372	} elsif ($len) {
306	push @res, substr $pkt, $ptr, $len;	373	push @res, substr $pkt, $ptr, $len;
…		…
311	}	378	}
312	}	379	}
313	}	380	}
314		381
315	sub _dec_qd {	382	sub _dec_qd {
316	my $qname = _dec_qname;	383	my $qname = _dec_name;
317	my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;	384	my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;
318	[$qname, $type_str{$qt} \|\| $qt, $class_str{$qc} \|\| $qc]	385	[$qname, $type_str{$qt} \|\| $qt, $class_str{$qc} \|\| $qc]
319	}	386	}
320		387
321	our %dec_rr = (	388	our %dec_rr = (
322	1 => sub { Socket::inet_ntoa $_ }, # a	389	1 => sub { join ".", unpack "C4", $_ }, # a
323	2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns	390	2 => sub { local $ofs = $ofs - length; _dec_name }, # ns
324	5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname	391	5 => sub { local $ofs = $ofs - length; _dec_name }, # cname
325	6 => sub {	392	6 => sub {
326	local $ofs = $ofs - length;	393	local $ofs = $ofs - length;
327	my $mname = _dec_qname;	394	my $mname = _dec_name;
328	my $rname = _dec_qname;	395	my $rname = _dec_name;
329	($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)	396	($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)
330	}, # soa	397	}, # soa
331	11 => sub { ((Socket::inet_aton substr $_, 0, 4), unpack "C a*", substr $_, 4) }, # wks	398	11 => sub { ((join ".", unpack "C4", $_), unpack "C a*", substr $_, 4) }, # wks
332	12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr	399	12 => sub { local $ofs = $ofs - length; _dec_name }, # ptr
333	13 => sub { unpack "C/a C/a", $_ },	400	13 => sub { unpack "C/a* C/a*", $_ }, # hinfo
334	15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_qname) }, # mx	401	15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_name) }, # mx
335	16 => sub { unpack "C/a", $_ }, # txt	402	16 => sub { unpack "(C/a)", $_ }, # txt
336	28 => sub { sprintf "%04x:%04x:%04x:%04x:%04x:%04x:%04x:%04x", unpack "n8" }, # aaaa	403	28 => sub { AnyEvent::Socket::format_address ($_) }, # aaaa
337	33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_qname) }, # srv	404	33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_name) }, # srv
		405	99 => sub { unpack "(C/a)", $_ }, # spf
338	);	406	);
339		407
340	sub _dec_rr {	408	sub _dec_rr {
341	my $qname = _dec_qname;	409	my $name = _dec_name;
342		410
343	my ($rt, $rc, $ttl, $rdlen) = unpack "nn N n", substr $pkt, $ofs; $ofs += 10;	411	my ($rt, $rc, $ttl, $rdlen) = unpack "nn N n", substr $pkt, $ofs; $ofs += 10;
344	local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen;	412	local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen;
345		413
346	[	414	[
347	$qname,	415	$name,
348	$type_str{$rt} \|\| $rt,	416	$type_str{$rt} \|\| $rt,
349	$class_str{$rc} \|\| $rc,	417	$class_str{$rc} \|\| $rc,
350	($dec_rr{$rt} \|\| sub { $_ })->(),	418	($dec_rr{$rt} \|\| sub { $_ })->(),
351	]	419	]
352	}	420	}
…		…
355		423
356	Unpacks a DNS packet into a perl data structure.	424	Unpacks a DNS packet into a perl data structure.
357		425
358	Examples:	426	Examples:
359		427
360	# a non-successful reply	428	# an unsuccessful reply
361	{	429	{
362	'qd' => [	430	'qd' => [
363	[ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]	431	[ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]
364	],	432	],
365	'rc' => 'nxdomain',	433	'rc' => 'nxdomain',
…		…
369	'uni-karlsruhe.de',	437	'uni-karlsruhe.de',
370	'soa',	438	'soa',
371	'in',	439	'in',
372	'netserv.rz.uni-karlsruhe.de',	440	'netserv.rz.uni-karlsruhe.de',
373	'hostmaster.rz.uni-karlsruhe.de',	441	'hostmaster.rz.uni-karlsruhe.de',
374	2008052201,	442	2008052201, 10800, 1800, 2592000, 86400
375	10800,
376	1800,
377	2592000,
378	86400
379	]	443	]
380	],	444	],
381	'tc' => '',	445	'tc' => '',
382	'ra' => 1,	446	'ra' => 1,
383	'qr' => 1,	447	'qr' => 1,
…		…
431	qr => ! ! ($flags & 0x8000),	495	qr => ! ! ($flags & 0x8000),
432	aa => ! ! ($flags & 0x0400),	496	aa => ! ! ($flags & 0x0400),
433	tc => ! ! ($flags & 0x0200),	497	tc => ! ! ($flags & 0x0200),
434	rd => ! ! ($flags & 0x0100),	498	rd => ! ! ($flags & 0x0100),
435	ra => ! ! ($flags & 0x0080),	499	ra => ! ! ($flags & 0x0080),
		500	ad => ! ! ($flags & 0x0020),
		501	cd => ! ! ($flags & 0x0010),
436	op => $opcode_str{($flags & 0x001e) >> 11},	502	op => $opcode_str{($flags & 0x001e) >> 11},
437	rc => $rcode_str{($flags & 0x000f)},	503	rc => $rcode_str{($flags & 0x000f)},
438		504
439	qd => [map _dec_qd, 1 .. $qd],	505	qd => [map _dec_qd, 1 .. $qd],
440	an => [map _dec_rr, 1 .. $an],	506	an => [map _dec_rr, 1 .. $an],
…		…
447		513
448	=back	514	=back
449		515
450	=head2 THE AnyEvent::DNS RESOLVER CLASS	516	=head2 THE AnyEvent::DNS RESOLVER CLASS
451		517
452	This is the class which deos the actual protocol work.	518	This is the class which does the actual protocol work.
453		519
454	=over 4	520	=over 4
455		521
456	=cut	522	=cut
457		523
…		…
477	our $RESOLVER;	543	our $RESOLVER;
478		544
479	sub resolver() {	545	sub resolver() {
480	$RESOLVER \|\| do {	546	$RESOLVER \|\| do {
481	$RESOLVER = new AnyEvent::DNS;	547	$RESOLVER = new AnyEvent::DNS;
482	$RESOLVER->load_resolv_conf;	548	$RESOLVER->os_config;
483	$RESOLVER	549	$RESOLVER
484	}	550	}
485	}	551	}
486		552
487	=item $resolver = new AnyEvent::DNS key => value...	553	=item $resolver = new AnyEvent::DNS key => value...
488		554
489	Creates and returns a new resolver. It only supports UDP, so make sure	555	Creates and returns a new resolver.
490	your answer sections fit into a DNS packet.
491		556
492	The following options are supported:	557	The following options are supported:
493		558
494	=over 4	559	=over 4
495		560
496	=item server => [...]	561	=item server => [...]
497		562
498	A list of server addressses (default C<v127.0.0.1>) in network format (4	563	A list of server addresses (default: C<v127.0.0.1>) in network format (4
499	octets for IPv4, 16 octets for IPv6 - not yet supported).	564	octets for IPv4, 16 octets for IPv6 - not yet supported).
500		565
501	=item timeout => [...]	566	=item timeout => [...]
502		567
503	A list of timeouts to use (also determines the number of retries). To make	568	A list of timeouts to use (also determines the number of retries). To make
…		…
514	tries to resolve the name without any suffixes first.	579	tries to resolve the name without any suffixes first.
515		580
516	=item max_outstanding => $integer	581	=item max_outstanding => $integer
517		582
518	Most name servers do not handle many parallel requests very well. This option	583	Most name servers do not handle many parallel requests very well. This option
519	limits the numbe rof outstanding requests to C<$n> (default: C<10>), that means	584	limits the number of outstanding requests to C<$n> (default: C<10>), that means
520	if you request more than this many requests, then the additional requests will be queued	585	if you request more than this many requests, then the additional requests will be queued
521	until some other requests have been resolved.	586	until some other requests have been resolved.
522		587
		588	=item reuse => $seconds
		589
		590	The number of seconds (default: C<300>) that a query id cannot be re-used
		591	after a timeout. If there as no time-out then query id's can be reused
		592	immediately.
		593
523	=back	594	=back
524		595
525	=cut	596	=cut
526		597
527	sub new {	598	sub new {
528	my ($class, %arg) = @_;	599	my ($class, %arg) = @_;
529		600
		601	# try to create a ipv4 and an ipv6 socket
		602	# only fail when we cnanot create either
		603
530	socket my $fh, &Socket::AF_INET, &Socket::SOCK_DGRAM, 0	604	socket my $fh4, AF_INET , &Socket::SOCK_DGRAM, 0;
531	or Carp::croak "socket: $!";	605	socket my $fh6, AF_INET6, &Socket::SOCK_DGRAM, 0;
532		606
533	AnyEvent::Util::fh_nonblocking $fh, 1;	607	$fh4 \|\| $fh6
		608	or Carp::croak "unable to create either an IPv6 or an IPv4 socket";
534		609
535	my $self = bless {	610	my $self = bless {
536	server => [v127.0.0.1],	611	server => [],
537	timeout => [2, 5, 5],	612	timeout => [2, 5, 5],
538	search => [],	613	search => [],
539	ndots => 1,	614	ndots => 1,
540	max_outstanding => 10,	615	max_outstanding => 10,
541	reuse => 300, # reuse id's after 5 minutes only, if possible	616	reuse => 300, # reuse id's after 5 minutes only, if possible
542	%arg,	617	%arg,
543	fh => $fh,
544	reuse_q => [],	618	reuse_q => [],
545	}, $class;	619	}, $class;
546		620
547	# search should default to gethostname's domain	621	# search should default to gethostname's domain
548	# but perl lacks a good posix module	622	# but perl lacks a good posix module
549		623
550	Scalar::Util::weaken (my $wself = $self);	624	Scalar::Util::weaken (my $wself = $self);
		625
		626	if ($fh4) {
		627	AnyEvent::Util::fh_nonblocking $fh4, 1;
		628	$self->{fh4} = $fh4;
551	$self->{rw} = AnyEvent->io (fh => $fh, poll => "r", cb => sub { $wself->_recv });	629	$self->{rw4} = AnyEvent->io (fh => $fh4, poll => "r", cb => sub {
		630	if (my $peer = recv $fh4, my $pkt, MAX_PKT, 0) {
		631	$wself->_recv ($pkt, $peer);
		632	}
		633	});
		634	}
		635
		636	if ($fh6) {
		637	$self->{fh6} = $fh6;
		638	AnyEvent::Util::fh_nonblocking $fh6, 1;
		639	$self->{rw6} = AnyEvent->io (fh => $fh6, poll => "r", cb => sub {
		640	if (my $peer = recv $fh6, my $pkt, MAX_PKT, 0) {
		641	$wself->_recv ($pkt, $peer);
		642	}
		643	});
		644	}
552		645
553	$self->_compile;	646	$self->_compile;
554		647
555	$self	648	$self
556	}	649	}
557		650
558	=item $resolver->parse_resolv_conv ($string)	651	=item $resolver->parse_resolv_conv ($string)
559		652
560	Parses the given string a sif it were a F<resolv.conf> file. The following	653	Parses the given string as if it were a F<resolv.conf> file. The following
561	directives are supported:	654	directives are supported (but not necessarily implemented).
562		655
563	C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,	656	C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,
564	C<options> (C<timeout>, C<attempts>, C<ndots>).	657	C<options> (C<timeout>, C<attempts>, C<ndots>).
565		658
566	Everything else is silently ignored.	659	Everything else is silently ignored.
…		…
578	for (split /\n/, $resolvconf) {	671	for (split /\n/, $resolvconf) {
579	if (/^\s*#/) {	672	if (/^\s*#/) {
580	# comment	673	# comment
581	} elsif (/^\snameserver\s+(\S+)\s$/i) {	674	} elsif (/^\snameserver\s+(\S+)\s$/i) {
582	my $ip = $1;	675	my $ip = $1;
583	if (AnyEvent::Util::dotted_quad $ip) {	676	if (my $ipn = AnyEvent::Socket::parse_address ($ip)) {
584	push @{ $self->{server} }, AnyEvent::Util::socket_inet_aton $ip;	677	push @{ $self->{server} }, $ipn;
585	} else {	678	} else {
586	warn "nameserver $ip invalid and ignored\n";	679	warn "nameserver $ip invalid and ignored\n";
587	}	680	}
588	} elsif (/^\sdomain\s+(\S)\s+$/i) {	681	} elsif (/^\sdomain\s+(\S)\s+$/i) {
589	$self->{search} = [$1];	682	$self->{search} = [$1];
…		…
610	if $attempts;	703	if $attempts;
611		704
612	$self->_compile;	705	$self->_compile;
613	}	706	}
614		707
615	=item $resolver->load_resolv_conf	708	=item $resolver->os_config
616		709
617	Tries to load and parse F</etc/resolv.conf>. If there will ever be windows	710	Tries so load and parse F</etc/resolv.conf> on portable operating systems. Tries various
618	support, then this function will do the right thing under windows, too.	711	egregious hacks on windows to force the DNS servers and searchlist out of the system.
619		712
620	=cut	713	=cut
621		714
622	sub load_resolv_conf {	715	sub os_config {
623	my ($self) = @_;	716	my ($self) = @_;
624		717
		718	$self->{server} = [];
		719	$self->{search} = [];
		720
		721	if (AnyEvent::WIN32 \|\| $^O =~ /cygwin/i) {
		722	no strict 'refs';
		723
		724	# there are many options to find the current nameservers etc. on windows
		725	# all of them don't work consistently:
		726	# - the registry thing needs separate code on win32 native vs. cygwin
		727	# - the registry layout differs between windows versions
		728	# - calling windows api functions doesn't work on cygwin
		729	# - ipconfig uses locale-specific messages
		730
		731	# we use ipconfig parsing because, despite all it's brokenness,
		732	# it seems most stable in practise.
		733	# for good measure, we append a fallback nameserver to our list.
		734
		735	if (open my $fh, "ipconfig /all \|") {
		736	# parsing strategy: we go through the output and look for
		737	# :-lines with DNS in them. everything in those is regarded as
		738	# either a nameserver (if it parses as an ip address), or a suffix
		739	# (all else).
		740
		741	my $dns;
		742	while (<$fh>) {
		743	if (s/^\s.\bdns\b.://i) {
		744	$dns = 1;
		745	} elsif (/^\S/ \|\| /^\s[^:]{16,}: /) {
		746	$dns = 0;
		747	}
		748	if ($dns && /^\s(\S+)\s$/) {
		749	my $s = $1;
		750	$s =~ s/%\d+(?!\S)//; # get rid of scope id
		751	if (my $ipn = AnyEvent::Socket::parse_address ($s)) {
		752	push @{ $self->{server} }, $ipn;
		753	} else {
		754	push @{ $self->{search} }, $s;
		755	}
		756	}
		757	}
		758
		759	# always add one fallback server
		760	push @{ $self->{server} }, $DNS_FALLBACK[rand @DNS_FALLBACK];
		761
		762	$self->_compile;
		763	}
		764	} else {
		765	# try resolv.conf everywhere
		766
625	open my $fh, "</etc/resolv.conf"	767	if (open my $fh, "</etc/resolv.conf") {
626	or return;
627
628	local $/;	768	local $/;
629	$self->parse_resolv_conf (<$fh>);	769	$self->parse_resolv_conf (<$fh>);
		770	}
		771	}
630	}	772	}
631		773
632	sub _compile {	774	sub _compile {
633	my $self = shift;	775	my $self = shift;
		776
		777	my %search; $self->{search} = [grep 0 < length, grep !$search{$_}++, @{ $self->{search} }];
		778	my %server; $self->{server} = [grep 0 < length, grep !$server{$_}++, @{ $self->{server} }];
		779
		780	unless (@{ $self->{server} }) {
		781	# use 127.0.0.1 by default, and one opendns nameserver as fallback
		782	$self->{server} = [v127.0.0.1, $DNS_FALLBACK[rand @DNS_FALLBACK]];
		783	}
634		784
635	my @retry;	785	my @retry;
636		786
637	for my $timeout (@{ $self->{timeout} }) {	787	for my $timeout (@{ $self->{timeout} }) {
638	for my $server (@{ $self->{server} }) {	788	for my $server (@{ $self->{server} }) {
…		…
641	}	791	}
642		792
643	$self->{retry} = \@retry;	793	$self->{retry} = \@retry;
644	}	794	}
645		795
		796	sub _feed {
		797	my ($self, $res) = @_;
		798
		799	$res = dns_unpack $res
		800	or return;
		801
		802	my $id = $self->{id}{$res->{id}};
		803
		804	return unless ref $id;
		805
		806	$NOW = time;
		807	$id->[1]->($res);
		808	}
		809
646	sub _recv {	810	sub _recv {
647	my ($self) = @_;	811	my ($self, $pkt, $peer) = @_;
648		812
649	while (my $peer = recv $self->{fh}, my $res, 1024, 0) {	813	# we ignore errors (often one gets port unreachable, but there is
		814	# no good way to take advantage of that.
		815
650	my ($port, $host) = Socket::unpack_sockaddr_in $peer;	816	my ($port, $host) = AnyEvent::Socket::unpack_sockaddr ($peer);
651		817
652	return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };	818	return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };
653		819
654	$res = dns_unpack $res	820	$self->_feed ($pkt);
655	or return;	821	}
656		822
657	my $id = $self->{id}{$res->{id}};	823	sub _free_id {
		824	my ($self, $id, $timeout) = @_;
658		825
659	return unless ref $id;	826	if ($timeout) {
660		827	# we need to block the id for a while
661	$NOW = time;	828	$self->{id}{$id} = 1;
662	$id->[1]->($res);	829	push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $id];
		830	} else {
		831	# we can quickly recycle the id
		832	delete $self->{id}{$id};
663	}	833	}
664	}
665		834
		835	--$self->{outstanding};
		836	$self->_scheduler;
		837	}
		838
		839	# execute a single request, involves sending it with timeouts to multiple servers
666	sub _exec {	840	sub _exec {
667	my ($self, $req, $retry) = @_;	841	my ($self, $req) = @_;
668		842
		843	my $retry; # of retries
		844	my $do_retry;
		845
		846	$do_retry = sub {
669	if (my $retry_cfg = $self->{retry}[$retry]) {	847	my $retry_cfg = $self->{retry}[$retry++]
		848	or do {
		849	# failure
		850	$self->_free_id ($req->[2], $retry > 1);
		851	undef $do_retry; return $req->[1]->();
		852	};
		853
670	my ($server, $timeout) = @$retry_cfg;	854	my ($server, $timeout) = @$retry_cfg;
671		855
672	$self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {	856	$self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {
673	$NOW = time;	857	$NOW = time;
674		858
675	# timeout, try next	859	# timeout, try next
676	$self->_exec ($req, $retry + 1);	860	&$do_retry;
677	}), sub {	861	}), sub {
678	my ($res) = @_;	862	my ($res) = @_;
679		863
		864	if ($res->{tc}) {
		865	# success, but truncated, so use tcp
		866	AnyEvent::Socket::tcp_connect (AnyEvent::Socket::format_address ($server), DOMAIN_PORT, sub {
		867	my ($fh) = @_
		868	or return &$do_retry;
		869
		870	my $handle = new AnyEvent::Handle
		871	fh => $fh,
		872	on_error => sub {
		873	# failure, try next
		874	&$do_retry;
		875	};
		876
		877	$handle->push_write (pack "n/a", $req->[0]);
		878	$handle->push_read (chunk => 2, sub {
		879	$handle->unshift_read (chunk => (unpack "n", $_[1]), sub {
		880	$self->_feed ($_[1]);
		881	});
		882	});
		883	shutdown $fh, 1;
		884
		885	}, sub { $timeout });
		886
		887	} else {
680	# success	888	# success
681	$self->{id}{$req->[2]} = 1;	889	$self->_free_id ($req->[2], $retry > 1);
682	push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];	890	undef $do_retry; return $req->[1]->($res);
683	--$self->{outstanding};	891	}
684	$self->_scheduler;
685
686	$req->[1]->($res);
687	}];	892	}];
		893
		894	my $sa = AnyEvent::Socket::pack_sockaddr (DOMAIN_PORT, $server);
688		895
689	send $self->{fh}, $req->[0], 0, Socket::pack_sockaddr_in 53, $server;	896	my $fh = (Socket::sockaddr_family $sa) == AF_INET
690	} else {	897	? $self->{fh4} : $self->{fh6}
691	# failure	898	or return &$do_retry;
692	$self->{id}{$req->[2]} = 1;
693	push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];
694	--$self->{outstanding};
695	$self->_scheduler;
696		899
697	$req->[1]->();	900	send $fh, $req->[0], 0, $sa;
698	}	901	};
		902
		903	&$do_retry;
699	}	904	}
700		905
701	sub _scheduler {	906	sub _scheduler {
702	my ($self) = @_;	907	my ($self) = @_;
703		908
704	$NOW = time;	909	$NOW = time;
705		910
706	# first clear id reuse queue	911	# first clear id reuse queue
707	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }	912	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }
708	while @{ $self->{reuse_q} } && $self->{reuse_q}[0] <= $NOW;	913	while @{ $self->{reuse_q} } && $self->{reuse_q}[0][0] <= $NOW;
709		914
710	while ($self->{outstanding} < $self->{max_outstanding}) {	915	while ($self->{outstanding} < $self->{max_outstanding}) {
		916
		917	if (@{ $self->{reuse_q} } >= 30000) {
		918	# we ran out of ID's, wait a bit
		919	$self->{reuse_to} \|\|= AnyEvent->timer (after => $self->{reuse_q}[0][0] - $NOW, cb => sub {
		920	delete $self->{reuse_to};
		921	$self->_scheduler;
		922	});
		923	last;
		924	}
		925
711	my $req = shift @{ $self->{queue} }	926	my $req = shift @{ $self->{queue} }
712	or last;	927	or last;
713		928
714	while () {	929	while () {
715	$req->[2] = int rand 65536;	930	$req->[2] = int rand 65536;
716	last unless exists $self->{id}{$req->[2]};	931	last unless exists $self->{id}{$req->[2]};
717	}	932	}
718		933
		934	++$self->{outstanding};
719	$self->{id}{$req->[2]} = 1;	935	$self->{id}{$req->[2]} = 1;
720	substr $req->[0], 0, 2, pack "n", $req->[2];	936	substr $req->[0], 0, 2, pack "n", $req->[2];
721		937
722	++$self->{outstanding};
723	$self->_exec ($req, 0);	938	$self->_exec ($req);
724	}	939	}
725	}	940	}
726		941
727	=item $resolver->request ($req, $cb->($res))	942	=item $resolver->request ($req, $cb->($res))
728		943
…		…
748	The callback will be invoked with a list of matching result records or	963	The callback will be invoked with a list of matching result records or
749	none on any error or if the name could not be found.	964	none on any error or if the name could not be found.
750		965
751	CNAME chains (although illegal) are followed up to a length of 8.	966	CNAME chains (although illegal) are followed up to a length of 8.
752		967
753	Note that this resolver is just a stub resolver: it requires a nameserver	968	Note that this resolver is just a stub resolver: it requires a name server
754	supporting recursive queries, will not do any recursive queries itself and	969	supporting recursive queries, will not do any recursive queries itself and
755	is not secure when used against an untrusted name server.	970	is not secure when used against an untrusted name server.
756		971
757	The following options are supported:	972	The following options are supported:
758		973
…		…
834	my %atype = $opt{accept}	1049	my %atype = $opt{accept}
835	? map +($_ => 1), @{ $opt{accept} }	1050	? map +($_ => 1), @{ $opt{accept} }
836	: ($qtype => 1);	1051	: ($qtype => 1);
837		1052
838	# advance in searchlist	1053	# advance in searchlist
839	my $do_search; $do_search = sub {	1054	my ($do_search, $do_req);
		1055
		1056	$do_search = sub {
840	@search	1057	@search
841	or return $cb->();	1058	or (undef $do_search), (undef $do_req), return $cb->();
842		1059
843	(my $name = lc "$qname." . shift @search) =~ s/\.$//;	1060	(my $name = lc "$qname." . shift @search) =~ s/\.$//;
844	my $depth = 2;	1061	my $depth = 2;
845		1062
846	# advance in cname-chain	1063	# advance in cname-chain
847	my $do_req; $do_req = sub {	1064	$do_req = sub {
848	$self->request ({	1065	$self->request ({
849	rd => 1,	1066	rd => 1,
850	qd => [[$name, $qtype, $class]],	1067	qd => [[$name, $qtype, $class]],
851	}, sub {	1068	}, sub {
852	my ($res) = @_	1069	my ($res) = @_
…		…
856		1073
857	while () {	1074	while () {
858	# results found?	1075	# results found?
859	my @rr = grep $name eq lc $_->[0] && ($atype{"*"} \|\| $atype{$_->[1]}), @{ $res->{an} };	1076	my @rr = grep $name eq lc $_->[0] && ($atype{"*"} \|\| $atype{$_->[1]}), @{ $res->{an} };
860		1077
861	return $cb->(@rr)	1078	(undef $do_search), (undef $do_req), return $cb->(@rr)
862	if @rr;	1079	if @rr;
863		1080
864	# see if there is a cname we can follow	1081	# see if there is a cname we can follow
865	my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} };	1082	my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} };
866		1083
…		…
887	};	1104	};
888		1105
889	$do_search->();	1106	$do_search->();
890	}	1107	}
891		1108
		1109	use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end
		1110
892	1;	1111	1;
893		1112
894	=back	1113	=back
895		1114
896	=head1 AUTHOR	1115	=head1 AUTHOR

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.4 by root, Fri May 23 04:10:40 2008 UTC vs. Revision 1.38 by root, Thu May 29 01:46:56 2008 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.4 by root, Fri May 23 04:10:40 2008 UTC vs.
Revision 1.38 by root, Thu May 29 01:46:56 2008 UTC