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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.3 by root, Fri May 23 03:20:53 2008 UTC vs.
Revision 1.23 by root, Sat May 24 02:13:52 2008 UTC

…		…
9	=head1 DESCRIPTION	9	=head1 DESCRIPTION
10		10
11	This module offers both a number of DNS convenience functions as well	11	This module offers both a number of DNS convenience functions as well
12	as a fully asynchronous and high-performance pure-perl stub resolver.	12	as a fully asynchronous and high-performance pure-perl stub resolver.
13		13
		14	The stub resolver supports DNS over UDP, optional EDNS0 support for up to
		15	4kiB datagrams and automatically falls back to virtual circuit mode for
		16	large responses.
		17
14	=head2 CONVENIENCE FUNCTIONS	18	=head2 CONVENIENCE FUNCTIONS
15
16	# none yet
17		19
18	=over 4	20	=over 4
19		21
20	=cut	22	=cut
21		23
22	package AnyEvent::DNS;	24	package AnyEvent::DNS;
23		25
24	no warnings;	26	no warnings;
25	use strict;	27	use strict;
26		28
27	use AnyEvent::Util ();	29	use AnyEvent::Handle ();
		30
		31	=item AnyEvent::DNS::addr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...)
		32
		33	Tries to resolve the given nodename and service name into protocol families
		34	and sockaddr structures usable to connect to this node and service in a
		35	protocol-independent way. It works remotely similar to the getaddrinfo
		36	posix function.
		37
		38	C<$node> is either an IPv4 or IPv6 address or a hostname, C<$service> is
		39	either a service name (port name from F</etc/services>) or a numerical
		40	port number. If both C<$node> and C<$service> are names, then SRV records
		41	will be consulted to find the real service, otherwise they will be
		42	used as-is. If you know that the service name is not in your services
		43	database, then you cna specify the service in the format C<name=port>
		44	(e.g. C<http=80>).
		45
		46	C<$proto> must be a protocol name, currently C<tcp>, C<udp> or
		47	C<sctp>. The default is C<tcp>.
		48
		49	C<$family> must be either C<0> (meaning any protocol is ok), C<4> (use
		50	only IPv4) or C<6> (use only IPv6). This setting might be influenced by
		51	C<$ENV{PERL_ANYEVENT_PROTOCOLS}>.
		52
		53	C<$type> must be C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_SEQPACKET> (or
		54	C<undef> in which case it gets automatically chosen).
		55
		56	The callback will receive zero or more array references that contain
		57	C<$family, $type, $proto> for use in C<socket> and a binary
		58	C<$sockaddr> for use in C<connect> (or C<bind>).
		59
		60	The application should try these in the order given.
		61
		62	Example:
		63
		64	AnyEvent::DNS::addr "google.com", "http", 0, undef, undef, sub { ... };
		65
		66	=item AnyEvent::DNS::a $domain, $cb->(@addrs)
		67
		68	Tries to resolve the given domain to IPv4 address(es).
		69
		70	=item AnyEvent::DNS::aaaa $domain, $cb->(@addrs)
		71
		72	Tries to resolve the given domain to IPv6 address(es).
		73
		74	=item AnyEvent::DNS::mx $domain, $cb->(@hostnames)
		75
		76	Tries to resolve the given domain into a sorted (lower preference value
		77	first) list of domain names.
		78
		79	=item AnyEvent::DNS::ns $domain, $cb->(@hostnames)
		80
		81	Tries to resolve the given domain name into a list of name servers.
		82
		83	=item AnyEvent::DNS::txt $domain, $cb->(@hostnames)
		84
		85	Tries to resolve the given domain name into a list of text records.
		86
		87	=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)
		88
		89	Tries to resolve the given service, protocol and domain name into a list
		90	of service records.
		91
		92	Each srv_rr is an arrayref with the following contents:
		93	C<[$priority, $weight, $transport, $target]>.
		94
		95	They will be sorted with lowest priority, highest weight first (TODO:
		96	should use the rfc algorithm to reorder same-priority records for weight).
		97
		98	Example:
		99
		100	AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...
		101	# @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )
		102
		103	=item AnyEvent::DNS::ptr $ipv4_or_6, $cb->(@hostnames)
		104
		105	Tries to reverse-resolve the given IPv4 or IPv6 address (in textual form)
		106	into it's hostname(s).
		107
		108	Example:
		109
		110	AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };
		111	# => f.root-servers.net
		112
		113	=item AnyEvent::DNS::any $domain, $cb->(@rrs)
		114
		115	Tries to resolve the given domain and passes all resource records found to
		116	the callback.
		117
		118	=cut
		119
		120	sub resolver;
		121
		122	sub a($$) {
		123	my ($domain, $cb) = @_;
		124
		125	resolver->resolve ($domain => "a", sub {
		126	$cb->(map $_->[3], @_);
		127	});
		128	}
		129
		130	sub aaaa($$) {
		131	my ($domain, $cb) = @_;
		132
		133	resolver->resolve ($domain => "aaaa", sub {
		134	$cb->(map $_->[3], @_);
		135	});
		136	}
		137
		138	sub mx($$) {
		139	my ($domain, $cb) = @_;
		140
		141	resolver->resolve ($domain => "mx", sub {
		142	$cb->(map $_->[4], sort { $a->[3] <=> $b->[3] } @_);
		143	});
		144	}
		145
		146	sub ns($$) {
		147	my ($domain, $cb) = @_;
		148
		149	resolver->resolve ($domain => "ns", sub {
		150	$cb->(map $_->[3], @_);
		151	});
		152	}
		153
		154	sub txt($$) {
		155	my ($domain, $cb) = @_;
		156
		157	resolver->resolve ($domain => "txt", sub {
		158	$cb->(map $_->[3], @_);
		159	});
		160	}
		161
		162	sub srv($$$$) {
		163	my ($service, $proto, $domain, $cb) = @_;
		164
		165	# todo, ask for any and check glue records
		166	resolver->resolve ("_$service._$proto.$domain" => "srv", sub {
		167	$cb->(map [@$_[3,4,5,6]], sort { $a->[3] <=> $b->[3] \|\| $b->[4] <=> $a->[4] } @_);
		168	});
		169	}
		170
		171	sub ptr($$) {
		172	my ($ip, $cb) = @_;
		173
		174	$ip = AnyEvent::Socket::parse_ip ($ip)
		175	or return $cb->();
		176
		177	if (4 == length $ip) {
		178	$ip = join ".", (reverse split /\./, $ip), "in-addr.arpa.";
		179	} else {
		180	$ip = join ".", (reverse split //, unpack "H*", $ip), "ip6.arpa.";
		181	}
		182
		183	resolver->resolve ($ip => "ptr", sub {
		184	$cb->(map $_->[3], @_);
		185	});
		186	}
		187
		188	sub any($$) {
		189	my ($domain, $cb) = @_;
		190
		191	resolver->resolve ($domain => "*", $cb);
		192	}
		193
		194	#############################################################################
		195
		196	sub addr($$$$$$) {
		197	my ($node, $service, $proto, $family, $type, $cb) = @_;
		198
		199	unless (&AnyEvent::Socket::AF_INET6) {
		200	$family != 6
		201	or return $cb->();
		202
		203	$family \|\|= 4;
		204	}
		205
		206	$cb->() if $family == 4 && !$AnyEvent::PROTOCOL{ipv4};
		207	$cb->() if $family == 6 && !$AnyEvent::PROTOCOL{ipv6};
		208
		209	$family \|\|=4 unless $AnyEvent::PROTOCOL{ipv6};
		210	$family \|\|=6 unless $AnyEvent::PROTOCOL{ipv4};
		211
		212	$proto \|\|= "tcp";
		213	$type \|\|= $proto eq "udp" ? Socket::SOCK_DGRAM : Socket::SOCK_STREAM;
		214
		215	my $proton = (getprotobyname $proto)[2]
		216	or Carp::croak "$proto: protocol unknown";
		217
		218	my $port;
		219
		220	if ($service =~ /^(\S+)=(\d+)$/) {
		221	($service, $port) = ($1, $2);
		222	} elsif ($service =~ /^\d+$/) {
		223	($service, $port) = (undef, $service);
		224	} else {
		225	$port = (getservbyname $service, $proto)[2]
		226	or Carp::croak "$service/$proto: service unknown";
		227	}
		228
		229	my @target = [$node, $port];
		230
		231	# resolve a records / provide sockaddr structures
		232	my $resolve = sub {
		233	my @res;
		234	my $cv = AnyEvent->condvar (cb => sub {
		235	$cb->(
		236	map $_->[1],
		237	sort {
		238	$AnyEvent::PROTOCOL{$a->[1][0]} <=> $AnyEvent::PROTOCOL{$b->[1][0]}
		239	or $a->[0] <=> $b->[0]
		240	}
		241	@res
		242	)
		243	});
		244
		245	$cv->begin;
		246	for my $idx (0 .. $#target) {
		247	my ($node, $port) = @{ $target[$idx] };
		248
		249	if (my $noden = AnyEvent::Socket::parse_ip ($node)) {
		250	if (4 == length $noden && $family != 6) {
		251	push @res, [$idx, [Socket::AF_INET, $type, $proton,
		252	AnyEvent::Socket::pack_sockaddr ($port, $noden)]]
		253	}
		254
		255	if (16 == length $noden && $family != 4) {
		256	push @res, [$idx, [&AnyEvent::Socket::AF_INET6, $type, $proton,
		257	AnyEvent::Socket::pack_sockaddr ( $port, $noden)]]
		258	}
		259	} else {
		260	# ipv4
		261	if ($family != 6) {
		262	$cv->begin;
		263	a $node, sub {
		264	push @res, [$idx, [Socket::AF_INET, $type, $proton,
		265	AnyEvent::Socket::pack_sockaddr ($port, AnyEvent::Socket::parse_ipv4 ($_))]]
		266	for @_;
		267	$cv->end;
		268	};
		269	}
		270
		271	# ipv6
		272	if ($family != 4) {
		273	$cv->begin;
		274	aaaa $node, sub {
		275	push @res, [$idx, [&AnyEvent::Socket::AF_INET6, $type, $proton,
		276	AnyEvent::Socket::pack_sockaddr ($port, AnyEvent::Socket::parse_ipv6 ($_))]]
		277	for @_;
		278	$cv->end;
		279	};
		280	}
		281	}
		282	}
		283	$cv->end;
		284	};
		285
		286	# try srv records, if applicable
		287	if ($node eq "localhost") {
		288	@target = ([v127.0.0.1, $port], [v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1, $port]);
		289	} elsif (defined $service && !AnyEvent::Socket::parse_ip ($node)) {
		290	srv $service, $proto, $node, sub {
		291	my (@srv) = @_;
		292
		293	# no srv records, continue traditionally
		294	@srv
		295	or return &$resolve;
		296
		297	# only srv record has "." => abort
		298	$srv[0][2] ne "." \|\| $#srv
		299	or return $cb->();
		300
		301	# use srv records then
		302	@target = map ["$_->[3].", $_->[2]],
		303	grep $_->[3] ne ".",
		304	@srv;
		305
		306	&$resolve;
		307	};
		308	} else {
		309	&$resolve;
		310	}
		311	}
		312
		313	#############################################################################
28		314
29	=back	315	=back
30		316
31	=head2 DNS EN-/DECODING FUNCTIONS	317	=head2 LOW-LEVEL DNS EN-/DECODING FUNCTIONS
32		318
33	=over 4	319	=over 4
34		320
		321	=item $AnyEvent::DNS::EDNS0
		322
		323	This variable decides whether dns_pack automatically enables EDNS0
		324	support. By default, this is disabled (C<0>), unless overriden by
		325	C<$ENV{PERL_ANYEVENT_EDNS0>), but when set to C<1>, AnyEvent::DNS will use
		326	EDNS0 in all requests.
		327
35	=cut	328	=cut
		329
		330	our $EDNS0 = $ENV{PERL_ANYEVENT_EDNS0} * 1; # set to 1 to enable (partial) edns0
36		331
37	our %opcode_id = (	332	our %opcode_id = (
38	query => 0,	333	query => 0,
39	iquery => 1,	334	iquery => 1,
40	status => 2,	335	status => 2,
		336	notify => 4,
		337	update => 5,
41	map +($_ => $_), 3..15	338	map +($_ => $_), 3, 6..15
42	);	339	);
43		340
44	our %opcode_str = reverse %opcode_id;	341	our %opcode_str = reverse %opcode_id;
45		342
46	our %rcode_id = (	343	our %rcode_id = (
47	ok => 0,	344	noerror => 0,
48	formerr => 1,	345	formerr => 1,
49	servfail => 2,	346	servfail => 2,
50	nxdomain => 3,	347	nxdomain => 3,
51	notimp => 4,	348	notimp => 4,
52	refused => 5,	349	refused => 5,
		350	yxdomain => 6, # Name Exists when it should not [RFC 2136]
		351	yxrrset => 7, # RR Set Exists when it should not [RFC 2136]
		352	nxrrset => 8, # RR Set that should exist does not [RFC 2136]
		353	notauth => 9, # Server Not Authoritative for zone [RFC 2136]
		354	notzone => 10, # Name not contained in zone [RFC 2136]
		355	# EDNS0 16 BADVERS Bad OPT Version [RFC 2671]
		356	# EDNS0 16 BADSIG TSIG Signature Failure [RFC 2845]
		357	# EDNS0 17 BADKEY Key not recognized [RFC 2845]
		358	# EDNS0 18 BADTIME Signature out of time window [RFC 2845]
		359	# EDNS0 19 BADMODE Bad TKEY Mode [RFC 2930]
		360	# EDNS0 20 BADNAME Duplicate key name [RFC 2930]
		361	# EDNS0 21 BADALG Algorithm not supported [RFC 2930]
53	map +($_ => $_), 6..15	362	map +($_ => $_), 11..15
54	);	363	);
55		364
56	our %rcode_str = reverse %rcode_id;	365	our %rcode_str = reverse %rcode_id;
57		366
58	our %type_id = (	367	our %type_id = (
…		…
72	minfo => 14,	381	minfo => 14,
73	mx => 15,	382	mx => 15,
74	txt => 16,	383	txt => 16,
75	aaaa => 28,	384	aaaa => 28,
76	srv => 33,	385	srv => 33,
		386	opt => 41,
		387	spf => 99,
		388	tkey => 249,
		389	tsig => 250,
		390	ixfr => 251,
77	axfr => 252,	391	axfr => 252,
78	mailb => 253,	392	mailb => 253,
79	"*" => 255,	393	"*" => 255,
80	);	394	);
81		395
82	our %type_str = reverse %type_id;	396	our %type_str = reverse %type_id;
83		397
84	our %class_id = (	398	our %class_id = (
85	in => 1,	399	in => 1,
86	ch => 3,	400	ch => 3,
87	hs => 4,	401	hs => 4,
		402	none => 254,
88	"*" => 255,	403	"*" => 255,
89	);	404	);
90		405
91	our %class_str = reverse %class_id;	406	our %class_str = reverse %class_id;
92		407
93	# names MUST have a trailing dot	408	# names MUST have a trailing dot
…		…
128	qr => 1,	443	qr => 1,
129	aa => 0,	444	aa => 0,
130	tc => 0,	445	tc => 0,
131	rd => 0,	446	rd => 0,
132	ra => 0,	447	ra => 0,
		448	ad => 0,
		449	cd => 0,
133		450
134	qd => [@rr], # query section	451	qd => [@rr], # query section
135	an => [@rr], # answer section	452	an => [@rr], # answer section
136	ns => [@rr], # authority section	453	ns => [@rr], # authority section
137	ar => [@rr], # additional records section	454	ar => [@rr], # additional records section
…		…
140	=cut	457	=cut
141		458
142	sub dns_pack($) {	459	sub dns_pack($) {
143	my ($req) = @_;	460	my ($req) = @_;
144		461
145	pack "nn nnnn a* a* a* a*",	462	pack "nn nnnn a* a* a* a* a*",
146	$req->{id},	463	$req->{id},
147		464
148	! !$req->{qr} * 0x8000	465	! !$req->{qr} * 0x8000
149	+ $opcode_id{$req->{op}} * 0x0800	466	+ $opcode_id{$req->{op}} * 0x0800
150	+ ! !$req->{aa} * 0x0400	467	+ ! !$req->{aa} * 0x0400
151	+ ! !$req->{tc} * 0x0200	468	+ ! !$req->{tc} * 0x0200
152	+ ! !$req->{rd} * 0x0100	469	+ ! !$req->{rd} * 0x0100
153	+ ! !$req->{ra} * 0x0080	470	+ ! !$req->{ra} * 0x0080
		471	+ ! !$req->{ad} * 0x0020
		472	+ ! !$req->{cd} * 0x0010
154	+ $rcode_id{$req->{rc}} * 0x0001,	473	+ $rcode_id{$req->{rc}} * 0x0001,
155		474
156	scalar @{ $req->{qd} \|\| [] },	475	scalar @{ $req->{qd} \|\| [] },
157	scalar @{ $req->{an} \|\| [] },	476	scalar @{ $req->{an} \|\| [] },
158	scalar @{ $req->{ns} \|\| [] },	477	scalar @{ $req->{ns} \|\| [] },
159	scalar @{ $req->{ar} \|\| [] },	478	$EDNS0 + scalar @{ $req->{ar} \|\| [] }, # include EDNS0 option here
160		479
161	(join "", map _enc_qd, @{ $req->{qd} \|\| [] }),	480	(join "", map _enc_qd, @{ $req->{qd} \|\| [] }),
162	(join "", map _enc_rr, @{ $req->{an} \|\| [] }),	481	(join "", map _enc_rr, @{ $req->{an} \|\| [] }),
163	(join "", map _enc_rr, @{ $req->{ns} \|\| [] }),	482	(join "", map _enc_rr, @{ $req->{ns} \|\| [] }),
164	(join "", map _enc_rr, @{ $req->{ar} \|\| [] });	483	(join "", map _enc_rr, @{ $req->{ar} \|\| [] }),
		484
		485	($EDNS0 ? pack "C nnNn", 0, 41, 4096, 0, 0 : "") # EDNS0, 4kiB udp payload size
165	}	486	}
166		487
167	our $ofs;	488	our $ofs;
168	our $pkt;	489	our $pkt;
169		490
…		…
198	my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;	519	my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;
199	[$qname, $type_str{$qt} \|\| $qt, $class_str{$qc} \|\| $qc]	520	[$qname, $type_str{$qt} \|\| $qt, $class_str{$qc} \|\| $qc]
200	}	521	}
201		522
202	our %dec_rr = (	523	our %dec_rr = (
203	1 => sub { Socket::inet_ntoa $_ }, # a	524	1 => sub { join ".", unpack "C4" }, # a
204	2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns	525	2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns
205	5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname	526	5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname
206	6 => sub {	527	6 => sub {
207	local $ofs = $ofs - length;	528	local $ofs = $ofs - length;
208	my $mname = _dec_qname;	529	my $mname = _dec_qname;
209	my $rname = _dec_qname;	530	my $rname = _dec_qname;
210	($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)	531	($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)
211	}, # soa	532	}, # soa
212	11 => sub { ((Socket::inet_aton substr $_, 0, 4), unpack "C a*", substr $_, 4) }, # wks	533	11 => sub { ((join ".", unpack "C4"), unpack "C a*", substr $_, 4) }, # wks
213	12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr	534	12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr
214	13 => sub { unpack "C/a C/a", $_ },	535	13 => sub { unpack "C/a C/a", $_ }, # hinfo
215	15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_qname) }, # mx	536	15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_qname) }, # mx
216	16 => sub { unpack "C/a", $_ }, # txt	537	16 => sub { unpack "(C/a)*", $_ }, # txt
217	28 => sub { sprintf "%04x:%04x:%04x:%04x:%04x:%04x:%04x:%04x", unpack "n8" }, # aaaa	538	28 => sub { AnyEvent::Socket::format_ip ($_) }, # aaaa
218	33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_qname) }, # srv	539	33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_qname) }, # srv
		540	99 => sub { unpack "(C/a)*", $_ }, # spf
