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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.7 by root, Fri May 23 05:30:59 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.
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 ();
26	use AnyEvent::Handle ();	37	use AnyEvent::Handle ();
		38	use AnyEvent::Util qw(AF_INET6);
27		39
28	=item AnyEvent::DNS::addr $node, $service, $family, $type, $cb->(@addrs)	40	our $VERSION = '1.0';
29		41
30	NOT YET IMPLEMENTED	42	our @DNS_FALLBACK = (v208.67.220.220, v208.67.222.222);
31
32	Tries to resolve the given nodename and service name into sockaddr
33	structures usable to connect to this node and service in a
34	protocol-independent way. It works similarly to the getaddrinfo posix
35	function.
36
37	Example:
38
39	AnyEvent::DNS::addr "google.com", "http", AF_UNSPEC, SOCK_STREAM, sub { ... };
40		43
41	=item AnyEvent::DNS::a $domain, $cb->(@addrs)	44	=item AnyEvent::DNS::a $domain, $cb->(@addrs)
42		45
43	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).
44		51
45	=item AnyEvent::DNS::mx $domain, $cb->(@hostnames)	52	=item AnyEvent::DNS::mx $domain, $cb->(@hostnames)
46		53
47	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
48	first) list of domain names.	55	first) list of domain names.
…		…
58	=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)	65	=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)
59		66
60	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
61	of service records.	68	of service records.
62		69
63	Each srv_rr is an arrayref with the following contents:	70	Each srv_rr is an array reference with the following contents:
64	C<[$priority, $weight, $transport, $target]>.	71	C<[$priority, $weight, $transport, $target]>.
65		72
66	They will be sorted with lowest priority, highest weight first (TODO:	73	They will be sorted with lowest priority, highest weight first (TODO:
67	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).
68		75
69	Example:	76	Example:
70		77
71	AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...	78	AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...
72	# @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )	79	# @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )
…		…
74	=item AnyEvent::DNS::ptr $ipv4_or_6, $cb->(@hostnames)	81	=item AnyEvent::DNS::ptr $ipv4_or_6, $cb->(@hostnames)
75		82
76	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)
77	into it's hostname(s).	84	into it's hostname(s).
78		85
79	Requires the Socket6 module for IPv6 support.
80
81	Example:	86	Example:
82		87
83	AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };	88	AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };
84	# => f.root-servers.net	89	# => f.root-servers.net
85		90
…		…
88	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
89	the callback.	94	the callback.
90		95
91	=cut	96	=cut
92		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
93	sub resolver;	102	sub resolver;
94		103
95	sub a($$) {	104	sub a($$) {
96	my ($domain, $cb) = @_;	105	my ($domain, $cb) = @_;
97		106
98	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 {
99	$cb->(map $_->[3], @_);	116	$cb->(map $_->[3], @_);
100	});	117	});
101	}	118	}
102		119
103	sub mx($$) {	120	sub mx($$) {
…		…
134	}	151	}
135		152
136	sub ptr($$) {	153	sub ptr($$) {
137	my ($ip, $cb) = @_;	154	my ($ip, $cb) = @_;
138		155
139	my $name;	156	$ip = AnyEvent::Socket::parse_address ($ip)
		157	or return $cb->();
140		158
141	if (AnyEvent::Util::dotted_quad $ip) {	159	my $af = AnyEvent::Socket::address_family ($ip);
		160
		161	if ($af == AF_INET) {
142	$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.";
143	} else {	165	} else {
144	require Socket6;	166	return $cb->();
145	$name = join ".",
146	(reverse split //,
147	unpack "H*", Socket6::inet_pton (Socket::AF_INET6, $ip)),
148	"ip6.arpa.";
149	}	167	}
150		168
151	resolver->resolve ($name => "ptr", sub {	169	resolver->resolve ($ip => "ptr", sub {
152	$cb->(map $_->[3], @_);	170	$cb->(map $_->[3], @_);
153	});	171	});
154	}	172	}
155		173
156	sub any($$) {	174	sub any($$) {
157	my ($domain, $cb) = @_;	175	my ($domain, $cb) = @_;
158		176
159	resolver->resolve ($domain => "*", $cb);	177	resolver->resolve ($domain => "*", $cb);
160	}	178	}
161		179
		180	#################################################################################
		181
		182	=back
		183
