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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.13 by root, Fri May 23 06:42:53 2008 UTC vs.
Revision 1.45 by root, Thu May 29 06:40:06 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.
…		…
24	package AnyEvent::DNS;	29	package AnyEvent::DNS;
25		30
26	no warnings;	31	no warnings;
27	use strict;	32	use strict;
28		33
		34	use Socket qw(AF_INET SOCK_DGRAM SOCK_STREAM);
		35
29	use AnyEvent::Util ();	36	use AnyEvent ();
30	use AnyEvent::Handle ();	37	use AnyEvent::Handle ();
		38	use AnyEvent::Util qw(AF_INET6);
31		39
32	=item AnyEvent::DNS::addr $node, $service, $family, $type, $cb->(@addrs)	40	our $VERSION = '1.0';
33		41
34	NOT YET IMPLEMENTED	42	our @DNS_FALLBACK = (v208.67.220.220, v208.67.222.222);
35
36	Tries to resolve the given nodename and service name into sockaddr
37	structures usable to connect to this node and service in a
38	protocol-independent way. It works similarly to the getaddrinfo posix
39	function.
40
41	Example:
42
43	AnyEvent::DNS::addr "google.com", "http", AF_UNSPEC, SOCK_STREAM, sub { ... };
44		43
45	=item AnyEvent::DNS::a $domain, $cb->(@addrs)	44	=item AnyEvent::DNS::a $domain, $cb->(@addrs)
46		45
47	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).
48		51
49	=item AnyEvent::DNS::mx $domain, $cb->(@hostnames)	52	=item AnyEvent::DNS::mx $domain, $cb->(@hostnames)
50		53
51	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
52	first) list of domain names.	55	first) list of domain names.
…		…
62	=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)	65	=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)
63		66
64	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
65	of service records.	68	of service records.
66		69
67	Each srv_rr is an arrayref with the following contents:	70	Each srv_rr is an array reference with the following contents:
68	C<[$priority, $weight, $transport, $target]>.	71	C<[$priority, $weight, $transport, $target]>.
69		72
70	They will be sorted with lowest priority, highest weight first (TODO:	73	They will be sorted with lowest priority, highest weight first (TODO:
71	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).
72		75
73	Example:	76	Example:
74		77
75	AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...	78	AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...
76	# @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )	79	# @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )
…		…
78	=item AnyEvent::DNS::ptr $ipv4_or_6, $cb->(@hostnames)	81	=item AnyEvent::DNS::ptr $ipv4_or_6, $cb->(@hostnames)
79		82
80	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)
81	into it's hostname(s).	84	into it's hostname(s).
82		85
83	Requires the Socket6 module for IPv6 support.
84
85	Example:	86	Example:
86		87
87	AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };	88	AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };
88	# => f.root-servers.net	89	# => f.root-servers.net
89		90
…		…
92	Tries to resolve the given domain and passes all resource records found to	93	Tries to resolve the given domain and passes all resource records found to
93	the callback.	94	the callback.
94		95
95	=cut	96	=cut
96		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
		101
97	sub resolver;	102	sub resolver;
98		103
99	sub a($$) {	104	sub a($$) {
100	my ($domain, $cb) = @_;	105	my ($domain, $cb) = @_;
101		106
102	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 {
103	$cb->(map $_->[3], @_);	116	$cb->(map $_->[3], @_);
104	});	117	});
105	}	118	}
106		119
107	sub mx($$) {	120	sub mx($$) {
…		…
138	}	151	}
139		152
140	sub ptr($$) {	153	sub ptr($$) {
141	my ($ip, $cb) = @_;	154	my ($ip, $cb) = @_;
142		155
143	my $name;	156	$ip = AnyEvent::Socket::parse_address ($ip)
		157	or return $cb->();
144		158
145	if (AnyEvent::Util::dotted_quad $ip) {	159	my $af = AnyEvent::Socket::address_family ($ip);
		160
		161	if ($af == AF_INET) {
146	$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.";
147	} else {	165	} else {
148	require Socket6;	166	return $cb->();
149	$name = join ".",
150	(reverse split //,
151	unpack "H*", Socket6::inet_pton (Socket::AF_INET6, $ip)),
152	"ip6.arpa.";
153	}	167	}
154		168
155	resolver->resolve ($name => "ptr", sub {	169	resolver->resolve ($ip => "ptr", sub {
156	$cb->(map $_->[3], @_);	170	$cb->(map $_->[3], @_);
157	});	171	});
158	}	172	}
159		173
160	sub any($$) {	174	sub any($$) {
161	my ($domain, $cb) = @_;	175	my ($domain, $cb) = @_;
162		176
163	resolver->resolve ($domain => "*", $cb);	177	resolver->resolve ($domain => "*", $cb);
164	}	178	}
165		179
		180	#################################################################################
		181
		182	=back
		183