219	);	541	);
220		542
221	sub _dec_rr {	543	sub _dec_rr {
222	my $qname = _dec_qname;	544	my $qname = _dec_qname;
223		545
…		…
236		558
237	Unpacks a DNS packet into a perl data structure.	559	Unpacks a DNS packet into a perl data structure.
238		560
239	Examples:	561	Examples:
240		562
241	# a non-successful reply	563	# an unsuccessful reply
242	{	564	{
243	'qd' => [	565	'qd' => [
244	[ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]	566	[ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]
245	],	567	],
246	'rc' => 'nxdomain',	568	'rc' => 'nxdomain',
…		…
250	'uni-karlsruhe.de',	572	'uni-karlsruhe.de',
251	'soa',	573	'soa',
252	'in',	574	'in',
253	'netserv.rz.uni-karlsruhe.de',	575	'netserv.rz.uni-karlsruhe.de',
254	'hostmaster.rz.uni-karlsruhe.de',	576	'hostmaster.rz.uni-karlsruhe.de',
255	2008052201,	577	2008052201, 10800, 1800, 2592000, 86400
256	10800,
257	1800,
258	2592000,
259	86400
260	]	578	]
261	],	579	],
262	'tc' => '',	580	'tc' => '',
263	'ra' => 1,	581	'ra' => 1,
264	'qr' => 1,	582	'qr' => 1,
…		…
312	qr => ! ! ($flags & 0x8000),	630	qr => ! ! ($flags & 0x8000),
313	aa => ! ! ($flags & 0x0400),	631	aa => ! ! ($flags & 0x0400),
314	tc => ! ! ($flags & 0x0200),	632	tc => ! ! ($flags & 0x0200),
315	rd => ! ! ($flags & 0x0100),	633	rd => ! ! ($flags & 0x0100),
316	ra => ! ! ($flags & 0x0080),	634	ra => ! ! ($flags & 0x0080),
		635	ad => ! ! ($flags & 0x0020),
		636	cd => ! ! ($flags & 0x0010),