162	=head2 DNS EN-/DECODING FUNCTIONS	184	=head2 LOW-LEVEL DNS EN-/DECODING FUNCTIONS
163		185
164	=over 4	186	=over 4
165		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
166	=cut	195	=cut
		196
		197	our $EDNS0 = $ENV{PERL_ANYEVENT_EDNS0} * 1; # set to 1 to enable (partial) edns0
167		198
168	our %opcode_id = (	199	our %opcode_id = (
169	query => 0,	200	query => 0,
170	iquery => 1,	201	iquery => 1,
171	status => 2,	202	status => 2,
…		…
239	"*" => 255,	270	"*" => 255,
240	);	271	);
241		272
242	our %class_str = reverse %class_id;	273	our %class_str = reverse %class_id;
243		274
244	# names MUST have a trailing dot
245	sub _enc_qname($) {	275	sub _enc_name($) {
246	pack "(C/a)*", (split /\./, shift), ""	276	pack "(C/a)", (split /\./, shift), ""
247	}	277	}
248		278
249	sub _enc_qd() {	279	sub _enc_qd() {
250	(_enc_qname $_->[0]) . pack "nn",	280	(_enc_name $_->[0]) . pack "nn",
251	($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}),	281	($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}),
252	($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] \|\| "in"})	282	($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] \|\| "in"})
253	}	283	}
254		284
255	sub _enc_rr() {	285	sub _enc_rr() {
…		…
309	+ $rcode_id{$req->{rc}} * 0x0001,	339	+ $rcode_id{$req->{rc}} * 0x0001,
310		340
311	scalar @{ $req->{qd} \|\| [] },	341	scalar @{ $req->{qd} \|\| [] },
312	scalar @{ $req->{an} \|\| [] },	342	scalar @{ $req->{an} \|\| [] },
313	scalar @{ $req->{ns} \|\| [] },	343	scalar @{ $req->{ns} \|\| [] },
314	1 + scalar @{ $req->{ar} \|\| [] }, # include EDNS0 option	344	$EDNS0 + scalar @{ $req->{ar} \|\| [] }, # EDNS0 option included here
315		345
316	(join "", map _enc_qd, @{ $req->{qd} \|\| [] }),	346	(join "", map _enc_qd, @{ $req->{qd} \|\| [] }),
317	(join "", map _enc_rr, @{ $req->{an} \|\| [] }),	347	(join "", map _enc_rr, @{ $req->{an} \|\| [] }),
318	(join "", map _enc_rr, @{ $req->{ns} \|\| [] }),	348	(join "", map _enc_rr, @{ $req->{ns} \|\| [] }),
319	(join "", map _enc_rr, @{ $req->{ar} \|\| [] }),	349	(join "", map _enc_rr, @{ $req->{ar} \|\| [] }),
320		350
321	(pack "C nnNn", 0, 41, 4000, 0, 0) # EDNS0, 4k udp payload size	351	($EDNS0 ? pack "C nnNn", 0, 41, MAX_PKT, 0, 0 : "") # EDNS0 option
322	}	352	}
323		353
324	our $ofs;	354	our $ofs;
325	our $pkt;	355	our $pkt;
326		356
327	# bitches	357	# bitches
328	sub _dec_qname {	358	sub _dec_name {
329	my @res;	359	my @res;
330	my $redir;	360	my $redir;
331	my $ptr = $ofs;	361	my $ptr = $ofs;
332	my $cnt;	362	my $cnt;
333		363
334	while () {	364	while () {
335	return undef if ++$cnt >= 256; # to avoid DoS attacks	365	return undef if ++$cnt >= 256; # to avoid DoS attacks
336		366
337	my $len = ord substr $pkt, $ptr++, 1;	367	my $len = ord substr $pkt, $ptr++, 1;
338		368
339	if ($len & 0xc0) {	369	if ($len >= 0xc0) {
340	$ptr++;	370	$ptr++;
341	$ofs = $ptr if $ptr > $ofs;	371	$ofs = $ptr if $ptr > $ofs;
342	$ptr = (unpack "n", substr $pkt, $ptr - 2, 2) & 0x3fff;	372	$ptr = (unpack "n", substr $pkt, $ptr - 2, 2) & 0x3fff;
343	} elsif ($len) {	373	} elsif ($len) {
344	push @res, substr $pkt, $ptr, $len;	374	push @res, substr $pkt, $ptr, $len;
…		…
349	}	379	}
350	}	380	}
351	}	381	}
352		382
353	sub _dec_qd {	383	sub _dec_qd {
354	my $qname = _dec_qname;	384	my $qname = _dec_name;
355	my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;	385	my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;
356	[$qname, $type_str{$qt} \|\| $qt, $class_str{$qc} \|\| $qc]	386	[$qname, $type_str{$qt} \|\| $qt, $class_str{$qc} \|\| $qc]
357	}	387	}
358		388
359	our %dec_rr = (	389	our %dec_rr = (
360	1 => sub { Socket::inet_ntoa $_ }, # a	390	1 => sub { join ".", unpack "C4", $_ }, # a
361	2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns	391	2 => sub { local $ofs = $ofs - length; _dec_name }, # ns
362	5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname	392	5 => sub { local $ofs = $ofs - length; _dec_name }, # cname
363	6 => sub {	393	6 => sub {
364	local $ofs = $ofs - length;	394	local $ofs = $ofs - length;
365	my $mname = _dec_qname;	395	my $mname = _dec_name;
366	my $rname = _dec_qname;	396	my $rname = _dec_name;
367	($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)	397	($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)
368	}, # soa	398	}, # soa
369	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
370	12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr	400	12 => sub { local $ofs = $ofs - length; _dec_name }, # ptr
371	13 => sub { unpack "C/a C/a", $_ }, # hinfo	401	13 => sub { unpack "C/a* C/a*", $_ }, # hinfo
372	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
373	16 => sub { unpack "(C/a)*", $_ }, # txt	403	16 => sub { unpack "(C/a)", $_ }, # txt
374	28 => sub { sprintf "%04x:%04x:%04x:%04x:%04x:%04x:%04x:%04x", unpack "n8" }, # aaaa	404	28 => sub { AnyEvent::Socket::format_address ($_) }, # aaaa
375	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
376	99 => sub { unpack "(C/a)*", $_ }, # spf	406	99 => sub { unpack "(C/a)", $_ }, # spf
377	);	407	);
378		408
379	sub _dec_rr {	409	sub _dec_rr {
380	my $qname = _dec_qname;	410	my $name = _dec_name;
381		411
382	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;
383	local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen;	413	local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen;
384		414
385	[	415	[
386	$qname,	416	$name,
387	$type_str{$rt} \|\| $rt,	417	$type_str{$rt} \|\| $rt,
388	$class_str{$rc} \|\| $rc,	418	$class_str{$rc} \|\| $rc,
389	($dec_rr{$rt} \|\| sub { $_ })->(),	419	($dec_rr{$rt} \|\| sub { $_ })->(),
390	]	420	]
391	}	421	}
…		…
394		424
395	Unpacks a DNS packet into a perl data structure.	425	Unpacks a DNS packet into a perl data structure.
396		426
397	Examples:	427	Examples:
398		428
399	# a non-successful reply	429	# an unsuccessful reply
400	{	430	{
401	'qd' => [	431	'qd' => [
402	[ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]	432	[ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]
403	],	433	],
404	'rc' => 'nxdomain',	434	'rc' => 'nxdomain',
…		…
408	'uni-karlsruhe.de',	438	'uni-karlsruhe.de',
409	'soa',	439	'soa',
410	'in',	440	'in',
411	'netserv.rz.uni-karlsruhe.de',	441	'netserv.rz.uni-karlsruhe.de',
412	'hostmaster.rz.uni-karlsruhe.de',	442	'hostmaster.rz.uni-karlsruhe.de',
413	2008052201,	443	2008052201, 10800, 1800, 2592000, 86400
414	10800,
415	1800,
416	2592000,
417	86400
418	]	444	]
419	],	445	],
420	'tc' => '',	446	'tc' => '',
421	'ra' => 1,	447	'ra' => 1,
422	'qr' => 1,	448	'qr' => 1,
…		…
488		514
489	=back	515	=back
490		516
491	=head2 THE AnyEvent::DNS RESOLVER CLASS	517	=head2 THE AnyEvent::DNS RESOLVER CLASS
492		518
493	This is the class which deos the actual protocol work.	519	This is the class which does the actual protocol work.
494		520
495	=over 4	521	=over 4
496		522
497	=cut	523	=cut
498		524
…		…
518	our $RESOLVER;	544	our $RESOLVER;
519		545
520	sub resolver() {	546	sub resolver() {
521	$RESOLVER \|\| do {	547	$RESOLVER \|\| do {
522	$RESOLVER = new AnyEvent::DNS;	548	$RESOLVER = new AnyEvent::DNS;
523	$RESOLVER->load_resolv_conf;	549	$RESOLVER->os_config;
524	$RESOLVER	550	$RESOLVER
525	}	551	}
526	}	552	}
527		553
528	=item $resolver = new AnyEvent::DNS key => value...	554	=item $resolver = new AnyEvent::DNS key => value...
…		…
533		559
534	=over 4	560	=over 4
535		561
536	=item server => [...]	562	=item server => [...]
537		563
538	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
539	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).
540		567
541	=item timeout => [...]	568	=item timeout => [...]
542		569
543	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
544	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,
…		…
553	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
554	tries to resolve the name without any suffixes first.	581	tries to resolve the name without any suffixes first.
555		582
556	=item max_outstanding => $integer	583	=item max_outstanding => $integer
557		584
558	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
559	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>
560	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,
561	until some other requests have been resolved.	588	then the additional requests will be queued until some other requests have
		589	been resolved.
		590
		591	=item reuse => $seconds
		592
		593	The number of seconds (default: C<300>) that a query id cannot be re-used
		594	after a timeout. If there as no time-out then query id's can be reused
		595	immediately.