166	=head2 LOW-LEVEL DNS EN-/DECODING FUNCTIONS	184	=head2 LOW-LEVEL DNS EN-/DECODING FUNCTIONS
167		185
168	=over 4	186	=over 4
169		187
170	=item $AnyEvent::DNS::EDNS0	188	=item $AnyEvent::DNS::EDNS0
171		189
172	This variable decides whether dns_pack automatically enables EDNS0	190	This variable decides whether dns_pack automatically enables EDNS0
173	support. By default, this is disabled (C<0>), but when set to C<1>,	191	support. By default, this is disabled (C<0>), unless overridden by
174	AnyEvent::DNS will use EDNS0 in all requests.	192	C<$ENV{PERL_ANYEVENT_EDNS0}>, but when set to C<1>, AnyEvent::DNS will use
		193	EDNS0 in all requests.
175		194
176	=cut	195	=cut
177		196
178	our $EDNS0 = 0; # set to 1 to enable (partial) edns0	197	our $EDNS0 = $ENV{PERL_ANYEVENT_EDNS0} * 1; # set to 1 to enable (partial) edns0
179		198
180	our %opcode_id = (	199	our %opcode_id = (
181	query => 0,	200	query => 0,
182	iquery => 1,	201	iquery => 1,
183	status => 2,	202	status => 2,
…		…
251	"*" => 255,	270	"*" => 255,
252	);	271	);
253		272
254	our %class_str = reverse %class_id;	273	our %class_str = reverse %class_id;
255		274
256	# names MUST have a trailing dot
257	sub _enc_qname($) {	275	sub _enc_name($) {
258	pack "(C/a)*", (split /\./, shift), ""	276	pack "(C/a)", (split /\./, shift), ""
259	}	277	}
260		278
261	sub _enc_qd() {	279	sub _enc_qd() {
262	(_enc_qname $_->[0]) . pack "nn",	280	(_enc_name $_->[0]) . pack "nn",
263	($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}),	281	($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}),
264	($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] \|\| "in"})	282	($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] \|\| "in"})
265	}	283	}
266		284
267	sub _enc_rr() {	285	sub _enc_rr() {
…		…
321	+ $rcode_id{$req->{rc}} * 0x0001,	339	+ $rcode_id{$req->{rc}} * 0x0001,
322		340
323	scalar @{ $req->{qd} \|\| [] },	341	scalar @{ $req->{qd} \|\| [] },
324	scalar @{ $req->{an} \|\| [] },	342	scalar @{ $req->{an} \|\| [] },
325	scalar @{ $req->{ns} \|\| [] },	343	scalar @{ $req->{ns} \|\| [] },
326	$EDNS0 + scalar @{ $req->{ar} \|\| [] }, # include EDNS0 option here	344	$EDNS0 + scalar @{ $req->{ar} \|\| [] }, # EDNS0 option included here
327		345
328	(join "", map _enc_qd, @{ $req->{qd} \|\| [] }),	346	(join "", map _enc_qd, @{ $req->{qd} \|\| [] }),
329	(join "", map _enc_rr, @{ $req->{an} \|\| [] }),	347	(join "", map _enc_rr, @{ $req->{an} \|\| [] }),
330	(join "", map _enc_rr, @{ $req->{ns} \|\| [] }),	348	(join "", map _enc_rr, @{ $req->{ns} \|\| [] }),
331	(join "", map _enc_rr, @{ $req->{ar} \|\| [] }),	349	(join "", map _enc_rr, @{ $req->{ar} \|\| [] }),
332		350
333	($EDNS0 ? pack "C nnNn", 0, 41, 4096, 0, 0 : "") # EDNS0, 4kiB udp payload size	351	($EDNS0 ? pack "C nnNn", 0, 41, MAX_PKT, 0, 0 : "") # EDNS0 option
334	}	352	}
335		353
336	our $ofs;	354	our $ofs;
337	our $pkt;	355	our $pkt;
338		356
339	# bitches	357	# bitches
340	sub _dec_qname {	358	sub _dec_name {
341	my @res;	359	my @res;
342	my $redir;	360	my $redir;
343	my $ptr = $ofs;	361	my $ptr = $ofs;
344	my $cnt;	362	my $cnt;
345		363
346	while () {	364	while () {
347	return undef if ++$cnt >= 256; # to avoid DoS attacks	365	return undef if ++$cnt >= 256; # to avoid DoS attacks
348		366
349	my $len = ord substr $pkt, $ptr++, 1;	367	my $len = ord substr $pkt, $ptr++, 1;
350		368
351	if ($len & 0xc0) {	369	if ($len >= 0xc0) {
352	$ptr++;	370	$ptr++;
353	$ofs = $ptr if $ptr > $ofs;	371	$ofs = $ptr if $ptr > $ofs;
354	$ptr = (unpack "n", substr $pkt, $ptr - 2, 2) & 0x3fff;	372	$ptr = (unpack "n", substr $pkt, $ptr - 2, 2) & 0x3fff;
355	} elsif ($len) {	373	} elsif ($len) {
356	push @res, substr $pkt, $ptr, $len;	374	push @res, substr $pkt, $ptr, $len;
…		…
361	}	379	}
362	}	380	}
363	}	381	}
364		382
365	sub _dec_qd {	383	sub _dec_qd {
366	my $qname = _dec_qname;	384	my $qname = _dec_name;
367	my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;	385	my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;
368	[$qname, $type_str{$qt} \|\| $qt, $class_str{$qc} \|\| $qc]	386	[$qname, $type_str{$qt} \|\| $qt, $class_str{$qc} \|\| $qc]
369	}	387	}
370		388
371	our %dec_rr = (	389	our %dec_rr = (
372	1 => sub { Socket::inet_ntoa $_ }, # a	390	1 => sub { join ".", unpack "C4", $_ }, # a
373	2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns	391	2 => sub { local $ofs = $ofs - length; _dec_name }, # ns
374	5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname	392	5 => sub { local $ofs = $ofs - length; _dec_name }, # cname
375	6 => sub {	393	6 => sub {
376	local $ofs = $ofs - length;	394	local $ofs = $ofs - length;
377	my $mname = _dec_qname;	395	my $mname = _dec_name;
378	my $rname = _dec_qname;	396	my $rname = _dec_name;
379	($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)	397	($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)
380	}, # soa	398	}, # soa
381	11 => sub { ((Socket::inet_aton substr $_, 0, 4), unpack "C a*", substr $_, 4) }, # wks	399	11 => sub { ((join ".", unpack "C4", $_), unpack "C a*", substr $_, 4) }, # wks
382	12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr	400	12 => sub { local $ofs = $ofs - length; _dec_name }, # ptr
383	13 => sub { unpack "C/a C/a", $_ }, # hinfo	401	13 => sub { unpack "C/a* C/a*", $_ }, # hinfo
384	15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_qname) }, # mx	402	15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_name) }, # mx
385	16 => sub { unpack "(C/a)*", $_ }, # txt	403	16 => sub { unpack "(C/a)", $_ }, # txt
386	28 => sub { sprintf "%04x:%04x:%04x:%04x:%04x:%04x:%04x:%04x", unpack "n8" }, # aaaa	404	28 => sub { AnyEvent::Socket::format_address ($_) }, # aaaa
387	33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_qname) }, # srv	405	33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_name) }, # srv
388	99 => sub { unpack "(C/a)*", $_ }, # spf	406	99 => sub { unpack "(C/a)", $_ }, # spf
389	);	407	);
390		408
391	sub _dec_rr {	409	sub _dec_rr {
392	my $qname = _dec_qname;	410	my $name = _dec_name;
393		411
394	my ($rt, $rc, $ttl, $rdlen) = unpack "nn N n", substr $pkt, $ofs; $ofs += 10;	412	my ($rt, $rc, $ttl, $rdlen) = unpack "nn N n", substr $pkt, $ofs; $ofs += 10;
395	local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen;	413	local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen;
396		414
397	[	415	[
398	$qname,	416	$name,
399	$type_str{$rt} \|\| $rt,	417	$type_str{$rt} \|\| $rt,
400	$class_str{$rc} \|\| $rc,	418	$class_str{$rc} \|\| $rc,
401	($dec_rr{$rt} \|\| sub { $_ })->(),	419	($dec_rr{$rt} \|\| sub { $_ })->(),
402	]	420	]
403	}	421	}
…		…
526	our $RESOLVER;	544	our $RESOLVER;
527		545
528	sub resolver() {	546	sub resolver() {
529	$RESOLVER \|\| do {	547	$RESOLVER \|\| do {
530	$RESOLVER = new AnyEvent::DNS;	548	$RESOLVER = new AnyEvent::DNS;
531	$RESOLVER->load_resolv_conf;	549	$RESOLVER->os_config;
532	$RESOLVER	550	$RESOLVER
533	}	551	}
534	}	552	}
535		553
536	=item $resolver = new AnyEvent::DNS key => value...	554	=item $resolver = new AnyEvent::DNS key => value...
…		…
541		559
542	=over 4	560	=over 4
543		561
544	=item server => [...]	562	=item server => [...]
545		563
546	A list of server addressses (default: C<v127.0.0.1>) in network format (4	564	A list of server addresses (default: C<v127.0.0.1>) in network format
547	octets for IPv4, 16 octets for IPv6 - not yet supported).	565	(i.e. as returned by C<AnyEvent::Socket::parse_address> - both IPv4 and
		566	IPv6 are supported).