317	op => $opcode_str{($flags & 0x001e) >> 11},	637	op => $opcode_str{($flags & 0x001e) >> 11},
318	rc => $rcode_str{($flags & 0x000f)},	638	rc => $rcode_str{($flags & 0x000f)},
319		639
320	qd => [map _dec_qd, 1 .. $qd],	640	qd => [map _dec_qd, 1 .. $qd],
321	an => [map _dec_rr, 1 .. $an],	641	an => [map _dec_rr, 1 .. $an],
…		…
328		648
329	=back	649	=back
330		650
331	=head2 THE AnyEvent::DNS RESOLVER CLASS	651	=head2 THE AnyEvent::DNS RESOLVER CLASS
332		652
333	This is the class which deos the actual protocol work.	653	This is the class which does the actual protocol work.
334		654
335	=over 4	655	=over 4
336		656
337	=cut	657	=cut
338		658
…		…
358	our $RESOLVER;	678	our $RESOLVER;
359		679
360	sub resolver() {	680	sub resolver() {
361	$RESOLVER \|\| do {	681	$RESOLVER \|\| do {
362	$RESOLVER = new AnyEvent::DNS;	682	$RESOLVER = new AnyEvent::DNS;
363	$RESOLVER->load_resolv_conf;	683	$RESOLVER->os_config;
364	$RESOLVER	684	$RESOLVER
365	}	685	}
366	}	686	}
367		687
368	=item $resolver = new AnyEvent::DNS key => value...	688	=item $resolver = new AnyEvent::DNS key => value...
369		689
370	Creates and returns a new resolver. It only supports UDP, so make sure	690	Creates and returns a new resolver.
371	your answer sections fit into a DNS packet.
372		691
373	The following options are supported:	692	The following options are supported:
374		693
375	=over 4	694	=over 4
376		695
377	=item server => [...]	696	=item server => [...]
378		697
379	A list of server addressses (default C<v127.0.0.1>) in network format (4	698	A list of server addressses (default: C<v127.0.0.1>) in network format (4
380	octets for IPv4, 16 octets for IPv6 - not yet supported).	699	octets for IPv4, 16 octets for IPv6 - not yet supported).
381		700
382	=item timeout => [...]	701	=item timeout => [...]
383		702
384	A list of timeouts to use (also determines the number of retries). To make	703	A list of timeouts to use (also determines the number of retries). To make
…		…
398		717
399	Most name servers do not handle many parallel requests very well. This option	718	Most name servers do not handle many parallel requests very well. This option
400	limits the numbe rof outstanding requests to C<$n> (default: C<10>), that means	719	limits the numbe rof outstanding requests to C<$n> (default: C<10>), that means
401	if you request more than this many requests, then the additional requests will be queued	720	if you request more than this many requests, then the additional requests will be queued
402	until some other requests have been resolved.	721	until some other requests have been resolved.
		722
		723	=item reuse => $seconds
		724
		725	The number of seconds (default: C<300>) that a query id cannot be re-used
		726	after a timeout. If there as no time-out then query id's can be reused
		727	immediately.