562		596
563	=back	597	=back
564		598
565	=cut	599	=cut
566		600
567	sub new {	601	sub new {
568	my ($class, %arg) = @_;	602	my ($class, %arg) = @_;
569		603
		604	# try to create a ipv4 and an ipv6 socket
		605	# only fail when we cnanot create either
		606
570	socket my $fh, &Socket::AF_INET, &Socket::SOCK_DGRAM, 0	607	socket my $fh4, AF_INET , &Socket::SOCK_DGRAM, 0;
571	or Carp::croak "socket: $!";	608	socket my $fh6, AF_INET6, &Socket::SOCK_DGRAM, 0;
572		609
573	AnyEvent::Util::fh_nonblocking $fh, 1;	610	$fh4 \|\| $fh6
		611	or Carp::croak "unable to create either an IPv6 or an IPv4 socket";
574		612
575	my $self = bless {	613	my $self = bless {
576	server => [v127.0.0.1],	614	server => [],
577	timeout => [2, 5, 5],	615	timeout => [2, 5, 5],
578	search => [],	616	search => [],
579	ndots => 1,	617	ndots => 1,
580	max_outstanding => 10,	618	max_outstanding => 10,
581	reuse => 300, # reuse id's after 5 minutes only, if possible	619	reuse => 300, # reuse id's after 5 minutes only, if possible
582	%arg,	620	%arg,
583	fh => $fh,
584	reuse_q => [],	621	reuse_q => [],
585	}, $class;	622	}, $class;
586		623
587	# search should default to gethostname's domain	624	# search should default to gethostname's domain
588	# but perl lacks a good posix module	625	# but perl lacks a good posix module
589		626
590	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;
591	$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	}
592		648
593	$self->_compile;	649	$self->_compile;
594		650
595	$self	651	$self
596	}	652	}
597		653
598	=item $resolver->parse_resolv_conv ($string)	654	=item $resolver->parse_resolv_conv ($string)
599		655
600	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
601	directives are supported:	657	directives are supported (but not necessarily implemented).
602		658
603	C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,	659	C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,
604	C<options> (C<timeout>, C<attempts>, C<ndots>).	660	C<options> (C<timeout>, C<attempts>, C<ndots>).
605		661
606	Everything else is silently ignored.	662	Everything else is silently ignored.
…		…
618	for (split /\n/, $resolvconf) {	674	for (split /\n/, $resolvconf) {
619	if (/^\s*#/) {	675	if (/^\s*#/) {
620	# comment	676	# comment
621	} elsif (/^\snameserver\s+(\S+)\s$/i) {	677	} elsif (/^\snameserver\s+(\S+)\s$/i) {
622	my $ip = $1;	678	my $ip = $1;
623	if (AnyEvent::Util::dotted_quad $ip) {	679	if (my $ipn = AnyEvent::Socket::parse_address ($ip)) {
624	push @{ $self->{server} }, AnyEvent::Util::socket_inet_aton $ip;	680	push @{ $self->{server} }, $ipn;
625	} else {	681	} else {
626	warn "nameserver $ip invalid and ignored\n";	682	warn "nameserver $ip invalid and ignored\n";
627	}	683	}
628	} elsif (/^\sdomain\s+(\S)\s+$/i) {	684	} elsif (/^\sdomain\s+(\S)\s+$/i) {
629	$self->{search} = [$1];	685	$self->{search} = [$1];
…		…
650	if $attempts;	706	if $attempts;
651		707
652	$self->_compile;	708	$self->_compile;
653	}	709	}
654		710
655	=item $resolver->load_resolv_conf	711	=item $resolver->os_config
656		712
657	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
658	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.
659		715
660	=cut	716	=cut
661		717
662	sub load_resolv_conf {	718	sub os_config {
663	my ($self) = @_;	719	my ($self) = @_;
664		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
665	open my $fh, "</etc/resolv.conf"	770	if (open my $fh, "</etc/resolv.conf") {
666	or return;
667
668	local $/;	771	local $/;
669	$self->parse_resolv_conf (<$fh>);	772	$self->parse_resolv_conf (<$fh>);
		773	}
		774	}
670	}	775	}
671		776
672	sub _compile {	777	sub _compile {
673	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	}
674		787
675	my @retry;	788	my @retry;
676		789
677	for my $timeout (@{ $self->{timeout} }) {	790	for my $timeout (@{ $self->{timeout} }) {
678	for my $server (@{ $self->{server} }) {	791	for my $server (@{ $self->{server} }) {
…		…
696	$NOW = time;	809	$NOW = time;
697	$id->[1]->($res);	810	$id->[1]->($res);
698	}	811	}
699		812
700	sub _recv {	813	sub _recv {
701	my ($self) = @_;	814	my ($self, $pkt, $peer) = @_;
702		815
703	while (my $peer = recv $self->{fh}, my $res, 4000, 0) {	816	# we ignore errors (often one gets port unreachable, but there is
		817	# no good way to take advantage of that.
		818
704	my ($port, $host) = Socket::unpack_sockaddr_in $peer;	819	my ($port, $host) = AnyEvent::Socket::unpack_sockaddr ($peer);
705		820
706	return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };	821	return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };
707		822
708	$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};
709	}	836	}
710	}
711		837
		838	--$self->{outstanding};
		839	$self->_scheduler;
		840	}
		841
		842	# execute a single request, involves sending it with timeouts to multiple servers
