Filename | /usr/local/lib/perl5/site_perl/Net/DNS/Resolver/Base.pm |
Statements | Executed 0 statements in 0s |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
0 | 0 | 0 | 0s | 0s | AUTOLOAD | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | BEGIN@1128 | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | BEGIN@28 | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | BEGIN@3 | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | BEGIN@31 | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | BEGIN@35 | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | BEGIN@39 | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | BEGIN@4 | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | BEGIN@40 | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | BEGIN@43 | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | BEGIN@44 | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | BEGIN@45 | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | BEGIN@46 | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | BEGIN@47 | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | BEGIN@48 | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | BEGIN@484 | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | BEGIN@50 | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | BEGIN@51 | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | BEGIN@53 | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | BEGIN@544 | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | BEGIN@929 | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | BEGIN@930 | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | BEGIN@931 | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | DESTROY | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | __ANON__ (xsub) | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | __ANON__[:1105] | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | __ANON__[:1134] | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | __ANON__[:731] | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | _accept_reply | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | _axfr_next | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | _axfr_start | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | _bgread | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | _bgsend_tcp | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | _bgsend_udp | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | _cname_addr | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | _create_dst_sockaddr | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | _create_tcp_socket | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | _create_udp_socket | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | _defaults | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | _deprecate | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | _diag | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | _hints | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | _ipv4 | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | _ipv6 | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | _make_query_packet | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | _option | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | _packetsz | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | _read_config_file | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | _read_env | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | _read_tcp | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | _read_udp | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | _reset_errorstring | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | _send_tcp | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | _send_udp | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | _untaint | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | answerfrom | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | axfr | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | axfr_next | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | axfr_start | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | bgbusy | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | bgisready | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | bgread | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | bgsend | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | dnssec | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | domain | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | errorstring | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | force_v4 | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | force_v6 | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | make_query_packet | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | nameserver | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | nameservers | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | new | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | prefer_v4 | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | prefer_v6 | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | |
0 | 0 | 0 | 0s | 0s | query | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | replyfrom | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | search | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | searchlist | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | send | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | srcaddr | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | string | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | tsig | Net::DNS::Resolver::Base::
0 | 0 | 0 | 0s | 0s | udppacketsize | Net::DNS::Resolver::Base::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package Net::DNS::Resolver::Base; | ||||
2 | |||||
3 | use strict; | ||||
4 | use warnings; | ||||
5 | our $VERSION = (qw$Id: Base.pm 1818 2020-10-18 15:24:42Z willem $)[2]; | ||||
6 | |||||
7 | |||||
8 | # | ||||
9 | # Implementation notes wrt IPv6 support when using perl before 5.20.0. | ||||
10 | # | ||||
11 | # In general we try to be gracious to those stacks that do not have IPv6 support. | ||||
12 | # The socket code is conditionally compiled depending upon the availability of | ||||
13 | # the IO::Socket::IP package. | ||||
14 | # | ||||
15 | # We have chosen not to use mapped IPv4 addresses, there seem to be issues | ||||
16 | # with this; as a result we use separate sockets for each family type. | ||||
17 | # | ||||
18 | # inet_pton is not available on WIN32, so we only use the getaddrinfo | ||||
19 | # call to translate IP addresses to socketaddress. | ||||
20 | # | ||||
21 | # The configuration options force_v4, force_v6, prefer_v4 and prefer_v6 | ||||
22 | # are provided to control IPv6 behaviour for test purposes. | ||||
23 | # | ||||
24 | # Olaf Kolkman, RIPE NCC, December 2003. | ||||
25 | # [Revised March 2016, June 2018] | ||||
26 | |||||
27 | |||||
28 | use constant USE_SOCKET_IP => defined eval 'use IO::Socket::IP 0.38; 1;'; ## no critic # spent 0s executing statements in string eval | ||||
29 | require IO::Socket::INET unless USE_SOCKET_IP; | ||||
30 | |||||
31 | use constant IPv6 => USE_SOCKET_IP; | ||||
32 | |||||
33 | |||||
34 | # If SOCKSified Perl, use TCP instead of UDP and keep the socket open. | ||||
35 | use constant SOCKS => scalar eval { require Config; $Config::Config{usesocks}; }; | ||||
36 | |||||
37 | |||||
38 | # Allow taint tests to be optimised away when appropriate. | ||||
39 | use constant TAINT => eval { ${^TAINT} }; | ||||
40 | use constant TESTS => TAINT && defined eval { require Scalar::Util; }; | ||||
41 | |||||
42 | |||||
43 | use integer; | ||||
44 | use Carp; | ||||
45 | use IO::File; | ||||
46 | use IO::Select; | ||||
47 | use IO::Socket; | ||||
48 | use Socket; | ||||
49 | |||||
50 | use Net::DNS::RR; | ||||
51 | use Net::DNS::Packet; | ||||
52 | |||||
53 | use constant PACKETSZ => 512; | ||||
54 | |||||
55 | |||||
56 | # | ||||
57 | # Set up a closure to be our class data. | ||||
58 | # | ||||
59 | { | ||||
60 | my $defaults = bless { | ||||
61 | nameservers => [qw(::1 127.0.0.1)], | ||||
62 | nameserver4 => ['127.0.0.1'], | ||||
63 | nameserver6 => ['::1'], | ||||
64 | port => 53, | ||||
65 | srcaddr4 => '0.0.0.0', | ||||
66 | srcaddr6 => '::', | ||||
67 | srcport => 0, | ||||
68 | searchlist => [], | ||||
69 | retrans => 5, | ||||
70 | retry => 4, | ||||
71 | usevc => ( SOCKS ? 1 : 0 ), | ||||
72 | igntc => 0, | ||||
73 | recurse => 1, | ||||
74 | defnames => 1, | ||||
75 | dnsrch => 1, | ||||
76 | ndots => 1, | ||||
77 | debug => 0, | ||||
78 | tcp_timeout => 120, | ||||
79 | udp_timeout => 30, | ||||
80 | persistent_tcp => ( SOCKS ? 1 : 0 ), | ||||
81 | persistent_udp => 0, | ||||
82 | dnssec => 0, | ||||
83 | adflag => 0, # see RFC6840, 5.7 | ||||
84 | cdflag => 0, # see RFC6840, 5.9 | ||||
85 | udppacketsize => 0, # value bounded below by PACKETSZ | ||||
86 | force_v4 => ( IPv6 ? 0 : 1 ), | ||||
87 | force_v6 => 0, # only relevant if IPv6 is supported | ||||
88 | prefer_v4 => 0, | ||||
89 | prefer_v6 => 0, | ||||
90 | }, | ||||
91 | __PACKAGE__; | ||||
92 | |||||
93 | |||||
94 | sub _defaults { return $defaults; } | ||||
95 | } | ||||
96 | |||||
97 | |||||
98 | my $warned; | ||||
99 | |||||
100 | sub _deprecate { | ||||
101 | carp join ' ', 'deprecated method;', pop(@_) unless $warned++; | ||||
102 | return; | ||||
103 | } | ||||
104 | |||||
105 | |||||
106 | sub _untaint { | ||||
107 | return TAINT ? map { ref($_) ? [_untaint(@$_)] : do { /^(.*)$/; $1 } } @_ : @_; | ||||
108 | } | ||||
109 | |||||
110 | |||||
111 | # These are the attributes that the user may specify in the new() constructor. | ||||
112 | my %public_attr = ( | ||||
113 | map { $_ => $_ } keys %{&_defaults}, qw(domain nameserver srcaddr), | ||||
114 | map { $_ => 0 } qw(nameserver4 nameserver6 srcaddr4 srcaddr6), | ||||
115 | ); | ||||
116 | |||||
117 | |||||
118 | my $initial; | ||||
119 | |||||
120 | sub new { | ||||
121 | my ( $class, %args ) = @_; | ||||
122 | |||||
123 | my $self; | ||||
124 | my $base = $class->_defaults; | ||||
125 | my $init = $initial; | ||||
126 | $initial ||= [%$base]; | ||||
127 | if ( my $file = $args{config_file} ) { | ||||
128 | my $conf = bless {@$initial}, $class; | ||||
129 | $conf->_read_config_file($file); # user specified config | ||||
130 | $self = bless {_untaint(%$conf)}, $class; | ||||
131 | %$base = %$self unless $init; # define default configuration | ||||
132 | |||||
133 | } elsif ($init) { | ||||
134 | $self = bless {%$base}, $class; | ||||
135 | |||||
136 | } else { | ||||
137 | $class->_init(); # define default configuration | ||||
138 | $self = bless {%$base}, $class; | ||||
139 | } | ||||
140 | |||||
141 | while ( my ( $attr, $value ) = each %args ) { | ||||
142 | next unless $public_attr{$attr}; | ||||
143 | my $ref = ref($value); | ||||
144 | croak "usage: $class->new( $attr => [...] )" | ||||
145 | if $ref && ( $ref ne 'ARRAY' ); | ||||
146 | $self->$attr( $ref ? @$value : $value ); | ||||
147 | } | ||||
148 | |||||
149 | return $self; | ||||
150 | } | ||||
151 | |||||
152 | |||||
153 | my %resolv_conf = ( ## map traditional resolv.conf option names | ||||
154 | attempts => 'retry', | ||||
155 | inet6 => 'prefer_v6', | ||||
156 | timeout => 'retrans', | ||||
157 | ); | ||||
158 | |||||
159 | my %res_option = ( ## any resolver attribute plus those listed above | ||||
160 | %public_attr, | ||||
161 | %resolv_conf, | ||||
162 | ); | ||||
163 | |||||
164 | sub _option { | ||||
165 | my ( $self, $name, @value ) = @_; | ||||
166 | my $attribute = $res_option{lc $name} || return; | ||||
167 | push @value, 1 unless scalar @value; | ||||
168 | return $self->$attribute(@value); | ||||
169 | } | ||||
170 | |||||
171 | |||||
172 | sub _read_env { ## read resolver config environment variables | ||||
173 | my $self = shift; | ||||
174 | |||||
175 | $self->searchlist( map {split} $ENV{LOCALDOMAIN} ) if defined $ENV{LOCALDOMAIN}; | ||||
176 | |||||
177 | $self->nameservers( map {split} $ENV{RES_NAMESERVERS} ) if defined $ENV{RES_NAMESERVERS}; | ||||
178 | |||||
179 | $self->searchlist( map {split} $ENV{RES_SEARCHLIST} ) if defined $ENV{RES_SEARCHLIST}; | ||||
180 | |||||
181 | foreach ( map {split} $ENV{RES_OPTIONS} || '' ) { | ||||
182 | $self->_option( split m/:/ ); | ||||
183 | } | ||||
184 | return; | ||||
185 | } | ||||
186 | |||||
187 | |||||
188 | sub _read_config_file { ## read resolver config file | ||||
189 | my $self = shift; | ||||
190 | my $file = shift; | ||||
191 | |||||
192 | my $filehandle = IO::File->new( $file, '<' ) or croak "$file: $!"; | ||||
193 | |||||
194 | my @nameserver; | ||||
195 | my @searchlist; | ||||
196 | |||||
197 | local $_; | ||||
198 | while (<$filehandle>) { | ||||
199 | s/[;#].*$//; # strip comments | ||||
200 | |||||
201 | /^nameserver/ && do { | ||||
202 | my ( $keyword, @ip ) = grep {defined} split; | ||||
203 | push @nameserver, @ip; | ||||
204 | next; | ||||
205 | }; | ||||
206 | |||||
207 | /^domain/ && do { | ||||
208 | my ( $keyword, $domain ) = grep {defined} split; | ||||
209 | $self->domain($domain); | ||||
210 | next; | ||||
211 | }; | ||||
212 | |||||
213 | /^search/ && do { | ||||
214 | my ( $keyword, @domain ) = grep {defined} split; | ||||
215 | push @searchlist, @domain; | ||||
216 | next; | ||||
217 | }; | ||||
218 | |||||
219 | /^option/ && do { | ||||
220 | my ( $keyword, @option ) = grep {defined} split; | ||||
221 | foreach (@option) { | ||||
222 | $self->_option( split m/:/ ); | ||||
223 | } | ||||
224 | }; | ||||
225 | } | ||||
226 | |||||
227 | close($filehandle); | ||||
228 | |||||
229 | $self->nameservers(@nameserver) if @nameserver; | ||||
230 | $self->searchlist(@searchlist) if @searchlist; | ||||
231 | return; | ||||
232 | } | ||||
233 | |||||
234 | |||||
235 | sub string { | ||||
236 | my $self = shift; | ||||
237 | $self = $self->_defaults unless ref($self); | ||||
238 | |||||
239 | my @nslist = $self->nameservers(); | ||||
240 | my ($force) = ( grep( { $self->{$_} } qw(force_v6 force_v4) ), 'force_v4' ); | ||||
241 | my ($prefer) = ( grep( { $self->{$_} } qw(prefer_v6 prefer_v4) ), 'prefer_v4' ); | ||||
242 | return <<END; | ||||
243 | ;; RESOLVER state: | ||||
244 | ;; nameservers = @nslist | ||||
245 | ;; searchlist = @{$self->{searchlist}} | ||||
246 | ;; defnames = $self->{defnames} dnsrch = $self->{dnsrch} | ||||
247 | ;; igntc = $self->{igntc} usevc = $self->{usevc} | ||||
248 | ;; recurse = $self->{recurse} port = $self->{port} | ||||
249 | ;; retrans = $self->{retrans} retry = $self->{retry} | ||||
250 | ;; tcp_timeout = $self->{tcp_timeout} persistent_tcp = $self->{persistent_tcp} | ||||
251 | ;; udp_timeout = $self->{udp_timeout} persistent_udp = $self->{persistent_udp} | ||||
252 | ;; ${prefer} = $self->{$prefer} ${force} = $self->{$force} | ||||
253 | ;; debug = $self->{debug} ndots = $self->{ndots} | ||||
254 | END | ||||
255 | } | ||||
256 | |||||
257 | |||||
258 | sub print { | ||||
259 | print &string; | ||||
260 | return; | ||||
261 | } | ||||
262 | |||||
263 | |||||
264 | sub searchlist { | ||||
265 | my ( $self, @domain ) = @_; | ||||
266 | $self = $self->_defaults unless ref($self); | ||||
267 | |||||
268 | if ( scalar(@domain) || !defined(wantarray) ) { | ||||
269 | foreach (@domain) { $_ = Net::DNS::Domain->new($_)->name } | ||||
270 | $self->{searchlist} = [@domain]; | ||||
271 | } | ||||
272 | |||||
273 | return ( @{$self->{searchlist}} ); | ||||
274 | } | ||||
275 | |||||
276 | sub domain { | ||||
277 | my ($head) = &searchlist; | ||||
278 | return wantarray ? ( grep {defined} $head ) : $head; | ||||
279 | } | ||||
280 | |||||
281 | |||||
282 | sub nameservers { | ||||
283 | my $self = shift; | ||||
284 | $self = $self->_defaults unless ref($self); | ||||
285 | |||||
286 | my @ip; | ||||
287 | foreach my $ns ( grep {defined} @_ ) { | ||||
288 | if ( _ipv4($ns) || _ipv6($ns) ) { | ||||
289 | push @ip, $ns; | ||||
290 | |||||
291 | } else { | ||||
292 | my $defres = ref($self)->new( debug => $self->{debug} ); | ||||
293 | $defres->{persistent} = $self->{persistent}; | ||||
294 | |||||
295 | my $names = {}; | ||||
296 | my $packet = $defres->send( $ns, 'A' ); | ||||
297 | my @iplist = _cname_addr( $packet, $names ); | ||||
298 | |||||
299 | if (IPv6) { | ||||
300 | $packet = $defres->send( $ns, 'AAAA' ); | ||||
301 | push @iplist, _cname_addr( $packet, $names ); | ||||
302 | } | ||||
303 | |||||
304 | my %unique = map { $_ => $_ } @iplist; | ||||
305 | |||||
306 | my @address = values(%unique); # tainted | ||||
307 | carp "unresolvable name: $ns" unless scalar @address; | ||||
308 | |||||
309 | push @ip, @address; | ||||
310 | } | ||||
311 | } | ||||
312 | |||||
313 | if ( scalar(@_) || !defined(wantarray) ) { | ||||
314 | my @ipv4 = grep { _ipv4($_) } @ip; | ||||
315 | my @ipv6 = grep { _ipv6($_) } @ip; | ||||
316 | $self->{nameservers} = \@ip; | ||||
317 | $self->{nameserver4} = \@ipv4; | ||||
318 | $self->{nameserver6} = \@ipv6; | ||||
319 | } | ||||
320 | |||||
321 | my @ns4 = $self->{force_v6} ? () : @{$self->{nameserver4}}; | ||||
322 | my @ns6 = $self->{force_v4} ? () : @{$self->{nameserver6}}; | ||||
323 | my @nameservers = @{$self->{nameservers}}; | ||||
324 | @nameservers = ( @ns4, @ns6 ) if $self->{prefer_v4} || !scalar(@ns6); | ||||
325 | @nameservers = ( @ns6, @ns4 ) if $self->{prefer_v6} || !scalar(@ns4); | ||||
326 | |||||
327 | return @nameservers if scalar @nameservers; | ||||
328 | |||||
329 | my $error = 'no nameservers'; | ||||
330 | $error = 'IPv4 transport disabled' if scalar(@ns4) < scalar @{$self->{nameserver4}}; | ||||
331 | $error = 'IPv6 transport disabled' if scalar(@ns6) < scalar @{$self->{nameserver6}}; | ||||
332 | $self->errorstring($error); | ||||
333 | return @nameservers; | ||||
334 | } | ||||
335 | |||||
336 | sub nameserver { return &nameservers; } | ||||
337 | |||||
338 | sub _cname_addr { | ||||
339 | |||||
340 | # TODO 20081217 | ||||
341 | # This code does not follow CNAME chains, it only looks inside the packet. | ||||
342 | # Out of bailiwick will fail. | ||||
343 | my @null; | ||||
344 | my $packet = shift || return @null; | ||||
345 | my $names = shift; | ||||
346 | |||||
347 | $names->{lc( $_->qname )}++ foreach $packet->question; | ||||
348 | $names->{lc( $_->cname )}++ foreach grep { $_->can('cname') } $packet->answer; | ||||
349 | |||||
350 | my @addr = grep { $_->can('address') } $packet->answer; | ||||
351 | return map { $_->address } grep { $names->{lc( $_->name )} } @addr; | ||||
352 | } | ||||
353 | |||||
354 | |||||
355 | sub replyfrom { | ||||
356 | return shift->{replyfrom}; | ||||
357 | } | ||||
358 | |||||
359 | sub answerfrom { return &replyfrom; } # uncoverable pod | ||||
360 | |||||
361 | |||||
362 | sub _reset_errorstring { | ||||
363 | shift->{errorstring} = ''; | ||||
364 | return; | ||||
365 | } | ||||
366 | |||||
367 | sub errorstring { | ||||
368 | my $self = shift; | ||||
369 | my $text = shift || return $self->{errorstring}; | ||||
370 | $self->_diag( 'errorstring:', $text ); | ||||
371 | return $self->{errorstring} = $text; | ||||
372 | } | ||||
373 | |||||
374 | |||||
375 | sub query { | ||||
376 | my $self = shift; | ||||
377 | my $name = shift || '.'; | ||||
378 | |||||
379 | my @sfix = $self->{defnames} && ( $name !~ m/[.:]/ ) ? $self->domain : (); | ||||
380 | |||||
381 | my $fqdn = join '.', $name, @sfix; | ||||
382 | $self->_diag( 'query(', $fqdn, @_, ')' ); | ||||
383 | my $packet = $self->send( $fqdn, @_ ) || return; | ||||
384 | return $packet->header->ancount ? $packet : undef; | ||||
385 | } | ||||
386 | |||||
387 | |||||
388 | sub search { | ||||
389 | my $self = shift; | ||||
390 | |||||
391 | return $self->query(@_) unless $self->{dnsrch}; | ||||
392 | |||||
393 | my $name = shift || '.'; | ||||
394 | my $dots = $name =~ tr/././; | ||||
395 | |||||
396 | my @sfix = ( $dots < $self->{ndots} ) ? @{$self->{searchlist}} : (); | ||||
397 | my ( $one, @more ) = ( $name =~ m/:|\.\d*$/ ) ? () : ( $dots ? ( undef, @sfix ) : @sfix ); | ||||
398 | |||||
399 | foreach my $suffix ( $one, @more ) { | ||||
400 | my $fqname = $suffix ? join( '.', $name, $suffix ) : $name; | ||||
401 | $self->_diag( 'search(', $fqname, @_, ')' ); | ||||
402 | my $packet = $self->send( $fqname, @_ ) || next; | ||||
403 | return $packet if $packet->header->ancount; | ||||
404 | } | ||||
405 | |||||
406 | return; | ||||
407 | } | ||||
408 | |||||
409 | |||||
410 | sub send { | ||||
411 | my $self = shift; | ||||
412 | my $packet = $self->_make_query_packet(@_); | ||||
413 | my $packet_data = $packet->data; | ||||
414 | |||||
415 | $self->_reset_errorstring; | ||||
416 | |||||
417 | return $self->_send_tcp( $packet, $packet_data ) | ||||
418 | if $self->{usevc} || length $packet_data > $self->_packetsz; | ||||
419 | |||||
420 | my $reply = $self->_send_udp( $packet, $packet_data ) || return; | ||||
421 | |||||
422 | return $reply if $self->{igntc}; | ||||
423 | return $reply unless $reply->header->tc; | ||||
424 | |||||
425 | $self->_diag('packet truncated: retrying using TCP'); | ||||
426 | return $self->_send_tcp( $packet, $packet_data ); | ||||
427 | } | ||||
428 | |||||
429 | |||||
430 | sub _send_tcp { | ||||
431 | my ( $self, $query, $query_data ) = @_; | ||||
432 | |||||
433 | my $tcp_packet = pack 'n a*', length($query_data), $query_data; | ||||
434 | my @ns = $self->nameservers(); | ||||
435 | my $fallback; | ||||
436 | my $timeout = $self->{tcp_timeout}; | ||||
437 | |||||
438 | foreach my $ip (@ns) { | ||||
439 | $self->_diag( 'tcp send', "[$ip]" ); | ||||
440 | |||||
441 | my $socket = $self->_create_tcp_socket($ip); | ||||
442 | $self->errorstring($!); | ||||
443 | my $select = IO::Select->new( $socket || next ); | ||||
444 | |||||
445 | $socket->send($tcp_packet); | ||||
446 | $self->errorstring($!); | ||||
447 | |||||
448 | next unless $select->can_read($timeout); # uncoverable branch true | ||||
449 | |||||
450 | my $buffer = _read_tcp($socket); | ||||
451 | $self->{replyfrom} = $ip; | ||||
452 | $self->_diag( 'reply from', "[$ip]", length($buffer), 'bytes' ); | ||||
453 | |||||
454 | my $reply = Net::DNS::Packet->decode( \$buffer, $self->{debug} ); | ||||
455 | $self->errorstring($@); | ||||
456 | next unless $self->_accept_reply( $reply, $query ); | ||||
457 | $reply->from($ip); | ||||
458 | |||||
459 | if ( $self->{tsig_rr} && !$reply->verify($query) ) { | ||||
460 | $self->errorstring( $reply->verifyerr ); | ||||
461 | next; | ||||
462 | } | ||||
463 | |||||
464 | my $rcode = $reply->header->rcode; | ||||
465 | return $reply if $rcode eq 'NOERROR'; | ||||
466 | return $reply if $rcode eq 'NXDOMAIN'; | ||||
467 | $fallback = $reply; | ||||
468 | } | ||||
469 | |||||
470 | $self->{errorstring} = $fallback->header->rcode if $fallback; | ||||
471 | $self->errorstring('query timed out') unless $self->{errorstring}; | ||||
472 | return $fallback; | ||||
473 | } | ||||
474 | |||||
475 | |||||
476 | sub _send_udp { | ||||
477 | my ( $self, $query, $query_data ) = @_; | ||||
478 | |||||
479 | my @ns = $self->nameservers; | ||||
480 | my $port = $self->{port}; | ||||
481 | my $retrans = $self->{retrans} || 1; | ||||
482 | my $retry = $self->{retry} || 1; | ||||
483 | my $servers = scalar(@ns); | ||||
484 | my $timeout = $servers ? do { no integer; $retrans / $servers } : 0; | ||||
485 | my $fallback; | ||||
486 | |||||
487 | # Perform each round of retries. | ||||
488 | RETRY: for ( 1 .. $retry ) { # assumed to be a small number | ||||
489 | |||||
490 | # Try each nameserver. | ||||
491 | my $select = IO::Select->new(); | ||||
492 | |||||
493 | NAMESERVER: foreach my $ns (@ns) { | ||||
494 | |||||
495 | # state vector replaces corresponding element of @ns array | ||||
496 | unless ( ref $ns ) { | ||||
497 | my $dst_sockaddr = $self->_create_dst_sockaddr( $ns, $port ); | ||||
498 | my $socket = $self->_create_udp_socket($ns) || next; | ||||
499 | $ns = [$socket, $ns, $dst_sockaddr]; | ||||
500 | } | ||||
501 | |||||
502 | my ( $socket, $ip, $dst_sockaddr, $failed ) = @$ns; | ||||
503 | next if $failed; | ||||
504 | |||||
505 | $self->_diag( 'udp send', "[$ip]:$port" ); | ||||
506 | |||||
507 | $select->add($socket); | ||||
508 | $socket->send( $query_data, 0, $dst_sockaddr ); | ||||
509 | $self->errorstring( $$ns[3] = $! ); | ||||
510 | |||||
511 | # handle failure to detect taint inside socket->send() | ||||
512 | die 'Insecure dependency while running with -T switch' | ||||
513 | if TESTS && Scalar::Util::tainted($dst_sockaddr); | ||||
514 | |||||
515 | my $reply; | ||||
516 | while ( my ($socket) = $select->can_read($timeout) ) { | ||||
517 | my $peer = $self->{replyfrom} = $socket->peerhost; | ||||
518 | |||||
519 | my $buffer = _read_udp( $socket, $self->_packetsz ); | ||||
520 | $self->_diag( "reply from [$peer]", length($buffer), 'bytes' ); | ||||
521 | |||||
522 | my $packet = Net::DNS::Packet->decode( \$buffer, $self->{debug} ); | ||||
523 | $self->errorstring($@); | ||||
524 | next unless $self->_accept_reply( $packet, $query ); | ||||
525 | $reply = $packet; | ||||
526 | $reply->from($peer); | ||||
527 | last; | ||||
528 | } #SELECT LOOP | ||||
529 | |||||
530 | next unless $reply; | ||||
531 | |||||
532 | if ( $self->{tsig_rr} && !$reply->verify($query) ) { | ||||
533 | $self->errorstring( $$ns[3] = $reply->verifyerr ); | ||||
534 | next; | ||||
535 | } | ||||
536 | |||||
537 | my $rcode = $reply->header->rcode; | ||||
538 | return $reply if $rcode eq 'NOERROR'; | ||||
539 | return $reply if $rcode eq 'NXDOMAIN'; | ||||
540 | $fallback = $reply; | ||||
541 | $$ns[3] = $rcode; | ||||
542 | } #NAMESERVER LOOP | ||||
543 | |||||
544 | no integer; | ||||
545 | $timeout += $timeout; | ||||
546 | } #RETRY LOOP | ||||
547 | |||||
548 | $self->{errorstring} = $fallback->header->rcode if $fallback; | ||||
549 | $self->errorstring('query timed out') unless $self->{errorstring}; | ||||
550 | return $fallback; | ||||
551 | } | ||||
552 | |||||
553 | |||||
554 | sub bgsend { | ||||
555 | my $self = shift; | ||||
556 | my $packet = $self->_make_query_packet(@_); | ||||
557 | my $packet_data = $packet->data; | ||||
558 | |||||
559 | $self->_reset_errorstring; | ||||
560 | |||||
561 | return $self->_bgsend_tcp( $packet, $packet_data ) | ||||
562 | if $self->{usevc} || length $packet_data > $self->_packetsz; | ||||
563 | |||||
564 | return $self->_bgsend_udp( $packet, $packet_data ); | ||||
565 | } | ||||
566 | |||||
567 | |||||
568 | sub _bgsend_tcp { | ||||
569 | my ( $self, $packet, $packet_data ) = @_; | ||||
570 | |||||
571 | my $tcp_packet = pack 'n a*', length($packet_data), $packet_data; | ||||
572 | |||||
573 | foreach my $ip ( $self->nameservers ) { | ||||
574 | $self->_diag( 'bgsend', "[$ip]" ); | ||||
575 | |||||
576 | my $socket = $self->_create_tcp_socket($ip); | ||||
577 | $self->errorstring($!); | ||||
578 | next unless $socket; | ||||
579 | |||||
580 | $socket->blocking(0); | ||||
581 | $socket->send($tcp_packet); | ||||
582 | $self->errorstring($!); | ||||
583 | $socket->blocking(1); | ||||
584 | |||||
585 | my $expire = time() + $self->{tcp_timeout}; | ||||
586 | ${*$socket}{net_dns_bg} = [$expire, $packet]; | ||||
587 | return $socket; | ||||
588 | } | ||||
589 | |||||
590 | return; | ||||
591 | } | ||||
592 | |||||
593 | |||||
594 | sub _bgsend_udp { | ||||
595 | my ( $self, $packet, $packet_data ) = @_; | ||||
596 | |||||
597 | my $port = $self->{port}; | ||||
598 | |||||
599 | foreach my $ip ( $self->nameservers ) { | ||||
600 | my $sockaddr = $self->_create_dst_sockaddr( $ip, $port ); | ||||
601 | my $socket = $self->_create_udp_socket($ip) || next; | ||||
602 | |||||
603 | $self->_diag( 'bgsend', "[$ip]:$port" ); | ||||
604 | |||||
605 | $socket->send( $packet_data, 0, $sockaddr ); | ||||
606 | $self->errorstring($!); | ||||
607 | |||||
608 | # handle failure to detect taint inside $socket->send() | ||||
609 | die 'Insecure dependency while running with -T switch' | ||||
610 | if TESTS && Scalar::Util::tainted($sockaddr); | ||||
611 | |||||
612 | my $expire = time() + $self->{udp_timeout}; | ||||
613 | ${*$socket}{net_dns_bg} = [$expire, $packet]; | ||||
614 | return $socket; | ||||
615 | } | ||||
616 | |||||
617 | return; | ||||
618 | } | ||||
619 | |||||
620 | |||||
621 | sub bgbusy { | ||||
622 | my ( $self, $handle ) = @_; | ||||
623 | return unless $handle; | ||||
624 | |||||
625 | my $appendix = ${*$handle}{net_dns_bg} ||= [time() + $self->{udp_timeout}]; | ||||
626 | my ( $expire, $query, $read ) = @$appendix; | ||||
627 | return if ref($read); | ||||
628 | |||||
629 | return time() <= $expire unless IO::Select->new($handle)->can_read(0); | ||||
630 | |||||
631 | return if $self->{igntc}; | ||||
632 | return unless $handle->socktype() == SOCK_DGRAM; | ||||
633 | return unless $query; # SpamAssassin 3.4.1 workaround | ||||
634 | |||||
635 | my $ans = $self->_bgread($handle); | ||||
636 | $$appendix[2] = [$ans]; | ||||
637 | return unless $ans; | ||||
638 | return unless $ans->header->tc; | ||||
639 | |||||
640 | $self->_diag('packet truncated: retrying using TCP'); | ||||
641 | my $tcp = $self->_bgsend_tcp( $query, $query->data ) || return; | ||||
642 | return defined( $_[1] = $tcp ); | ||||
643 | } | ||||
644 | |||||
645 | |||||
646 | sub bgisready { ## historical | ||||
647 | _deprecate('prefer ! bgbusy(...)'); # uncoverable pod | ||||
648 | return !&bgbusy; | ||||
649 | } | ||||
650 | |||||
651 | |||||
652 | sub bgread { | ||||
653 | while (&bgbusy) { # side effect: TCP retry | ||||
654 | IO::Select->new( $_[1] )->can_read(0.02); # reduce my CPU usage by 3 orders of magnitude | ||||
655 | } | ||||
656 | return &_bgread; | ||||
657 | } | ||||
658 | |||||
659 | |||||
660 | sub _bgread { | ||||
661 | my ( $self, $handle ) = @_; | ||||
662 | return unless $handle; | ||||
663 | |||||
664 | my $appendix = ${*$handle}{net_dns_bg}; | ||||
665 | my ( $expire, $query, $read ) = @$appendix; | ||||
666 | return shift(@$read) if ref($read); | ||||
667 | |||||
668 | my $select = IO::Select->new($handle); | ||||
669 | unless ( $select->can_read(0) ) { | ||||
670 | $self->errorstring('timed out'); | ||||
671 | return; | ||||
672 | } | ||||
673 | |||||
674 | my $peer = $self->{replyfrom} = $handle->peerhost; | ||||
675 | |||||
676 | my $dgram = $handle->socktype() == SOCK_DGRAM; | ||||
677 | my $buffer = $dgram ? _read_udp( $handle, $self->_packetsz ) : _read_tcp($handle); | ||||
678 | $self->_diag( "reply from [$peer]", length($buffer), 'bytes' ); | ||||
679 | |||||
680 | my $reply = Net::DNS::Packet->decode( \$buffer, $self->{debug} ); | ||||
681 | $self->errorstring($@); | ||||
682 | return unless $self->_accept_reply( $reply, $query ); | ||||
683 | $reply->from($peer); | ||||
684 | |||||
685 | return $reply unless $self->{tsig_rr} && !$reply->verify($query); | ||||
686 | $self->errorstring( $reply->verifyerr ); | ||||
687 | return; | ||||
688 | } | ||||
689 | |||||
690 | |||||
691 | sub _accept_reply { | ||||
692 | my ( $self, $reply, $query ) = @_; | ||||
693 | |||||
694 | return unless $reply; | ||||
695 | |||||
696 | my $header = $reply->header; | ||||
697 | return unless $header->qr; | ||||
698 | |||||
699 | return if $query && $header->id != $query->header->id; | ||||
700 | |||||
701 | return $self->errorstring( $header->rcode ); # historical quirk | ||||
702 | } | ||||
703 | |||||
704 | |||||
705 | sub axfr { ## zone transfer | ||||
706 | return eval { | ||||
707 | my $self = shift; | ||||
708 | |||||
709 | # initialise iterator state vector | ||||
710 | my ( $select, $verify, @rr, $soa ) = $self->_axfr_start(@_); | ||||
711 | |||||
712 | my $iterator = sub { ## iterate over RRs | ||||
713 | my $rr = shift(@rr); | ||||
714 | |||||
715 | if ( ref($rr) eq 'Net::DNS::RR::SOA' ) { | ||||
716 | if ($soa) { | ||||
717 | $select = undef; | ||||
718 | return if $rr->encode eq $soa->encode; | ||||
719 | croak $self->errorstring('mismatched final SOA'); | ||||
720 | } | ||||
721 | $soa = $rr; | ||||
722 | } | ||||
723 | |||||
724 | unless ( scalar @rr ) { | ||||
725 | my $reply; # refill @rr | ||||
726 | ( $reply, $verify ) = $self->_axfr_next( $select, $verify ); | ||||
727 | @rr = $reply->answer if $reply; | ||||
728 | } | ||||
729 | |||||
730 | return $rr; | ||||
731 | }; | ||||
732 | |||||
733 | return $iterator unless wantarray; | ||||
734 | |||||
735 | my @zone; ## subvert iterator to assemble entire zone | ||||
736 | while ( my $rr = $iterator->() ) { | ||||
737 | push @zone, $rr, @rr; # copy RRs en bloc | ||||
738 | @rr = pop(@zone); # leave last one in @rr | ||||
739 | } | ||||
740 | return @zone; | ||||
741 | }; | ||||
742 | } | ||||
743 | |||||
744 | |||||
745 | sub axfr_start { ## historical | ||||
746 | _deprecate('prefer $iterator = $self->axfr(...)'); # uncoverable pod | ||||
747 | my $self = shift; | ||||
748 | return defined( $self->{axfr_iter} = $self->axfr(@_) ); | ||||
749 | } | ||||
750 | |||||
751 | |||||
752 | sub axfr_next { ## historical | ||||
753 | _deprecate('prefer $iterator->()'); # uncoverable pod | ||||
754 | return shift->{axfr_iter}->(); | ||||
755 | } | ||||
756 | |||||
757 | |||||
758 | sub _axfr_start { | ||||
759 | my $self = shift; | ||||
760 | my $dname = scalar(@_) ? shift : $self->domain; | ||||
761 | my @class = @_; | ||||
762 | |||||
763 | my $request = $self->_make_query_packet( $dname, 'AXFR', @class ); | ||||
764 | my $content = $request->data; | ||||
765 | my $TCP_msg = pack 'n a*', length($content), $content; | ||||
766 | |||||
767 | $self->_diag("axfr( $dname @class )"); | ||||
768 | |||||
769 | my ( $select, $reply, $rcode ); | ||||
770 | foreach my $ns ( $self->nameservers ) { | ||||
771 | $self->_diag("axfr send [$ns]"); | ||||
772 | |||||
773 | my $socket = $self->_create_tcp_socket($ns); | ||||
774 | $self->errorstring($!); | ||||
775 | $select = IO::Select->new( $socket || next ); | ||||
776 | |||||
777 | $socket->send($TCP_msg); | ||||
778 | $self->errorstring($!); | ||||
779 | |||||
780 | ($reply) = $self->_axfr_next($select); | ||||
781 | last if ( $rcode = $reply->header->rcode ) eq 'NOERROR'; | ||||
782 | } | ||||
783 | |||||
784 | croak $self->errorstring unless $reply; | ||||
785 | |||||
786 | $self->errorstring($rcode); # historical quirk | ||||
787 | |||||
788 | my $verify = $request->sigrr ? $request : undef; | ||||
789 | unless ($verify) { | ||||
790 | croak $self->errorstring unless $rcode eq 'NOERROR'; | ||||
791 | return ( $select, $verify, $reply->answer ); | ||||
792 | } | ||||
793 | |||||
794 | my $verifyok = $reply->verify($verify); | ||||
795 | croak $self->errorstring( $reply->verifyerr ) unless $verifyok; | ||||
796 | croak $self->errorstring unless $rcode eq 'NOERROR'; | ||||
797 | return ( $select, $verifyok, $reply->answer ); | ||||
798 | } | ||||
799 | |||||
800 | |||||
801 | sub _axfr_next { | ||||
802 | my $self = shift; | ||||
803 | my $select = shift || return; | ||||
804 | my $verify = shift; | ||||
805 | |||||
806 | my ($socket) = $select->can_read( $self->{tcp_timeout} ); | ||||
807 | croak $self->errorstring('timed out') unless $socket; | ||||
808 | |||||
809 | my $buffer = _read_tcp($socket); | ||||
810 | my $packet = Net::DNS::Packet->decode( \$buffer ); | ||||
811 | croak $@, $self->errorstring('corrupt packet') if $@; | ||||
812 | |||||
813 | return ( $packet, $verify ) unless $verify; | ||||
814 | |||||
815 | my $verifyok = $packet->verify($verify); | ||||
816 | croak $self->errorstring( $packet->verifyerr ) unless $verifyok; | ||||
817 | return ( $packet, $verifyok ); | ||||
818 | } | ||||
819 | |||||
820 | |||||
821 | # | ||||
822 | # Usage: $data = _read_tcp($socket); | ||||
823 | # | ||||
824 | sub _read_tcp { | ||||
825 | my $socket = shift; | ||||
826 | |||||
827 | my ( $buffer, $s1, $s2 ); | ||||
828 | $socket->recv( $s1, 2 ); # one lump | ||||
829 | $socket->recv( $s2, 2 - length $s1 ); # or two? | ||||
830 | my $size = unpack 'n', pack( 'a*a*@2', $s1, $s2 ); | ||||
831 | |||||
832 | $socket->recv( $buffer, $size ); # initial read | ||||
833 | |||||
834 | while ( length($buffer) < $size ) { | ||||
835 | my $fragment; | ||||
836 | $socket->recv( $fragment, $size - length($buffer) ); | ||||
837 | $buffer .= $fragment || last; | ||||
838 | } | ||||
839 | return $buffer; | ||||
840 | } | ||||
841 | |||||
842 | |||||
843 | # | ||||
844 | # Usage: $data = _read_udp($socket, $length); | ||||
845 | # | ||||
846 | sub _read_udp { | ||||
847 | my $socket = shift; | ||||
848 | my $buffer = ''; | ||||
849 | $socket->recv( $buffer, shift ); | ||||
850 | return $buffer; | ||||
851 | } | ||||
852 | |||||
853 | |||||
854 | sub _create_tcp_socket { | ||||
855 | my $self = shift; | ||||
856 | my $ip = shift; | ||||
857 | |||||
858 | my $sock_key = "TCP[$ip]"; | ||||
859 | my $socket; | ||||
860 | |||||
861 | if ( $socket = $self->{persistent}{$sock_key} ) { | ||||
862 | $self->_diag( 'using persistent socket', $sock_key ); | ||||
863 | return $socket if $socket->connected; | ||||
864 | $self->_diag('socket disconnected (trying to connect)'); | ||||
865 | } | ||||
866 | |||||
867 | my $ip6_addr = IPv6 && _ipv6($ip); | ||||
868 | |||||
869 | $socket = IO::Socket::IP->new( | ||||
870 | LocalAddr => $ip6_addr ? $self->{srcaddr6} : $self->{srcaddr4}, | ||||
871 | LocalPort => $self->{srcport}, | ||||
872 | PeerAddr => $ip, | ||||
873 | PeerPort => $self->{port}, | ||||
874 | Proto => 'tcp', | ||||
875 | Timeout => $self->{tcp_timeout}, | ||||
876 | ) | ||||
877 | if USE_SOCKET_IP; | ||||
878 | |||||
879 | unless (USE_SOCKET_IP) { | ||||
880 | $socket = IO::Socket::INET->new( | ||||
881 | LocalAddr => $self->{srcaddr4}, | ||||
882 | LocalPort => $self->{srcport} || undef, | ||||
883 | PeerAddr => $ip, | ||||
884 | PeerPort => $self->{port}, | ||||
885 | Proto => 'tcp', | ||||
886 | Timeout => $self->{tcp_timeout}, | ||||
887 | ) | ||||
888 | unless $ip6_addr; | ||||
889 | } | ||||
890 | |||||
891 | $self->{persistent}{$sock_key} = $self->{persistent_tcp} ? $socket : undef; | ||||
892 | return $socket; | ||||
893 | } | ||||
894 | |||||
895 | |||||
896 | sub _create_udp_socket { | ||||
897 | my $self = shift; | ||||
898 | my $ip = shift; | ||||
899 | |||||
900 | my $ip6_addr = IPv6 && _ipv6($ip); | ||||
901 | my $sock_key = IPv6 && $ip6_addr ? 'UDP/IPv6' : 'UDP/IPv4'; | ||||
902 | my $socket; | ||||
903 | return $socket if $socket = $self->{persistent}{$sock_key}; | ||||
904 | |||||
905 | $socket = IO::Socket::IP->new( | ||||
906 | LocalAddr => $ip6_addr ? $self->{srcaddr6} : $self->{srcaddr4}, | ||||
907 | LocalPort => $self->{srcport}, | ||||
908 | Proto => 'udp', | ||||
909 | Type => SOCK_DGRAM | ||||
910 | ) | ||||
911 | if USE_SOCKET_IP; | ||||
912 | |||||
913 | unless (USE_SOCKET_IP) { | ||||
914 | $socket = IO::Socket::INET->new( | ||||
915 | LocalAddr => $self->{srcaddr4}, | ||||
916 | LocalPort => $self->{srcport} || undef, | ||||
917 | Proto => 'udp', | ||||
918 | Type => SOCK_DGRAM | ||||
919 | ) | ||||
920 | unless $ip6_addr; | ||||
921 | } | ||||
922 | |||||
923 | $self->{persistent}{$sock_key} = $self->{persistent_udp} ? $socket : undef; | ||||
924 | return $socket; | ||||
925 | } | ||||
926 | |||||
927 | |||||
928 | { | ||||
929 | no strict 'subs'; ## no critic ProhibitNoStrict | ||||
930 | use constant AI_NUMERICHOST => Socket::AI_NUMERICHOST; | ||||
931 | use constant IPPROTO_UDP => Socket::IPPROTO_UDP; | ||||
932 | |||||
933 | my $ip4 = {family => AF_INET, flags => AI_NUMERICHOST, protocol => IPPROTO_UDP, socktype => SOCK_DGRAM}; | ||||
934 | my $ip6 = {family => AF_INET6, flags => AI_NUMERICHOST, protocol => IPPROTO_UDP, socktype => SOCK_DGRAM}; | ||||
935 | |||||
936 | sub _create_dst_sockaddr { ## create UDP destination sockaddr structure | ||||
937 | my ( $self, $ip, $port ) = @_; | ||||
938 | |||||
939 | unless (USE_SOCKET_IP) { # NB: errors raised in socket->send | ||||
940 | return _ipv6($ip) ? undef : sockaddr_in( $port, inet_aton($ip) ); | ||||
941 | } | ||||
942 | |||||
943 | my @addrinfo = Socket::getaddrinfo( $ip, $port, _ipv6($ip) ? $ip6 : $ip4 ); | ||||
944 | return ( grep {ref} @addrinfo, {} )[0]->{addr}; | ||||
945 | } | ||||
946 | } | ||||
947 | |||||
948 | |||||
949 | # Lightweight versions of subroutines from Net::IP module, recoded to fix RT#96812 | ||||
950 | |||||
951 | sub _ipv4 { | ||||
952 | for (shift) { | ||||
953 | last if m/[^.0-9]/; # dots and digits only | ||||
954 | return m/\.\d+\./; # dots separated by digits | ||||
955 | } | ||||
956 | return; | ||||
957 | } | ||||
958 | |||||
959 | sub _ipv6 { | ||||
960 | for (shift) { | ||||
961 | last unless m/:.*:/; # must contain two colons | ||||
962 | return 1 unless m/[^:0-9A-Fa-f]/; # colons and hexdigits only | ||||
963 | return 1 if m/^[:.0-9A-Fa-f]+\%.+$/; # RFC4007 scoped address | ||||
964 | return m/^[:0-9A-Fa-f]+:[.0-9]+$/; # prefix : dotted digits | ||||
965 | } | ||||
966 | return; | ||||
967 | } | ||||
968 | |||||
969 | |||||
970 | sub _make_query_packet { | ||||
971 | my $self = shift; | ||||
972 | |||||
973 | my ($packet) = @_; | ||||
974 | if ( ref($packet) ) { | ||||
975 | my $edns = $packet->edns; # advertise UDPsize for local stack | ||||
976 | $edns->size( $self->{udppacketsize} ) unless defined $edns->{size}; | ||||
977 | |||||
978 | my $header = $packet->header; | ||||
979 | $header->rd( $self->{recurse} ) if $header->opcode eq 'QUERY'; | ||||
980 | |||||
981 | } else { | ||||
982 | $packet = Net::DNS::Packet->new(@_); | ||||
983 | $packet->edns->size( $self->{udppacketsize} ); | ||||
984 | |||||
985 | my $header = $packet->header; | ||||
986 | $header->ad( $self->{adflag} ); # RFC6840, 5.7 | ||||
987 | $header->cd( $self->{cdflag} ); # RFC6840, 5.9 | ||||
988 | $header->do(1) if $self->{dnssec}; | ||||
989 | $header->rd( $self->{recurse} ); | ||||
990 | } | ||||
991 | |||||
992 | if ( $self->{tsig_rr} ) { | ||||
993 | $packet->sign_tsig( $self->{tsig_rr} ) unless $packet->sigrr; | ||||
994 | } | ||||
995 | |||||
996 | return $packet; | ||||
997 | } | ||||
998 | |||||
999 | |||||
1000 | sub dnssec { | ||||
1001 | my $self = shift; | ||||
1002 | |||||
1003 | return $self->{dnssec} unless scalar @_; | ||||
1004 | |||||
1005 | # increase default udppacket size if flag set | ||||
1006 | $self->udppacketsize(2048) if $self->{dnssec} = shift; | ||||
1007 | |||||
1008 | return $self->{dnssec}; | ||||
1009 | } | ||||
1010 | |||||
1011 | |||||
1012 | sub force_v6 { | ||||
1013 | my $self = shift; | ||||
1014 | my $value = scalar(@_) ? $_[0] : $self->{force_v6}; | ||||
1015 | return $self->{force_v6} = $value ? do { $self->{force_v4} = 0; 1 } : 0; | ||||
1016 | } | ||||
1017 | |||||
1018 | sub force_v4 { | ||||
1019 | my $self = shift; | ||||
1020 | my $value = scalar(@_) ? $_[0] : $self->{force_v4}; | ||||
1021 | return $self->{force_v4} = $value ? do { $self->{force_v6} = 0; 1 } : 0; | ||||
1022 | } | ||||
1023 | |||||
1024 | sub prefer_v6 { | ||||
1025 | my $self = shift; | ||||
1026 | my $value = scalar(@_) ? $_[0] : $self->{prefer_v6}; | ||||
1027 | return $self->{prefer_v6} = $value ? do { $self->{prefer_v4} = 0; 1 } : 0; | ||||
1028 | } | ||||
1029 | |||||
1030 | sub prefer_v4 { | ||||
1031 | my $self = shift; | ||||
1032 | my $value = scalar(@_) ? $_[0] : $self->{prefer_v4}; | ||||
1033 | return $self->{prefer_v4} = $value ? do { $self->{prefer_v6} = 0; 1 } : 0; | ||||
1034 | } | ||||
1035 | |||||
1036 | |||||
1037 | sub srcaddr { | ||||
1038 | my $self = shift; | ||||
1039 | for (@_) { | ||||
1040 | my $hashkey = _ipv6($_) ? 'srcaddr6' : 'srcaddr4'; | ||||
1041 | $self->{$hashkey} = $_; | ||||
1042 | } | ||||
1043 | return shift; | ||||
1044 | } | ||||
1045 | |||||
1046 | |||||
1047 | sub tsig { | ||||
1048 | my $self = shift; | ||||
1049 | $self->{tsig_rr} = eval { | ||||
1050 | local $SIG{__DIE__}; | ||||
1051 | require Net::DNS::RR::TSIG; | ||||
1052 | Net::DNS::RR::TSIG->create(@_); | ||||
1053 | }; | ||||
1054 | croak "${@}unable to create TSIG record" if $@; | ||||
1055 | return; | ||||
1056 | } | ||||
1057 | |||||
1058 | |||||
1059 | # if ($self->{udppacketsize} > PACKETSZ | ||||
1060 | # then we use EDNS and $self->{udppacketsize} | ||||
1061 | # should be taken as the maximum packet_data length | ||||
1062 | sub _packetsz { | ||||
1063 | my $udpsize = shift->{udppacketsize} || 0; | ||||
1064 | return $udpsize > PACKETSZ ? $udpsize : PACKETSZ; | ||||
1065 | } | ||||
1066 | |||||
1067 | sub udppacketsize { | ||||
1068 | my $self = shift; | ||||
1069 | $self->{udppacketsize} = shift if scalar @_; | ||||
1070 | return $self->_packetsz; | ||||
1071 | } | ||||
1072 | |||||
1073 | |||||
1074 | # | ||||
1075 | # Keep this method around. Folk depend on it although it is neither documented nor exported. | ||||
1076 | # | ||||
1077 | sub make_query_packet { ## historical | ||||
1078 | _deprecate('see RT#37104'); # uncoverable pod | ||||
1079 | return &_make_query_packet; | ||||
1080 | } | ||||
1081 | |||||
1082 | |||||
1083 | sub _diag { ## debug output | ||||
1084 | my $self = shift; | ||||
1085 | return unless $self->{debug}; | ||||
1086 | return print "\n;; @_\n" | ||||
1087 | } | ||||
1088 | |||||
1089 | |||||
1090 | { | ||||
1091 | my $parse_dig = sub { | ||||
1092 | require Net::DNS::ZoneFile; | ||||
1093 | |||||
1094 | my $dug = Net::DNS::ZoneFile->new( \*DATA ); | ||||
1095 | my @rr = $dug->read; | ||||
1096 | |||||
1097 | my @auth = grep { $_->type eq 'NS' } @rr; | ||||
1098 | my %auth = map { lc $_->nsdname => 1 } @auth; | ||||
1099 | my %glue; | ||||
1100 | my @glue = grep { $auth{lc $_->name} } @rr; | ||||
1101 | foreach ( grep { $_->can('address') } @glue ) { | ||||
1102 | push @{$glue{lc $_->name}}, $_->address; | ||||
1103 | } | ||||
1104 | map { @$_ } values %glue; | ||||
1105 | }; | ||||
1106 | |||||
1107 | my @ip; | ||||
1108 | |||||
1109 | sub _hints { ## default hints | ||||
1110 | @ip = &$parse_dig unless scalar @ip; # once only, on demand | ||||
1111 | splice @ip, 0, 0, splice( @ip, int( rand scalar @ip ) ); # cut deck | ||||
1112 | return @ip; | ||||
1113 | } | ||||
1114 | } | ||||
1115 | |||||
1116 | |||||
1117 | our $AUTOLOAD; | ||||
1118 | |||||
1119 | sub DESTROY { } ## Avoid tickling AUTOLOAD (in cleanup) | ||||
1120 | |||||
1121 | sub AUTOLOAD { ## Default method | ||||
1122 | my ($self) = @_; | ||||
1123 | |||||
1124 | my $name = $AUTOLOAD; | ||||
1125 | $name =~ s/.*://; | ||||
1126 | croak qq[unknown method "$name"] unless $public_attr{$name}; | ||||
1127 | |||||
1128 | no strict 'refs'; ## no critic ProhibitNoStrict | ||||
1129 | *{$AUTOLOAD} = sub { | ||||
1130 | my $self = shift; | ||||
1131 | $self = $self->_defaults unless ref($self); | ||||
1132 | $self->{$name} = shift || 0 if scalar @_; | ||||
1133 | return $self->{$name}; | ||||
1134 | }; | ||||
1135 | |||||
1136 | goto &{$AUTOLOAD}; | ||||
1137 | } | ||||
1138 | |||||
1139 | |||||
1140 | 1; | ||||
1141 | |||||
1142 | |||||
1143 | =head1 NAME | ||||
1144 | |||||
1145 | Net::DNS::Resolver::Base - DNS resolver base class | ||||
1146 | |||||
1147 | =head1 SYNOPSIS | ||||
1148 | |||||
1149 | use base qw(Net::DNS::Resolver::Base); | ||||
1150 | |||||
1151 | =head1 DESCRIPTION | ||||
1152 | |||||
1153 | This class is the common base class for the different platform | ||||
1154 | sub-classes of L<Net::DNS::Resolver>. | ||||
1155 | |||||
1156 | No user serviceable parts inside, see L<Net::DNS::Resolver> | ||||
1157 | for all your resolving needs. | ||||
1158 | |||||
1159 | |||||
1160 | =head1 METHODS | ||||
1161 | |||||
1162 | =head2 new, domain, searchlist, nameserver, nameservers, | ||||
1163 | |||||
1164 | =head2 search, query, send, bgsend, bgbusy, bgread, axfr, | ||||
1165 | |||||
1166 | =head2 force_v4, force_v6, prefer_v4, prefer_v6, | ||||
1167 | |||||
1168 | =head2 dnssec, srcaddr, tsig, udppacketsize, | ||||
1169 | |||||
1170 | =head2 print, string, errorstring, replyfrom | ||||
1171 | |||||
1172 | See L<Net::DNS::Resolver>. | ||||
1173 | |||||
1174 | |||||
1175 | =head1 COPYRIGHT | ||||
1176 | |||||
1177 | Copyright (c)2003,2004 Chris Reinhardt. | ||||
1178 | |||||
1179 | Portions Copyright (c)2005 Olaf Kolkman. | ||||
1180 | |||||
1181 | Portions Copyright (c)2014-2017 Dick Franks. | ||||
1182 | |||||
1183 | All rights reserved. | ||||
1184 | |||||
1185 | |||||
1186 | =head1 LICENSE | ||||
1187 | |||||
1188 | Permission to use, copy, modify, and distribute this software and its | ||||
1189 | documentation for any purpose and without fee is hereby granted, provided | ||||
1190 | that the above copyright notice appear in all copies and that both that | ||||
1191 | copyright notice and this permission notice appear in supporting | ||||
1192 | documentation, and that the name of the author not be used in advertising | ||||
1193 | or publicity pertaining to distribution of the software without specific | ||||
1194 | prior written permission. | ||||
1195 | |||||
1196 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR | ||||
1197 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, | ||||
1198 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL | ||||
1199 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER | ||||
1200 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING | ||||
1201 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER | ||||
1202 | DEALINGS IN THE SOFTWARE. | ||||
1203 | |||||
1204 | |||||
1205 | =head1 SEE ALSO | ||||
1206 | |||||
1207 | L<perl>, L<Net::DNS>, L<Net::DNS::Resolver> | ||||
1208 | |||||
1209 | =cut | ||||
1210 | |||||
1211 | |||||
1212 | ######################################## | ||||
1213 | |||||
1214 | __DATA__ ## DEFAULT HINTS |