403		728
404	=back	729	=back
405		730
406	=cut	731	=cut
407		732
…		…
437	}	762	}
438		763
439	=item $resolver->parse_resolv_conv ($string)	764	=item $resolver->parse_resolv_conv ($string)
440		765
441	Parses the given string a sif it were a F<resolv.conf> file. The following	766	Parses the given string a sif it were a F<resolv.conf> file. The following
442	directives are supported:	767	directives are supported (but not neecssarily implemented).
443		768
444	C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,	769	C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,
445	C<options> (C<timeout>, C<attempts>, C<ndots>).	770	C<options> (C<timeout>, C<attempts>, C<ndots>).
446		771
447	Everything else is silently ignored.	772	Everything else is silently ignored.
…		…
491	if $attempts;	816	if $attempts;
492		817
493	$self->_compile;	818	$self->_compile;
494	}	819	}
495		820
496	=item $resolver->load_resolv_conf	821	=item $resolver->os_config
497		822
498	Tries to load and parse F</etc/resolv.conf>. If there will ever be windows	823	Tries so load and parse F</etc/resolv.conf> on portable opertaing systems. Tries various
499	support, then this function will do the right thing under windows, too.	824	egregious hacks on windows to force the dns servers and searchlist out of the config.
500		825
501	=cut	826	=cut
502		827
503	sub load_resolv_conf {	828	sub os_config {
504	my ($self) = @_;	829	my ($self) = @_;
505		830
		831	if ($^O =~ /mswin32\|cygwin/i) {
		832	# yeah, it suxx... lets hope DNS is DNS in all locales
		833
		834	if (open my $fh, "ipconfig /all \|") {
		835	delete $self->{server};
		836	delete $self->{search};
		837
		838	while (<$fh>) {
		839	# first DNS.* is suffix list
		840	if (/^\s*DNS/) {
		841	while (/\s+([[:alnum:].\-]+)\s*$/) {
		842	push @{ $self->{search} }, $1;
		843	$_ = <$fh>;
		844	}
		845	last;
		846	}
		847	}
		848
		849	while (<$fh>) {
		850	# second DNS.* is server address list
		851	if (/^\s*DNS/) {
		852	while (/\s+(\d+\.\d+\.\d+\.\d+)\s*$/) {
		853	my $ip = $1;
		854	push @{ $self->{server} }, AnyEvent::Util::socket_inet_aton $ip
		855	if AnyEvent::Util::dotted_quad $ip;
		856	$_ = <$fh>;
		857	}
		858	last;
		859	}
		860	}
		861
		862	$self->_compile;
		863	}
		864	} else {
		865	# try resolv.conf everywhere
		866
506	open my $fh, "</etc/resolv.conf"	867	if (open my $fh, "</etc/resolv.conf") {
507	or return;
508
509	local $/;	868	local $/;
510	$self->parse_resolv_conf (<$fh>);	869	$self->parse_resolv_conf (<$fh>);
		870	}
		871	}
511	}	872	}
512		873
513	sub _compile {	874	sub _compile {
514	my $self = shift;	875	my $self = shift;
515		876
…		…
522	}	883	}
523		884
524	$self->{retry} = \@retry;	885	$self->{retry} = \@retry;
525	}	886	}
526		887
		888	sub _feed {
		889	my ($self, $res) = @_;
		890
		891	$res = dns_unpack $res
		892	or return;
		893
		894	my $id = $self->{id}{$res->{id}};
		895
		896	return unless ref $id;
		897
		898	$NOW = time;
		899	$id->[1]->($res);
		900	}
		901