712	sub _exec {	843	sub _exec {
713	my ($self, $req, $retry) = @_;	844	my ($self, $req) = @_;
714		845
		846	my $retry; # of retries
		847	my $do_retry;
		848
		849	$do_retry = sub {
715	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
716	my ($server, $timeout) = @$retry_cfg;	857	my ($server, $timeout) = @$retry_cfg;
717		858
718	$self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {	859	$self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {
719	$NOW = time;	860	$NOW = time;
720		861
721	# timeout, try next	862	# timeout, try next
722	$self->_exec ($req, $retry + 1);	863	&$do_retry;
723	}), sub {	864	}), sub {
724	my ($res) = @_;	865	my ($res) = @_;
725		866
726	if ($res->{tc}) {	867	if ($res->{tc}) {
727	# success, but truncated, so use tcp	868	# success, but truncated, so use tcp
728	AnyEvent::Util::tcp_connect +(Socket::inet_ntoa $server), 53, sub {	869	AnyEvent::Socket::tcp_connect (AnyEvent::Socket::format_address ($server), DOMAIN_PORT, sub {
729	my ($fh) = @_	870	my ($fh) = @_
730	or return $self->_exec ($req, $retry + 1);	871	or return &$do_retry;
731		872
732	my $handle = new AnyEvent::Handle	873	my $handle = new AnyEvent::Handle
733	fh => $fh,	874	fh => $fh,
734	on_error => sub {	875	on_error => sub {
735	# failure, try next	876	# failure, try next
736	$self->_exec ($req, $retry + 1);	877	&$do_retry;
737	};	878	};
738		879
739	$handle->push_write (pack "n/a", $req->[0]);	880	$handle->push_write (pack "n/a", $req->[0]);
740	$handle->push_read_chunk (2, sub {	881	$handle->push_read (chunk => 2, sub {
741	$handle->unshift_read_chunk ((unpack "n", $_[1]), sub {	882	$handle->unshift_read (chunk => (unpack "n", $_[1]), sub {
742	$self->_feed ($_[1]);	883	$self->_feed ($_[1]);
743	});	884	});
744	});	885	});
745	shutdown $fh, 1;	886	shutdown $fh, 1;
746		887
747	}, sub { $timeout };	888	}, sub { $timeout });
748		889
749	} else {	890	} else {
750	# success	891	# success
751	$self->{id}{$req->[2]} = 1;	892	$self->_free_id ($req->[2], $retry > 1);
752	push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];	893	undef $do_retry; return $req->[1]->($res);
753	--$self->{outstanding};
754	$self->_scheduler;
755
756	$req->[1]->($res);
757	}	894	}
758	}];	895	}];
		896
		897	my $sa = AnyEvent::Socket::pack_sockaddr (DOMAIN_PORT, $server);