548		567
549	=item timeout => [...]	568	=item timeout => [...]
550		569
551	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
552	three retries with individual time-outs of 2, 5 and 5 seconds, use C<[2,	571	three retries with individual time-outs of 2, 5 and 5 seconds, use C<[2,
…		…
561	The number of dots (default: C<1>) that a name must have so that the resolver	580	The number of dots (default: C<1>) that a name must have so that the resolver
562	tries to resolve the name without any suffixes first.	581	tries to resolve the name without any suffixes first.
563		582
564	=item max_outstanding => $integer	583	=item max_outstanding => $integer
565		584
566	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
567	limits the numbe rof outstanding requests to C<$n> (default: C<10>), that means	586	option limits the number of outstanding requests to C<$integer>
568	if you request more than this many requests, then the additional requests will be queued	587	(default: C<10>), that means if you request more than this many requests,
569	until some other requests have been resolved.	588	then the additional requests will be queued until some other requests have
		589	been resolved.
570		590
571	=item reuse => $seconds	591	=item reuse => $seconds
572		592
573	The number of seconds (default: C<60>) that a query id cannot be re-used	593	The number of seconds (default: C<300>) that a query id cannot be re-used
574	after a request. Since AnyEvent::DNS will only allocate up to 30000 ID's	594	after a timeout. If there as no time-out then query id's can be reused
575	at the same time, the long-term maximum number of requests per second is	595	immediately.
576	C<30000 / $seconds> (and thus C<500> requests/s by default).
577		596
578	=back	597	=back
579		598
580	=cut	599	=cut
581		600
582	sub new {	601	sub new {
583	my ($class, %arg) = @_;	602	my ($class, %arg) = @_;
584		603
		604	# try to create a ipv4 and an ipv6 socket
		605	# only fail when we cnanot create either
		606
585	socket my $fh, &Socket::AF_INET, &Socket::SOCK_DGRAM, 0	607	socket my $fh4, AF_INET , &Socket::SOCK_DGRAM, 0;
586	or Carp::croak "socket: $!";	608	socket my $fh6, AF_INET6, &Socket::SOCK_DGRAM, 0;
587		609
588	AnyEvent::Util::fh_nonblocking $fh, 1;	610	$fh4 \|\| $fh6
		611	or Carp::croak "unable to create either an IPv6 or an IPv4 socket";
589		612
590	my $self = bless {	613	my $self = bless {
591	server => [v127.0.0.1],	614	server => [],
592	timeout => [2, 5, 5],	615	timeout => [2, 5, 5],
593	search => [],	616	search => [],
594	ndots => 1,	617	ndots => 1,
595	max_outstanding => 10,	618	max_outstanding => 10,
596	reuse => 60, # reuse id's after 5 minutes only, if possible	619	reuse => 300, # reuse id's after 5 minutes only, if possible
597	%arg,	620	%arg,
598	fh => $fh,
599	reuse_q => [],	621	reuse_q => [],
600	}, $class;	622	}, $class;
601		623
602	# search should default to gethostname's domain	624	# search should default to gethostname's domain
603	# but perl lacks a good posix module	625	# but perl lacks a good posix module
604		626
605	Scalar::Util::weaken (my $wself = $self);	627	Scalar::Util::weaken (my $wself = $self);
		628
		629	if ($fh4) {
		630	AnyEvent::Util::fh_nonblocking $fh4, 1;
		631	$self->{fh4} = $fh4;
606	$self->{rw} = AnyEvent->io (fh => $fh, poll => "r", cb => sub { $wself->_recv });	632	$self->{rw4} = AnyEvent->io (fh => $fh4, poll => "r", cb => sub {
		633	if (my $peer = recv $fh4, my $pkt, MAX_PKT, 0) {
		634	$wself->_recv ($pkt, $peer);
		635	}
		636	});
		637	}
		638
		639	if ($fh6) {
		640	$self->{fh6} = $fh6;
		641	AnyEvent::Util::fh_nonblocking $fh6, 1;
		642	$self->{rw6} = AnyEvent->io (fh => $fh6, poll => "r", cb => sub {
		643	if (my $peer = recv $fh6, my $pkt, MAX_PKT, 0) {
		644	$wself->_recv ($pkt, $peer);
		645	}
		646	});
		647	}
607		648
608	$self->_compile;	649	$self->_compile;
609		650
610	$self	651	$self
611	}	652	}
612		653
613	=item $resolver->parse_resolv_conv ($string)	654	=item $resolver->parse_resolv_conv ($string)
614		655
615	Parses the given string a sif it were a F<resolv.conf> file. The following	656	Parses the given string as if it were a F<resolv.conf> file. The following
616	directives are supported:	657	directives are supported (but not necessarily implemented).
617		658
618	C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,	659	C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,
619	C<options> (C<timeout>, C<attempts>, C<ndots>).	660	C<options> (C<timeout>, C<attempts>, C<ndots>).
620		661
621	Everything else is silently ignored.	662	Everything else is silently ignored.
…		…
633	for (split /\n/, $resolvconf) {	674	for (split /\n/, $resolvconf) {
634	if (/^\s*#/) {	675	if (/^\s*#/) {
635	# comment	676	# comment
636	} elsif (/^\snameserver\s+(\S+)\s$/i) {	677	} elsif (/^\snameserver\s+(\S+)\s$/i) {
637	my $ip = $1;	678	my $ip = $1;
638	if (AnyEvent::Util::dotted_quad $ip) {	679	if (my $ipn = AnyEvent::Socket::parse_address ($ip)) {
639	push @{ $self->{server} }, AnyEvent::Util::socket_inet_aton $ip;	680	push @{ $self->{server} }, $ipn;
640	} else {	681	} else {
641	warn "nameserver $ip invalid and ignored\n";	682	warn "nameserver $ip invalid and ignored\n";
642	}	683	}
643	} elsif (/^\sdomain\s+(\S)\s+$/i) {	684	} elsif (/^\sdomain\s+(\S)\s+$/i) {
644	$self->{search} = [$1];	685	$self->{search} = [$1];
…		…
665	if $attempts;	706	if $attempts;
666		707
667	$self->_compile;	708	$self->_compile;
668	}	709	}
669		710
670	=item $resolver->load_resolv_conf	711	=item $resolver->os_config
671		712
672	Tries to load and parse F</etc/resolv.conf>. If there will ever be windows	713	Tries so load and parse F</etc/resolv.conf> on portable operating systems. Tries various
673	support, then this function will do the right thing under windows, too.	714	egregious hacks on windows to force the DNS servers and searchlist out of the system.
674		715
675	=cut	716	=cut
676		717
677	sub load_resolv_conf {	718	sub os_config {
678	my ($self) = @_;	719	my ($self) = @_;
679		720
		721	$self->{server} = [];
		722	$self->{search} = [];
		723
		724	if (AnyEvent::WIN32 \|\| $^O =~ /cygwin/i) {
		725	no strict 'refs';
		726
		727	# there are many options to find the current nameservers etc. on windows
		728	# all of them don't work consistently:
		729	# - the registry thing needs separate code on win32 native vs. cygwin
		730	# - the registry layout differs between windows versions
		731	# - calling windows api functions doesn't work on cygwin
		732	# - ipconfig uses locale-specific messages
		733
		734	# we use ipconfig parsing because, despite all it's brokenness,
		735	# it seems most stable in practise.
		736	# for good measure, we append a fallback nameserver to our list.
		737
		738	if (open my $fh, "ipconfig /all \|") {
		739	# parsing strategy: we go through the output and look for
		740	# :-lines with DNS in them. everything in those is regarded as
		741	# either a nameserver (if it parses as an ip address), or a suffix
		742	# (all else).
		743
		744	my $dns;
		745	while (<$fh>) {
		746	if (s/^\s.\bdns\b.://i) {
		747	$dns = 1;
		748	} elsif (/^\S/ \|\| /^\s[^:]{16,}: /) {
		749	$dns = 0;
		750	}
		751	if ($dns && /^\s(\S+)\s$/) {
		752	my $s = $1;
		753	$s =~ s/%\d+(?!\S)//; # get rid of scope id
		754	if (my $ipn = AnyEvent::Socket::parse_address ($s)) {
		755	push @{ $self->{server} }, $ipn;
		756	} else {
		757	push @{ $self->{search} }, $s;
		758	}
		759	}
		760	}
		761
		762	# always add one fallback server
		763	push @{ $self->{server} }, $DNS_FALLBACK[rand @DNS_FALLBACK];
		764
		765	$self->_compile;
		766	}
		767	} else {
		768	# try resolv.conf everywhere
		769
680	open my $fh, "</etc/resolv.conf"	770	if (open my $fh, "</etc/resolv.conf") {
681	or return;
682
683	local $/;	771	local $/;
684	$self->parse_resolv_conf (<$fh>);	772	$self->parse_resolv_conf (<$fh>);
		773	}
		774	}
685	}	775	}
686		776
687	sub _compile {	777	sub _compile {
688	my $self = shift;	778	my $self = shift;
		779
		780	my %search; $self->{search} = [grep 0 < length, grep !$search{$_}++, @{ $self->{search} }];
		781	my %server; $self->{server} = [grep 0 < length, grep !$server{$_}++, @{ $self->{server} }];
		782
		783	unless (@{ $self->{server} }) {
		784	# use 127.0.0.1 by default, and one opendns nameserver as fallback
		785	$self->{server} = [v127.0.0.1, $DNS_FALLBACK[rand @DNS_FALLBACK]];
		786	}
689		787
690	my @retry;	788	my @retry;
691		789
692	for my $timeout (@{ $self->{timeout} }) {	790	for my $timeout (@{ $self->{timeout} }) {
693	for my $server (@{ $self->{server} }) {	791	for my $server (@{ $self->{server} }) {
…		…
711	$NOW = time;	809	$NOW = time;
712	$id->[1]->($res);	810	$id->[1]->($res);
713	}	811	}
714		812
715	sub _recv {	813	sub _recv {
716	my ($self) = @_;	814	my ($self, $pkt, $peer) = @_;
717		815
718	while (my $peer = recv $self->{fh}, my $res, 4096, 0) {	816	# we ignore errors (often one gets port unreachable, but there is
		817	# no good way to take advantage of that.
		818
719	my ($port, $host) = Socket::unpack_sockaddr_in $peer;	819	my ($port, $host) = AnyEvent::Socket::unpack_sockaddr ($peer);
720		820
721	return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };	821	return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };
722		822
723	$self->_feed ($res);	823	$self->_feed ($pkt);
		824	}
		825
		826	sub _free_id {
		827	my ($self, $id, $timeout) = @_;
		828
		829	if ($timeout) {
		830	# we need to block the id for a while
		831	$self->{id}{$id} = 1;
		832	push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $id];
		833	} else {
		834	# we can quickly recycle the id
		835	delete $self->{id}{$id};
724	}	836	}
725	}
726		837
		838	--$self->{outstanding};
		839	$self->_scheduler;
		840	}
		841
		842	# execute a single request, involves sending it with timeouts to multiple servers
727	sub _exec {	843	sub _exec {
728	my ($self, $req, $retry) = @_;	844	my ($self, $req) = @_;
729		845
		846	my $retry; # of retries
		847	my $do_retry;
		848
		849	$do_retry = sub {
730	if (my $retry_cfg = $self->{retry}[$retry]) {	850	my $retry_cfg = $self->{retry}[$retry++]
		851	or do {
		852	# failure
		853	$self->_free_id ($req->[2], $retry > 1);
		854	undef $do_retry; return $req->[1]->();
		855	};
		856
731	my ($server, $timeout) = @$retry_cfg;	857	my ($server, $timeout) = @$retry_cfg;
732		858
733	$self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {	859	$self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {
734	$NOW = time;	860	$NOW = time;
735		861
736	# timeout, try next	862	# timeout, try next
737	$self->_exec ($req, $retry + 1);	863	&$do_retry;
738	}), sub {	864	}), sub {
739	my ($res) = @_;	865	my ($res) = @_;
740		866
741	if ($res->{tc}) {	867	if ($res->{tc}) {
742	# success, but truncated, so use tcp	868	# success, but truncated, so use tcp
743	AnyEvent::Util::tcp_connect +(Socket::inet_ntoa $server), 53, sub {	869	AnyEvent::Socket::tcp_connect (AnyEvent::Socket::format_address ($server), DOMAIN_PORT, sub {
744	my ($fh) = @_	870	my ($fh) = @_
745	or return $self->_exec ($req, $retry + 1);	871	or return &$do_retry;
746		872
747	my $handle = new AnyEvent::Handle	873	my $handle = new AnyEvent::Handle
748	fh => $fh,	874	fh => $fh,
749	on_error => sub {	875	on_error => sub {
750	# failure, try next	876	# failure, try next
751	$self->_exec ($req, $retry + 1);	877	&$do_retry;
752	};	878	};
753		879
754	$handle->push_write (pack "n/a", $req->[0]);	880	$handle->push_write (pack "n/a", $req->[0]);
755	$handle->push_read_chunk (2, sub {	881	$handle->push_read (chunk => 2, sub {
756	$handle->unshift_read_chunk ((unpack "n", $_[1]), sub {	882	$handle->unshift_read (chunk => (unpack "n", $_[1]), sub {
757	$self->_feed ($_[1]);	883	$self->_feed ($_[1]);
758	});	884	});
759	});	885	});
760	shutdown $fh, 1;	886	shutdown $fh, 1;
761		887
762	}, sub { $timeout };	888	}, sub { $timeout });
763		889
764	} else {	890	} else {
765	# success	891	# success
766	$self->{id}{$req->[2]} = 1;	892	$self->_free_id ($req->[2], $retry > 1);
767	push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];	893	undef $do_retry; return $req->[1]->($res);
768	--$self->{outstanding};
769	$self->_scheduler;
770
771	$req->[1]->($res);
772	}	894	}
773	}];	895	}];
		896
		897	my $sa = AnyEvent::Socket::pack_sockaddr (DOMAIN_PORT, $server);
774		898
775	send $self->{fh}, $req->[0], 0, Socket::pack_sockaddr_in 53, $server;	899	my $fh = AF_INET == Socket::sockaddr_family ($sa)
776	} else {	900	? $self->{fh4} : $self->{fh6}
777	# failure	901	or return &$do_retry;
778	$self->{id}{$req->[2]} = 1;
779	push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];
780	--$self->{outstanding};
781	$self->_scheduler;
782		902
783	$req->[1]->();	903	send $fh, $req->[0], 0, $sa;
784	}	904	};
		905
		906	&$do_retry;
