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