759		898
760	send $self->{fh}, $req->[0], 0, Socket::pack_sockaddr_in 53, $server;	899	my $fh = AF_INET == Socket::sockaddr_family ($sa)
761	} else {	900	? $self->{fh4} : $self->{fh6}
762	# failure	901	or return &$do_retry;
763	$self->{id}{$req->[2]} = 1;
764	push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];
765	--$self->{outstanding};
766	$self->_scheduler;
767		902
768	$req->[1]->();	903	send $fh, $req->[0], 0, $sa;
769	}	904	};
		905
		906	&$do_retry;
770	}	907	}
771		908
772	sub _scheduler {	909	sub _scheduler {
773	my ($self) = @_;	910	my ($self) = @_;
774		911
775	$NOW = time;	912	$NOW = time;
776		913
777	# first clear id reuse queue	914	# first clear id reuse queue
778	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }	915	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }
779	while @{ $self->{reuse_q} } && $self->{reuse_q}[0] <= $NOW;	916	while @{ $self->{reuse_q} } && $self->{reuse_q}[0][0] <= $NOW;
780		917
781	while ($self->{outstanding} < $self->{max_outstanding}) {	918	while ($self->{outstanding} < $self->{max_outstanding}) {
		919
		920	if (@{ $self->{reuse_q} } >= 30000) {
		921	# we ran out of ID's, wait a bit
		922	$self->{reuse_to} \|\|= AnyEvent->timer (after => $self->{reuse_q}[0][0] - $NOW, cb => sub {
		923	delete $self->{reuse_to};
		924	$self->_scheduler;
		925	});
		926	last;
		927	}
		928
782	my $req = shift @{ $self->{queue} }	929	my $req = shift @{ $self->{queue} }
783	or last;	930	or last;
784		931
785	while () {	932	while () {
786	$req->[2] = int rand 65536;	933	$req->[2] = int rand 65536;
787	last unless exists $self->{id}{$req->[2]};	934	last unless exists $self->{id}{$req->[2]};
788	}	935	}
789		936
		937	++$self->{outstanding};
790	$self->{id}{$req->[2]} = 1;	938	$self->{id}{$req->[2]} = 1;
791	substr $req->[0], 0, 2, pack "n", $req->[2];	939	substr $req->[0], 0, 2, pack "n", $req->[2];
792		940
793	++$self->{outstanding};
794	$self->_exec ($req, 0);	941	$self->_exec ($req);
795	}	942	}
796	}	943	}
797		944
798	=item $resolver->request ($req, $cb->($res))	945	=item $resolver->request ($req, $cb->($res))
799		946
…		…
811	$self->_scheduler;	958	$self->_scheduler;
812	}	959	}
813		960
814	=item $resolver->resolve ($qname, $qtype, %options, $cb->($rcode, @rr))	961	=item $resolver->resolve ($qname, $qtype, %options, $cb->($rcode, @rr))
815		962
816	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>.
817	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.
818		970
819	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
820	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.
821		973
822	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.
823		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
824	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
825	supporting recursive queries, will not do any recursive queries itself and	990	supporting recursive queries, will not do any recursive queries itself and
826	is not secure when used against an untrusted name server.	991	is not secure when used against an untrusted name server.
827		992
828	The following options are supported:	993	The following options are supported:
829		994
…		…
838		1003
839	=item accept => [$type...]	1004	=item accept => [$type...]
840		1005
841	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
842	accepted and returned. The default includes the C<$qtype> and nothing	1007	accepted and returned. The default includes the C<$qtype> and nothing
843	else.	1008	else. If this list includes C<cname>, then CNAME-chains will not be
		1009	followed (because you asked for the CNAME record).