785	}	907	}
786		908
787	sub _scheduler {	909	sub _scheduler {
788	my ($self) = @_;	910	my ($self) = @_;
789		911
…		…
810	while () {	932	while () {
811	$req->[2] = int rand 65536;	933	$req->[2] = int rand 65536;
812	last unless exists $self->{id}{$req->[2]};	934	last unless exists $self->{id}{$req->[2]};
813	}	935	}
814		936
		937	++$self->{outstanding};
815	$self->{id}{$req->[2]} = 1;	938	$self->{id}{$req->[2]} = 1;
816	substr $req->[0], 0, 2, pack "n", $req->[2];	939	substr $req->[0], 0, 2, pack "n", $req->[2];
817		940
818	++$self->{outstanding};
819	$self->_exec ($req, 0);	941	$self->_exec ($req);
820	}	942	}
821	}	943	}
822		944
823	=item $resolver->request ($req, $cb->($res))	945	=item $resolver->request ($req, $cb->($res))
824		946
…		…
836	$self->_scheduler;	958	$self->_scheduler;
837	}	959	}
838		960
839	=item $resolver->resolve ($qname, $qtype, %options, $cb->($rcode, @rr))	961	=item $resolver->resolve ($qname, $qtype, %options, $cb->($rcode, @rr))
840		962
841	Queries the DNS for the given domain name C<$qname> of type C<$qtype> (a	963	Queries the DNS for the given domain name C<$qname> of type C<$qtype>.
842	qtype of "*" is supported and means "any").	964
		965	A C<$qtype> is either a numerical query type (e.g. C<1> for A recods) or
		966	a lowercase name (you have to look at the source to see which aliases are
		967	supported, but all types from RFC 1034, C<aaaa>, C<srv>, C<spf> and a few
		968	more are known to this module). A qtype of "*" is supported and means
		969	"any" record type.