527	sub _recv {	902	sub _recv {
528	my ($self) = @_;	903	my ($self) = @_;
529		904
530	while (my $peer = recv $self->{fh}, my $res, 1024, 0) {	905	while (my $peer = recv $self->{fh}, my $res, 4096, 0) {
531	my ($port, $host) = Socket::unpack_sockaddr_in $peer;	906	my ($port, $host) = AnyEvent::Socket::unpack_sockaddr ($peer);
532		907
533	return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };	908	return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };
534		909
535	$res = dns_unpack $res	910	$self->_feed ($res);
536	or return;
537
538	my $id = $self->{id}{$res->{id}};
539
540	return unless ref $id;
541
542	$NOW = time;
543	$id->[1]->($res);
544	}	911	}
545	}	912	}
546		913
		914	sub _free_id {
		915	my ($self, $id, $timeout) = @_;
		916
		917	if ($timeout) {
		918	# we need to block the id for a while
		919	$self->{id}{$id} = 1;
		920	push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $id];
		921	} else {
		922	# we can quickly recycle the id
		923	delete $self->{id}{$id};
		924	}
		925
		926	--$self->{outstanding};
		927	$self->_scheduler;
		928	}
		929
		930	# execute a single request, involves sending it with timeouts to multiple servers
547	sub _exec {	931	sub _exec {
548	my ($self, $req, $retry) = @_;	932	my ($self, $req) = @_;
549		933
		934	my $retry; # of retries
		935	my $do_retry;
		936
		937	$do_retry = sub {
550	if (my $retry_cfg = $self->{retry}[$retry]) {	938	my $retry_cfg = $self->{retry}[$retry++]
		939	or do {
		940	# failure
		941	$self->_free_id ($req->[2], $retry > 1);
		942	undef $do_retry; return $req->[1]->();
		943	};
		944
551	my ($server, $timeout) = @$retry_cfg;	945	my ($server, $timeout) = @$retry_cfg;
552		946
553	$self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {	947	$self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {
554	$NOW = time;	948	$NOW = time;
555		949
556	# timeout, try next	950	# timeout, try next
557	$self->_exec ($req, $retry + 1);	951	&$do_retry;
558	}), sub {	952	}), sub {
559	my ($res) = @_;	953	my ($res) = @_;
560		954
		955	if ($res->{tc}) {
		956	# success, but truncated, so use tcp
		957	AnyEvent::Socket::tcp_connect ((Socket::inet_ntoa $server), 53, sub {
		958	my ($fh) = @_
		959	or return &$do_retry;
		960
		961	my $handle = new AnyEvent::Handle
		962	fh => $fh,
		963	on_error => sub {
		964	# failure, try next
		965	&$do_retry;
		966	};
		967
		968	$handle->push_write (pack "n/a", $req->[0]);
		969	$handle->push_read_chunk (2, sub {
		970	$handle->unshift_read_chunk ((unpack "n", $_[1]), sub {
		971	$self->_feed ($_[1]);
		972	});
		973	});
		974	shutdown $fh, 1;
		975
		976	}, sub { $timeout });
		977
		978	} else {
561	# success	979	# success
562	$self->{id}{$req->[2]} = 1;	980	$self->_free_id ($req->[2], $retry > 1);
563	push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];	981	undef $do_retry; return $req->[1]->($res);
564	--$self->{outstanding};	982	}
565	$self->_scheduler;
566
567	$req->[1]->($res);
568	}];	983	}];
569		984
570	send $self->{fh}, $req->[0], 0, Socket::pack_sockaddr_in 53, $server;	985	send $self->{fh}, $req->[0], 0, AnyEvent::Socket::pack_sockaddr (53, $server);
571	} else {
572	# failure
573	$self->{id}{$req->[2]} = 1;
574	push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];
575	--$self->{outstanding};
576	$self->_scheduler;
577
578	$req->[1]->();
579	}	986	};
		987
		988	&$do_retry;
