idn_to_ascii reverse_ip_address
domain_to_search_list)
;
use
Errno
qw(EADDRINUSE EACCES)
;
our
@ISA
=
qw()
;
our
$have_net_dns
;
our
$io_socket_module_name
;
BEGIN {
$have_net_dns
=
eval
{
require
Net::DNS; };
$io_socket_module_name
=
'IO::Socket::IP'
;
$io_socket_module_name
=
'IO::Socket::INET6'
;
$io_socket_module_name
=
'IO::Socket::INET'
;
}
}
sub
new {
my
$class
=
shift
;
$class
=
ref
(
$class
) ||
$class
;
my
(
$main
) =
@_
;
my
$self
= {
'main'
=>
$main
,
'conf'
=>
$main
->{conf},
'id_to_callback'
=> { },
};
bless
(
$self
,
$class
);
$self
;
}
sub
load_resolver {
my
(
$self
) =
@_
;
return
0
if
$self
->{no_resolver};
return
1
if
$self
->{res};
my
$force_ipv4
=
$self
->{main}->{force_ipv4};
my
$force_ipv6
=
$self
->{main}->{force_ipv6};
if
(!
$force_ipv4
&&
$io_socket_module_name
eq
'IO::Socket::INET'
) {
dbg(
"dns: socket module for IPv6 support not available"
);
die
"Use of IPv6 requested, but not available\n"
if
$force_ipv6
;
$force_ipv4
= 1;
$force_ipv6
= 0;
}
if
(!
$force_ipv4
) {
eval
{
my
$sock6
;
if
(
$io_socket_module_name
) {
$sock6
=
$io_socket_module_name
->new(
LocalAddr
=>
'::'
,
Proto
=>
'udp'
);
}
if
(
$sock6
) {
$sock6
->
close
() or
warn
"dns: error closing socket: $!\n"
}
$sock6
;
} or
do
{
dbg(
"dns: socket module %s is available, but no host support for IPv6"
,
$io_socket_module_name
);
die
"Use of IPv6 requested, but not available\n"
if
$force_ipv6
;
$force_ipv4
= 1;
$force_ipv6
= 0;
}
}
eval
{
die
"Net::DNS required\n"
if
!
$have_net_dns
;
die
"Net::DNS 0.69 required\n"
if
(version->parse(Net::DNS->VERSION) < version->parse(0.69));
my
$res
=
$self
->{res} = Net::DNS::Resolver->new(
force_v4
=>
$force_ipv4
);
if
(
$res
) {
$self
->{force_ipv4} =
$force_ipv4
;
$self
->{force_ipv6} =
$force_ipv6
;
$self
->{retry} = 1;
$self
->{retrans} = 3;
$res
->retry(1);
$res
->retrans(0);
$res
->dnsrch(0);
$res
->defnames(0);
$res
->tcp_timeout(3);
$res
->udp_timeout(3);
$res
->persistent_tcp(0);
$res
->persistent_udp(0);
my
$edns
=
$self
->{conf}->{dns_options}->{edns};
if
(
$edns
&&
$edns
> 512) {
$res
->udppacketsize(
$edns
);
dbg(
"dns: EDNS, UDP payload size %d"
,
$edns
);
}
my
@ns_addr_port
=
$self
->available_nameservers();
local
($1,$2);
@ns_addr_port
=
map
(/^\[(.*)\]:(\d+)\z/ ? $1 :
$_
,
@ns_addr_port
);
dbg(
"dns: nameservers set to %s"
,
join
(
', '
,
@ns_addr_port
));
$res
->nameservers(
@ns_addr_port
);
}
1;
} or
do
{
my
$eval_stat
= $@ ne
''
? $@ :
"errno=$!"
;
chomp
$eval_stat
;
warn
(
"dns: resolver create failed: $eval_stat\n"
);
};
dbg(
"dns: using socket module: %s version %s%s"
,
$io_socket_module_name
,
$io_socket_module_name
->VERSION,
$self
->{force_ipv4} ?
', forced IPv4'
:
$self
->{force_ipv6} ?
', forced IPv6'
:
''
);
dbg(
"dns: is Net::DNS::Resolver available? %s"
,
$self
->{res} ?
"yes"
:
"no"
);
if
(
$self
->{res} &&
defined
$Net::DNS::VERSION
) {
dbg(
"dns: Net::DNS version: %s"
,
$Net::DNS::VERSION
);
}
$self
->{no_resolver} = !
$self
->{res};
return
defined
$self
->{res};
}
sub
get_resolver {
my
(
$self
) =
@_
;
return
$self
->{res};
}
sub
configured_nameservers {
my
$self
=
shift
;
my
$res
=
$self
->{res};
my
@ns_addr_port
;
if
(
$self
->{conf}->{dns_servers}) {
@ns_addr_port
= @{
$self
->{conf}->{dns_servers}};
dbg(
"dns: servers set by config to: %s"
,
join
(
', '
,
@ns_addr_port
));
}
elsif
(
$res
) {
my
@ns
=
$res
->UNIVERSAL::can(
'nameservers'
) ?
$res
->nameservers
: @{
$res
->{nameservers}};
my
$port
=
$res
->UNIVERSAL::can(
'port'
) ?
$res
->port :
$res
->{port};
@ns_addr_port
=
map
(untaint_var(
"[$_]:"
.
$port
),
@ns
);
dbg(
"dns: servers obtained from Net::DNS : %s"
,
join
(
', '
,
@ns_addr_port
));
}
return
@ns_addr_port
;
}
sub
available_nameservers {
my
$self
=
shift
;
if
(
@_
) {
$self
->{available_dns_servers} = [
@_
];
dbg(
"dns: servers set by a caller to: %s"
,
join
(
', '
,@{
$self
->{available_dns_servers}}));
}
elsif
(!
$self
->{available_dns_servers}) {
$self
->{available_dns_servers} = [
$self
->configured_nameservers() ];
}
if
(
$self
->{force_ipv4} ||
$self
->{force_ipv6}) {
my
(
@filtered_addr_port
);
for
(@{
$self
->{available_dns_servers}}) {
local
($1,$2);
/^ \[ (.*) \] : (\d+) \z/xs or
next
;
my
(
$addr
,
$port
) = ($1,$2);
if
(
$addr
=~ IS_IPV4_ADDRESS) {
push
(
@filtered_addr_port
,
$_
)
unless
$self
->{force_ipv6};
}
elsif
(
$addr
=~ /:.*:/) {
push
(
@filtered_addr_port
,
$_
)
unless
$self
->{force_ipv4};
}
else
{
warn
"dns: Unrecognized DNS server specification: $_\n"
;
}
}
if
(
@filtered_addr_port
< @{
$self
->{available_dns_servers}}) {
dbg(
"dns: filtered DNS servers according to protocol family: %s"
,
join
(
", "
,
@filtered_addr_port
));
}
@{
$self
->{available_dns_servers}} =
@filtered_addr_port
;
}
die
"available_nameservers: No DNS servers available!\n"
if
!@{
$self
->{available_dns_servers}};
return
@{
$self
->{available_dns_servers}};
}
sub
disable_available_port {
my
(
$self
,
$lport
) =
@_
;
if
(
$lport
>= 0 &&
$lport
<= 65535) {
my
$conf
=
$self
->{conf};
if
(!
defined
$conf
->{dns_available_portscount}) {
$self
->pick_random_available_port();
}
if
(
vec
(
$conf
->{dns_available_ports_bitset},
$lport
, 1)) {
dbg(
"dns: disabling local port %d"
,
$lport
);
vec
(
$conf
->{dns_available_ports_bitset},
$lport
, 1) = 0;
$conf
->{dns_available_portscount_buckets}->[
$lport
>> 8] --;
$conf
->{dns_available_portscount} --;
}
}
}
sub
pick_random_available_port {
my
$self
=
shift
;
my
$port_number
;
my
$conf
=
$self
->{conf};
my
$available_portscount
=
$conf
->{dns_available_portscount};
if
(!
defined
$available_portscount
) {
my
$ports_bitset
=
$conf
->{dns_available_ports_bitset};
if
(!
defined
$ports_bitset
) {
Mail::SpamAssassin::Conf::set_ports_range(\
$ports_bitset
, 0, 0, 0);
$conf
->{dns_available_ports_bitset} =
$ports_bitset
;
}
my
@bucket_counts
= (0) x 256;
my
$all_zeroes
=
"\000"
x 32;
my
$all_ones
=
"\377"
x 32;
my
$ind
= 0;
$available_portscount
= 0;
foreach
my
$bucket
(0..255) {
my
$cnt
= 0;
my
$b
=
substr
(
$ports_bitset
,
$bucket
*32, 32);
if
(
$b
eq
$all_zeroes
) {
$ind
+= 256 }
elsif
(
$b
eq
$all_ones
) {
$ind
+= 256;
$cnt
+= 256 }
else
{
vec
(
$ports_bitset
,
$ind
++, 1) &&
$cnt
++
for
0..255;
}
$available_portscount
+=
$cnt
;
$bucket_counts
[
$bucket
] =
$cnt
;
}
$conf
->{dns_available_portscount} =
$available_portscount
;
if
(
$available_portscount
) {
$conf
->{dns_available_portscount_buckets} = \
@bucket_counts
;
}
else
{
$conf
->{dns_available_portscount_buckets} =
undef
;
$conf
->{dns_available_ports_bitset} =
''
;
}
}
dbg(
"dns: %d configured local ports for DNS queries"
,
$available_portscount
);
if
(
$available_portscount
> 0) {
my
$ports_bitset
=
$conf
->{dns_available_ports_bitset};
my
$n
=
int
(
rand
(
$available_portscount
));
my
$bucket_counts_ref
=
$conf
->{dns_available_portscount_buckets};
my
$ind
= 0;
foreach
my
$bucket
(0..255) {
my
$cnt
=
$bucket_counts_ref
->[
$bucket
];
if
(
$cnt
>
$n
) {
last
}
else
{
$n
-=
$cnt
;
$ind
+= 256 }
}
while
(
$ind
<= 65535) {
if
(
vec
(
$ports_bitset
,
$ind
, 1)) {
if
(
$n
<= 0) {
$port_number
=
$ind
;
last
}
else
{
$n
-- }
}
$ind
++;
}
}
return
$port_number
;
}
sub
connect_sock {
my
(
$self
) =
@_
;
dbg(
"dns: connect_sock, resolver: %s"
,
$self
->{no_resolver} ?
"no"
:
"yes"
);
return
if
$self
->{no_resolver};
$io_socket_module_name
or
die
"No Perl modules for network socket available"
;
if
(
$self
->{sock}) {
$self
->{sock}->
close
()
or info(
"dns: connect_sock: error closing socket %s: %s"
,
$self
->{sock}, $!);
$self
->{sock} =
undef
;
}
my
$sock
;
my
$errno
;
my
@ns_addr_port
=
$self
->available_nameservers();
my
(
$ns_addr
,
$ns_port
);
local
($1,$2);
(
$ns_addr
,
$ns_port
) = ($1,$2)
if
$ns_addr_port
[0] =~ /^\[(.*)\]:(\d+)\z/;
my
$srcaddr
;
if
(
$self
->{force_ipv4}) {
$srcaddr
=
"0.0.0.0"
;
}
elsif
(
$self
->{force_ipv6}) {
$srcaddr
=
"::"
;
}
elsif
(
$ns_addr
=~ IS_IPV4_ADDRESS) {
$srcaddr
=
"0.0.0.0"
;
}
elsif
(
$ns_addr
=~ /:.*:/) {
$srcaddr
=
"::"
;
}
else
{
}
my
$lport
;
my
$attempts
= 0;
for
(;;) {
$attempts
++;
$lport
=
$self
->pick_random_available_port();
if
(!
defined
$lport
) {
$lport
= 0;
dbg(
"dns: no configured local ports for DNS queries, letting OS choose"
);
}
if
(
$attempts
+1 > 50) {
warn
"dns: could not create a DNS resolver socket in $attempts attempts\n"
;
$errno
= 0;
last
;
}
dbg(
"dns: LocalAddr: [%s]:%d, name server: [%s]:%d, module %s"
,
$srcaddr
||
'x'
,
$lport
,
$ns_addr
,
$ns_port
,
$io_socket_module_name
);
my
%args
= (
PeerAddr
=>
$ns_addr
,
PeerPort
=>
$ns_port
,
LocalAddr
=>
$srcaddr
,
LocalPort
=>
$lport
,
Type
=> SOCK_DGRAM,
Proto
=>
'udp'
,
);
$sock
=
$io_socket_module_name
->new(
%args
);
last
if
$sock
;
$errno
=
$io_socket_module_name
eq
'IO::Socket::IP'
? $@ : $!;
if
($! == EADDRINUSE || $! == EACCES) {
dbg(
"dns: UDP port $lport already in use, trying another port"
);
if
(
$self
->{conf}->{dns_available_portscount} > 100) {
$self
->disable_available_port(
$lport
);
}
}
else
{
warn
"dns: error creating a DNS resolver socket: $errno"
;
goto
no_sock;
}
}
if
(!
$sock
) {
warn
"dns: could not create a DNS resolver socket in $attempts attempts: $errno\n"
;
goto
no_sock;
}
eval
{
my
(
$bufsiz
,
$newbufsiz
);
$bufsiz
=
$sock
->sockopt(Socket::SO_RCVBUF)
or
die
"cannot get a resolver socket rx buffer size: $!"
;
if
(
$bufsiz
>= 32*1024) {
dbg(
"dns: resolver socket rx buffer size is %d bytes, local port %d"
,
$bufsiz
,
$lport
);
}
else
{
$sock
->sockopt(Socket::SO_RCVBUF, 32*1024)
or
die
"cannot set a resolver socket rx buffer size: $!"
;
$newbufsiz
=
$sock
->sockopt(Socket::SO_RCVBUF)
or
die
"cannot get a resolver socket rx buffer size: $!"
;
dbg(
"dns: resolver socket rx buffer size changed from %d to %d bytes, "
.
"local port %d"
,
$bufsiz
,
$newbufsiz
,
$lport
);
}
1;
} or
do
{
my
$eval_stat
= $@ ne
''
? $@ :
"errno=$!"
;
chomp
$eval_stat
;
info(
"dns: socket buffer size error: $eval_stat"
);
};
$self
->{sock} =
$sock
;
$self
->{sock_as_vec} =
$self
->fhs_to_vec(
$self
->{sock});
return
;
no_sock:
undef
$self
->{sock};
undef
$self
->{sock_as_vec};
}
sub
connect_sock_if_reqd {
my
(
$self
) =
@_
;
$self
->connect_sock()
if
!
$self
->{sock};
}
sub
get_sock {
my
(
$self
) =
@_
;
$self
->connect_sock_if_reqd();
return
$self
->{sock};
}
sub
dnsext_dns0x20 {
my
(
$string
) =
@_
;
my
$rnd
;
my
$have_rnd_bits
= 0;
my
$result
=
''
;
for
my
$ic
(
unpack
(
"C*"
,
$string
)) {
if
(
chr
(
$ic
) =~ /^[A-Za-z]\z/) {
if
(
$have_rnd_bits
< 1) {
$rnd
=
int
(
rand
(0x7fffffff)) & 0xff;
$have_rnd_bits
= 8;
}
$ic
^= 0x20
if
$rnd
& 1;
$rnd
=
$rnd
>> 1;
$have_rnd_bits
--;
}
$result
.=
chr
(
$ic
);
}
return
$result
;
}
sub
new_dns_packet {
my
(
$self
,
$domain
,
$type
,
$class
) =
@_
;
return
if
$self
->{no_resolver};
if
(!
defined
(
$type
) ||
$type
eq
'PTR'
) {
if
(
$domain
=~ IS_IPV4_ADDRESS) {
$domain
= reverse_ip_address(
$domain
).
".in-addr.arpa."
;
$type
=
'PTR'
;
}
}
$type
=
'A'
if
!
defined
$type
;
$class
=
'IN'
if
!
defined
$class
;
my
$packet
;
eval
{
if
(utf8::is_utf8(
$domain
)) {
dbg(
"dns: new_dns_packet: domain is utf8 flagged: %s"
,
$domain
);
}
$domain
=~ s/\.*\z/./s;
if
(
length
(
$domain
) > 255) {
die
"domain name longer than 255 bytes\n"
;
}
elsif
(
$domain
!~ /^ (?: [^.]{1,63} \. )+ \z/sx) {
if
(
$domain
!~ /^ (?: [^.]+ \. )+ \z/sx) {
die
"a domain name contains a null label\n"
;
}
else
{
die
"a label in a domain name is longer than 63 bytes\n"
;
}
}
if
(
$self
->{conf}->{dns_options}->{dns0x20}) {
$domain
= dnsext_dns0x20(
$domain
);
}
else
{
$domain
=~
tr
/A-Z/a-z/;
}
$domain
=~ s{ ( [\000-\037\177-\377\\] ) }
{ $1 eq
'\\'
?
"\\$1"
:
sprintf
(
"\\%03d"
,
ord
($1)) }xgse;
$packet
= Net::DNS::Packet->new(
$domain
,
$type
,
$class
);
1;
} or
do
{
my
$eval_stat
= $@ ne
''
? $@ :
"errno=$!"
;
chomp
$eval_stat
;
die
"dns: (1) $eval_stat\n"
if
$eval_stat
=~ /__alarm__ignore__\(.*\)/s;
info(
"dns: new_dns_packet (domain=%s type=%s class=%s) failed: %s"
,
$domain
,
$type
,
$class
,
$eval_stat
);
};
if
(
$packet
) {
$packet
->header->rd(1);
my
$udp_payload_size
=
$self
->{conf}->{dns_options}->{edns};
if
(
$udp_payload_size
&&
$udp_payload_size
> 512) {
$packet
->edns->size(
$udp_payload_size
);
}
}
return
$packet
;
}
sub
_packet_id {
my
(
$self
,
$packet
) =
@_
;
my
$header
=
$packet
->header;
my
$id
=
$header
->id;
my
@questions
=
$packet
->question;
@questions
<= 1
or
warn
"dns: packet has multiple questions: "
.
$packet
->string .
"\n"
;
if
(
$questions
[0]) {
my
(
$class
,
$type
,
$qname
) = decode_dns_question_entry(
$questions
[0]);
$qname
=~
tr
/A-Z/a-z/
if
!
$self
->{conf}->{dns_options}->{dns0x20};
return
join
(
'/'
,
$id
,
$class
,
$type
,
$qname
);
}
else
{
return
$id
.
"/NO_QUESTION_IN_PACKET"
;
}
}
sub
bgsend {
my
(
$self
,
$domain
,
$type
,
$class
,
$cb
) =
@_
;
return
if
$self
->{no_resolver};
my
$dns_query_blockages
=
$self
->{main}->{conf}->{dns_query_blocked};
if
(
$dns_query_blockages
) {
my
$search_list
= domain_to_search_list(
$domain
);
foreach
my
$parent_domain
((
@$search_list
,
'*'
)) {
my
$blocked
=
$dns_query_blockages
->{
$parent_domain
};
next
if
!
defined
$blocked
;
last
if
!
$blocked
;
dbg(
"dns: bgsend, query $type/$domain blocked by dns_query_restriction: $parent_domain"
);
return
;
}
}
$self
->{send_timed_out} = 0;
my
$pkt
=
$self
->new_dns_packet(
$domain
,
$type
,
$class
);
return
if
!
$pkt
;
my
@ns_addr_port
=
$self
->available_nameservers();
dbg(
"dns: bgsend, DNS servers: %s"
,
join
(
', '
,
@ns_addr_port
));
my
$n_servers
=
scalar
@ns_addr_port
;
my
$ok
;
for
(
my
$attempts
=1;
$attempts
<=
$n_servers
;
$attempts
++) {
dbg(
"dns: attempt %d/%d, trying connect/sendto to %s"
,
$attempts
,
$n_servers
,
$ns_addr_port
[0]);
$self
->connect_sock_if_reqd();
if
(
$self
->{sock} &&
defined
(
$self
->{sock}->
send
(
$pkt
->data, 0))) {
$ok
= 1;
last
;
}
else
{
my
$msg
= !
$self
->{sock} ?
"unable to connect to $ns_addr_port[0]"
:
"sendto() to $ns_addr_port[0] failed: $!"
;
$self
->finish_socket();
if
(
$attempts
>=
$n_servers
) {
warn
"dns: $msg, no more alternatives\n"
;
last
;
}
warn
"dns: $msg, failing over to $ns_addr_port[1]\n"
;
push
(
@ns_addr_port
,
shift
(
@ns_addr_port
));
$self
->available_nameservers(
@ns_addr_port
);
}
}
return
if
!
$ok
;
my
$id
=
$self
->_packet_id(
$pkt
);
dbg(
"dns: providing a callback for id: $id"
);
$self
->{id_to_callback}->{
$id
} =
$cb
;
return
$id
;
}
sub
bgread {
my
(
$self
) =
@_
;
my
$sock
=
$self
->{sock};
my
$packetsize
=
$self
->{res}->udppacketsize;
$packetsize
= 512
if
$packetsize
< 512;
my
$data
=
''
;
my
$peeraddr
=
$sock
->
recv
(
$data
,
$packetsize
+256);
defined
$peeraddr
or
die
"bgread: recv() failed: $!"
;
my
$peerhost
=
$sock
->peerhost;
$data
ne
''
or
die
"bgread: received empty packet from $peerhost"
;
dbg(
"dns: bgread: received %d bytes from %s"
,
length
(
$data
),
$peerhost
);
my
(
$answerpkt
,
$decoded_length
) = Net::DNS::Packet->new(\
$data
);
$answerpkt
or
die
"bgread: decoding DNS packet failed: $@"
;
$answerpkt
->answerfrom(
$peerhost
);
if
(
defined
$decoded_length
&&
$decoded_length
ne
""
&&
$decoded_length
!=
length
(
$data
)) {
warn
sprintf
(
"dns: bgread: received a %d bytes packet from %s, decoded %d bytes\n"
,
length
(
$data
),
$peerhost
,
$decoded_length
);
}
return
$answerpkt
;
}
sub
poll_responses {
my
(
$self
,
$timeout
) =
@_
;
return
if
$self
->{no_resolver};
return
if
!
$self
->{sock};
my
$cnt
= 0;
my
$cnt_cb
= 0;
my
$rin
=
$self
->{sock_as_vec};
my
$rout
;
for
(;;) {
my
(
$nfound
,
$timeleft
,
$eval_stat
);
my
$eintrcount
= 3;
eval
{
my
$timer
;
if
(!
defined
(
$timeout
) ||
$timeout
> 0)
{
$timer
=
$self
->{main}->time_method(
"poll_dns_idle"
) }
$! = 0;
(
$nfound
,
$timeleft
) =
select
(
$rout
=
$rin
,
undef
,
undef
,
$timeout
);
1;
} or
do
{
$eval_stat
= $@ ne
''
? $@ :
"errno=$!"
;
chomp
$eval_stat
;
};
if
(
defined
$eval_stat
) {
die
"dns: (2) $eval_stat\n"
if
$eval_stat
=~ /__alarm__ignore__\(.*\)/s;
warn
"dns: select aborted: $eval_stat\n"
;
last
;
}
elsif
(!
defined
$nfound
||
$nfound
< 0) {
if
($!{EINTR} and
$eintrcount
> 0) {
$eintrcount
--;
next
;
}
if
($!) {
warn
"dns: select failed: $!\n"
}
else
{ info(
"dns: select interrupted"
) }
last
;
}
elsif
(!
$nfound
) {
if
(!
defined
$timeout
) {
warn
(
"dns: select returned empty-handed\n"
) }
elsif
(
$timeout
> 0) { dbg(
"dns: select timed out %.3f s"
,
$timeout
) }
last
;
}
$cnt
+=
$nfound
;
my
$now
=
time
;
$timeout
= 0;
last
if
$nfound
== 0;
my
$packet
;
eval
{
$packet
=
$self
->bgread();
} or
do
{
undef
$packet
;
my
$eval_stat
= $@ ne
''
? $@ :
"errno=$!"
;
chomp
$eval_stat
;
die
$eval_stat
if
$eval_stat
=~ /__alarm__ignore__\(.*\)/s;
info(
"dns: bad dns reply: %s"
,
$eval_stat
);
};
if
(!
$packet
) {
}
else
{
my
$header
=
$packet
->header;
if
(!
$header
) {
info(
"dns: dns reply is missing a header section"
);
}
else
{
my
$rcode
=
$header
->rcode;
my
$packet_id
=
$header
->id;
my
$id
=
$self
->_packet_id(
$packet
);
if
(
$rcode
eq
'NOERROR'
) {
dbg(
"dns: dns reply %s is OK, %d answer records"
,
$packet_id
,
$header
->ancount);
if
(
$header
->tc) {
my
$edns
=
$self
->{conf}->{dns_options}->{edns} || 512;
info(
"dns: reply to %s truncated (%s), %d answer records"
,
$id
,
$edns
== 512 ?
"EDNS off"
:
"EDNS $edns bytes"
,
$header
->ancount);
}
}
else
{
dbg(
"dns: dns reply to %s: %s"
,
$id
,
$rcode
);
}
my
$cb
=
delete
$self
->{id_to_callback}->{
$id
};
if
(
$cb
) {
$cb
->(
$packet
,
$id
,
$now
);
$cnt_cb
++;
}
else
{
if
(
$rcode
eq
'REFUSED'
||
$id
=~ m{^\d+/NO_QUESTION_IN_PACKET\z}) {
}
else
{
info(
"dns: no callback for id $id, ignored, packet on next debug line"
);
dbg(
"dns: %s"
,
$packet
?
$packet
->string :
"undef"
);
}
local
$1;
if
(
$id
=~ m{^(\d+)/}) {
my
$dnsid
= $1;
my
@matches
=
grep
(m{^\Q
$dnsid
\E/}o,
keys
%{
$self
->{id_to_callback}});
if
(!
@matches
) {
info(
"dns: no likely matching queries for id %s"
,
$dnsid
);
}
else
{
info(
"dns: a likely matching query: %s"
,
join
(
', '
,
@matches
));
}
}
}
}
}
}
return
(
$cnt
,
$cnt_cb
);
}
use
constant
RECV_FLAGS
=>
eval
{ MSG_DONTWAIT } || 0;
sub
flush_responses {
my
(
$self
) =
@_
;
return
if
$self
->{no_resolver};
return
if
!
$self
->{sock};
my
$rin
=
$self
->{sock_as_vec};
my
$rout
;
my
$nfound
;
my
$packetsize
=
$self
->{res}->udppacketsize;
$packetsize
= 512
if
$packetsize
< 512;
$self
->{sock}->blocking(0)
unless
(RECV_FLAGS);
for
(;;) {
eval
{
(
$nfound
,
undef
) =
select
(
$rout
=
$rin
,
undef
,
undef
, 0);
1;
} or
do
{
last
;
};
last
if
!
$nfound
;
last
if
!
$self
->{sock}->
recv
(
my
$data
,
$packetsize
+256, RECV_FLAGS);
}
$self
->{sock}->blocking(1)
unless
(RECV_FLAGS);
}
sub
bgabort {
my
(
$self
) =
@_
;
$self
->{id_to_callback} = {};
}
sub
send
{
my
(
$self
,
$name
,
$type
,
$class
) =
@_
;
return
if
$self
->{no_resolver};
$name
= idn_to_ascii(
$name
);
my
$retrans
=
$self
->{retrans};
my
$retries
=
$self
->{retry};
my
$timeout
=
$retrans
;
my
$answerpkt
;
my
$answerpkt_avail
= 0;
for
(
my
$i
= 0;
((
$i
<
$retries
) && !
defined
(
$answerpkt
));
++
$i
,
$retrans
*= 2,
$timeout
=
$retrans
) {
$timeout
= 1
if
(
$timeout
< 1);
my
$id
=
$self
->bgsend(
$name
,
$type
,
$class
,
sub
{
my
(
$reply
,
$reply_id
,
$timestamp
) =
@_
;
$answerpkt
=
$reply
;
$answerpkt_avail
= 1;
});
last
if
!
defined
$id
;
my
$now
=
time
;
my
$deadline
=
$now
+
$timeout
;
while
(!
$answerpkt_avail
) {
if
(
$now
>=
$deadline
) {
$self
->{send_timed_out} = 1;
last
}
$self
->poll_responses(1);
$now
=
time
;
}
}
return
$answerpkt
;
}
sub
errorstring {
my
(
$self
) =
@_
;
return
'query timed out'
if
$self
->{send_timed_out};
return
'unknown error or no error'
;
}
sub
finish_socket {
my
(
$self
) =
@_
;
if
(
$self
->{sock}) {
$self
->{sock}->
close
()
or
warn
"dns: finish_socket: error closing socket $self->{sock}: $!\n"
;
undef
$self
->{sock};
}
}
sub
finish {
my
(
$self
) =
@_
;
$self
->finish_socket();
%{
$self
} = ();
}
sub
fhs_to_vec {
my
(
$self
,
@fhlist
) =
@_
;
my
$rin
=
''
;
foreach
my
$sock
(
@fhlist
) {
my
$fno
=
fileno
(
$sock
);
if
(!
defined
$fno
) {
warn
"dns: oops! fileno now undef for $sock\n"
;
}
else
{
vec
(
$rin
,
$fno
, 1) = 1;
}
}
return
$rin
;
}
sub
reinit_post_fork {
my
(
$self
) =
@_
;
$self
->finish_socket();
}
1;