843		970
844	The callback will be invoked with a list of matching result records or	971	The callback will be invoked with a list of matching result records or
845	none on any error or if the name could not be found.	972	none on any error or if the name could not be found.
846		973
847	CNAME chains (although illegal) are followed up to a length of 8.	974	CNAME chains (although illegal) are followed up to a length of 8.
848		975
		976	The callback will be invoked with an result code in string form (noerror,
		977	formerr, servfail, nxdomain, notimp, refused and so on), or numerical
		978	form if the result code is not supported. The remaining arguments are
		979	arraryefs of the form C<[$name, $type, $class, @data>], where C<$name> is
		980	the domain name, C<$type> a type string or number, C<$class> a class name
		981	and @data is resource-record-dependent data. For C<a> records, this will
		982	be the textual IPv4 addresses, for C<ns> or C<cname> records this will be
		983	a domain name, for C<txt> records these are all the strings and so on.
		984
		985	All types mentioned in RFC 1034, C<aaaa>, C<srv> and C<spf> are
		986	decoded. All resource records not known to this module will just return
		987	the raw C<rdata> field as fourth entry.
		988
849	Note that this resolver is just a stub resolver: it requires a nameserver	989	Note that this resolver is just a stub resolver: it requires a name server
850	supporting recursive queries, will not do any recursive queries itself and	990	supporting recursive queries, will not do any recursive queries itself and
851	is not secure when used against an untrusted name server.	991	is not secure when used against an untrusted name server.
852		992
853	The following options are supported:	993	The following options are supported:
854		994
…		…
863		1003
864	=item accept => [$type...]	1004	=item accept => [$type...]
865		1005
866	Lists the acceptable result types: only result types in this set will be	1006	Lists the acceptable result types: only result types in this set will be
867	accepted and returned. The default includes the C<$qtype> and nothing	1007	accepted and returned. The default includes the C<$qtype> and nothing
868	else.	1008	else. If this list includes C<cname>, then CNAME-chains will not be
		1009	followed (because you asked for the CNAME record).