580	}	989	}
581		990
582	sub _scheduler {	991	sub _scheduler {
583	my ($self) = @_;	992	my ($self) = @_;
584		993
585	$NOW = time;	994	$NOW = time;
586		995
587	# first clear id reuse queue	996	# first clear id reuse queue
588	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }	997	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }
589	while @{ $self->{reuse_q} } && $self->{reuse_q}[0] <= $NOW;	998	while @{ $self->{reuse_q} } && $self->{reuse_q}[0][0] <= $NOW;
590		999
591	while ($self->{outstanding} < $self->{max_outstanding}) {	1000	while ($self->{outstanding} < $self->{max_outstanding}) {
		1001
		1002	if (@{ $self->{reuse_q} } >= 30000) {
		1003	# we ran out of ID's, wait a bit
		1004	$self->{reuse_to} \|\|= AnyEvent->timer (after => $self->{reuse_q}[0][0] - $NOW, cb => sub {
		1005	delete $self->{reuse_to};
		1006	$self->_scheduler;
		1007	});
		1008	last;
		1009	}
		1010
592	my $req = shift @{ $self->{queue} }	1011	my $req = shift @{ $self->{queue} }
593	or last;	1012	or last;
594		1013
595	while () {	1014	while () {
596	$req->[2] = int rand 65536;	1015	$req->[2] = int rand 65536;
597	last unless exists $self->{id}{$req->[2]};	1016	last unless exists $self->{id}{$req->[2]};
598	}	1017	}
599		1018
		1019	++$self->{outstanding};
600	$self->{id}{$req->[2]} = 1;	1020	$self->{id}{$req->[2]} = 1;
601	substr $req->[0], 0, 2, pack "n", $req->[2];	1021	substr $req->[0], 0, 2, pack "n", $req->[2];
602		1022
603	++$self->{outstanding};
604	$self->_exec ($req, 0);	1023	$self->_exec ($req);
605	}	1024	}
606	}	1025	}
607		1026
608	=item $resolver->request ($req, $cb->($res))	1027	=item $resolver->request ($req, $cb->($res))
609		1028
…		…
715	my %atype = $opt{accept}	1134	my %atype = $opt{accept}
716	? map +($_ => 1), @{ $opt{accept} }	1135	? map +($_ => 1), @{ $opt{accept} }
717	: ($qtype => 1);	1136	: ($qtype => 1);
718		1137
719	# advance in searchlist	1138	# advance in searchlist
720	my $do_search; $do_search = sub {	1139	my ($do_search, $do_req);
		1140
		1141	$do_search = sub {
721	@search	1142	@search
722	or return $cb->();	1143	or (undef $do_search), (undef $do_req), return $cb->();
723		1144
724	(my $name = "$qname." . shift @search) =~ s/\.$//;	1145	(my $name = lc "$qname." . shift @search) =~ s/\.$//;
725	my $depth = 2;	1146	my $depth = 2;
726		1147
727	# advance in cname-chain	1148	# advance in cname-chain
728	my $do_req; $do_req = sub {	1149	$do_req = sub {
729	$self->request ({	1150	$self->request ({
730	rd => 1,	1151	rd => 1,
731	qd => [[$name, $qtype, $class]],	1152	qd => [[$name, $qtype, $class]],
732	}, sub {	1153	}, sub {
733	my ($res) = @_	1154	my ($res) = @_
…		…
735		1156
736	my $cname;	1157	my $cname;
737		1158
738	while () {	1159	while () {
739	# results found?	1160	# results found?
740	my @rr = grep $_->[0] eq $name && ($atype{"*"} \|\| $atype{$_->[1]}), @{ $res->{an} };	1161	my @rr = grep $name eq lc $_->[0] && ($atype{"*"} \|\| $atype{$_->[1]}), @{ $res->{an} };
741		1162
742	return $cb->(@rr)	1163	(undef $do_search), (undef $do_req), return $cb->(@rr)
743	if @rr;	1164	if @rr;
744		1165
745	# see if there is a cname we can follow	1166	# see if there is a cname we can follow
746	my @rr = grep $_->[0] eq $name && $_->[1] eq "cname", @{ $res->{an} };	1167	my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} };
747		1168
748	if (@rr) {	1169	if (@rr) {
749	$depth--	1170	$depth--
750	or return $do_search->(); # cname chain too long	1171	or return $do_search->(); # cname chain too long
751		1172
…		…
768	};	1189	};
769		1190
770	$do_search->();	1191	$do_search->();
771	}	1192	}
772		1193
		1194	use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end
		1195
773	1;	1196	1;
774		1197
775	=back	1198	=back
776		1199
777	=head1 AUTHOR	1200	=head1 AUTHOR

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.3 by root, Fri May 23 03:20:53 2008 UTC vs. Revision 1.23 by root, Sat May 24 02:13:52 2008 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.3 by root, Fri May 23 03:20:53 2008 UTC vs.
Revision 1.23 by root, Sat May 24 02:13:52 2008 UTC