844		1010
845	=item class => "class"	1011	=item class => "class"
846		1012
847	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
848	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.
849		1015
850	=back	1016	=back
851		1017
852	Examples:	1018	Examples:
853		1019
854	$res->resolve ("ruth.plan9.de", "a", sub {	1020	# full example, you can paste this into perl
855	warn Dumper [@_];	1021	use Data::Dumper;
856	});	1022	use AnyEvent::DNS;
		1023	AnyEvent::DNS::resolver->resolve (
		1024	"google.com", "*", my $cv = AnyEvent->condvar);
		1025	warn Dumper [$cv->recv];
857		1026
		1027	# shortened result:
858	[	1028	# [
		1029	# [ 'google.com', 'soa', 'in', 'ns1.google.com', 'dns-admin.google.com',
		1030	# 2008052701, 7200, 1800, 1209600, 300 ],
859	[	1031	# [
860	'ruth.schmorp.de',	1032	# 'google.com', 'txt', 'in',
861	'a',	1033	# 'v=spf1 include:_netblocks.google.com ~all'
862	'in',	1034	# ],
863	'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' ],
864	]	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' ]
865	]	1046	# ]
866		1047
		1048	# resolve any records, but return only a and aaaa records:
867	$res->resolve ("test1.laendle", "*",	1049	$res->resolve ("test1.laendle", "*",
868	accept => ["a", "aaaa"],	1050	accept => ["a", "aaaa"],
869	sub {	1051	sub {
870	warn Dumper [@_];	1052	warn Dumper [@_];
871	}	1053	}
872	);	1054	);
873		1055
874	[	1056	# result:
875	[	1057	# [
876	'test1.laendle',	1058	# [ 'test1.laendle', 'a', 'in', '10.0.0.255' ],
877	'a',	1059	# [ 'test1.laendle', 'aaaa', 'in', '3ffe:1900:4545:0002:0240:0000:0000:f7e1' ]
878	'in',
879	'10.0.0.255'
880	],
881	[
882	'test1.laendle',
883	'aaaa',
884	'in',
885	'3ffe:1900:4545:0002:0240:0000:0000:f7e1'
886	]	1060	# ]
887	]
888		1061
889	=cut	1062	=cut
890		1063
891	sub resolve($%) {	1064	sub resolve($%) {
892	my $cb = pop;	1065	my $cb = pop;
…		…
905	my %atype = $opt{accept}	1078	my %atype = $opt{accept}
906	? map +($_ => 1), @{ $opt{accept} }	1079	? map +($_ => 1), @{ $opt{accept} }
907	: ($qtype => 1);	1080	: ($qtype => 1);
908		1081
909	# advance in searchlist	1082	# advance in searchlist
910	my $do_search; $do_search = sub {	1083	my ($do_search, $do_req);
		1084
		1085	$do_search = sub {
911	@search	1086	@search
912	or return $cb->();	1087	or (undef $do_search), (undef $do_req), return $cb->();
913		1088
914	(my $name = lc "$qname." . shift @search) =~ s/\.$//;	1089	(my $name = lc "$qname." . shift @search) =~ s/\.$//;
915	my $depth = 2;	1090	my $depth = 2;
916		1091
917	# advance in cname-chain	1092	# advance in cname-chain
918	my $do_req; $do_req = sub {	1093	$do_req = sub {
919	$self->request ({	1094	$self->request ({
920	rd => 1,	1095	rd => 1,
921	qd => [[$name, $qtype, $class]],	1096	qd => [[$name, $qtype, $class]],
922	}, sub {	1097	}, sub {
923	my ($res) = @_	1098	my ($res) = @_
…		…
927		1102
928	while () {	1103	while () {
929	# results found?	1104	# results found?
930	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} };
931		1106
932	return $cb->(@rr)	1107	(undef $do_search), (undef $do_req), return $cb->(@rr)
933	if @rr;	1108	if @rr;
934		1109
935	# see if there is a cname we can follow	1110	# see if there is a cname we can follow
936	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} };
937		1112
…		…
958	};	1133	};
959		1134
960	$do_search->();	1135	$do_search->();
961	}	1136	}
962		1137
		1138	use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end
		1139
963	1;	1140	1;
964		1141
965	=back	1142	=back
966		1143
967	=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.7 by root, Fri May 23 05:30:59 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.7 by root, Fri May 23 05:30:59 2008 UTC vs.
Revision 1.45 by root, Thu May 29 06:40:06 2008 UTC