869		1010
870	=item class => "class"	1011	=item class => "class"
871		1012
872	Specify the query class ("in" for internet, "ch" for chaosnet and "hs" for	1013	Specify the query class ("in" for internet, "ch" for chaosnet and "hs" for
873	hesiod are the only ones making sense). The default is "in", of course.	1014	hesiod are the only ones making sense). The default is "in", of course.
874		1015
875	=back	1016	=back
876		1017
877	Examples:	1018	Examples:
878		1019
879	$res->resolve ("ruth.plan9.de", "a", sub {	1020	# full example, you can paste this into perl
880	warn Dumper [@_];	1021	use Data::Dumper;
881	});	1022	use AnyEvent::DNS;
		1023	AnyEvent::DNS::resolver->resolve (
		1024	"google.com", "*", my $cv = AnyEvent->condvar);
		1025	warn Dumper [$cv->recv];
882		1026
		1027	# shortened result:
883	[	1028	# [
		1029	# [ 'google.com', 'soa', 'in', 'ns1.google.com', 'dns-admin.google.com',
		1030	# 2008052701, 7200, 1800, 1209600, 300 ],
884	[	1031	# [
885	'ruth.schmorp.de',	1032	# 'google.com', 'txt', 'in',
886	'a',	1033	# 'v=spf1 include:_netblocks.google.com ~all'
887	'in',	1034	# ],
888	'129.13.162.95'	1035	# [ 'google.com', 'a', 'in', '64.233.187.99' ],
		1036	# [ 'google.com', 'mx', 'in', 10, 'smtp2.google.com' ],
		1037	# [ 'google.com', 'ns', 'in', 'ns2.google.com' ],
889	]	1038	# ]
		1039
		1040	# resolve a records:
		1041	$res->resolve ("ruth.plan9.de", "a", sub { warn Dumper [@_] });
		1042
		1043	# result:
		1044	# [
		1045	# [ 'ruth.schmorp.de', 'a', 'in', '129.13.162.95' ]
890	]	1046	# ]
891		1047
		1048	# resolve any records, but return only a and aaaa records:
892	$res->resolve ("test1.laendle", "*",	1049	$res->resolve ("test1.laendle", "*",
893	accept => ["a", "aaaa"],	1050	accept => ["a", "aaaa"],
894	sub {	1051	sub {
895	warn Dumper [@_];	1052	warn Dumper [@_];
896	}	1053	}
897	);	1054	);
898		1055
899	[	1056	# result:
900	[	1057	# [
901	'test1.laendle',	1058	# [ 'test1.laendle', 'a', 'in', '10.0.0.255' ],
902	'a',	1059	# [ 'test1.laendle', 'aaaa', 'in', '3ffe:1900:4545:0002:0240:0000:0000:f7e1' ]
903	'in',
904	'10.0.0.255'
905	],
906	[
907	'test1.laendle',
908	'aaaa',
909	'in',
910	'3ffe:1900:4545:0002:0240:0000:0000:f7e1'
911	]	1060	# ]
912	]
913		1061
914	=cut	1062	=cut
915		1063
916	sub resolve($%) {	1064	sub resolve($%) {
917	my $cb = pop;	1065	my $cb = pop;
…		…
930	my %atype = $opt{accept}	1078	my %atype = $opt{accept}
931	? map +($_ => 1), @{ $opt{accept} }	1079	? map +($_ => 1), @{ $opt{accept} }
932	: ($qtype => 1);	1080	: ($qtype => 1);
933		1081
934	# advance in searchlist	1082	# advance in searchlist
935	my $do_search; $do_search = sub {	1083	my ($do_search, $do_req);
		1084
		1085	$do_search = sub {
936	@search	1086	@search
937	or return $cb->();	1087	or (undef $do_search), (undef $do_req), return $cb->();
938		1088
939	(my $name = lc "$qname." . shift @search) =~ s/\.$//;	1089	(my $name = lc "$qname." . shift @search) =~ s/\.$//;
940	my $depth = 2;	1090	my $depth = 2;
941		1091
942	# advance in cname-chain	1092	# advance in cname-chain
943	my $do_req; $do_req = sub {	1093	$do_req = sub {
944	$self->request ({	1094	$self->request ({
945	rd => 1,	1095	rd => 1,
946	qd => [[$name, $qtype, $class]],	1096	qd => [[$name, $qtype, $class]],
947	}, sub {	1097	}, sub {
948	my ($res) = @_	1098	my ($res) = @_
…		…
952		1102
953	while () {	1103	while () {
954	# results found?	1104	# results found?
955	my @rr = grep $name eq lc $_->[0] && ($atype{"*"} \|\| $atype{$_->[1]}), @{ $res->{an} };	1105	my @rr = grep $name eq lc $_->[0] && ($atype{"*"} \|\| $atype{$_->[1]}), @{ $res->{an} };
956		1106
957	return $cb->(@rr)	1107	(undef $do_search), (undef $do_req), return $cb->(@rr)
958	if @rr;	1108	if @rr;
959		1109
960	# see if there is a cname we can follow	1110	# see if there is a cname we can follow
961	my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} };	1111	my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} };
962		1112
…		…
983	};	1133	};
984		1134
985	$do_search->();	1135	$do_search->();
986	}	1136	}
987		1137
		1138	use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end
		1139
988	1;	1140	1;
989		1141
990	=back	1142	=back
991		1143
992	=head1 AUTHOR	1144	=head1 AUTHOR

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.13 by root, Fri May 23 06:42:53 2008 UTC vs. Revision 1.45 by root, Thu May 29 06:40:06 2008 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.13 by root, Fri May 23 06:42:53 2008 UTC vs.
Revision 1.45 by root, Thu May 29 06:40:06 2008 UTC