← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:14 2021

Filename/usr/local/lib/perl5/site_perl/Mail/DKIM/DNS.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sMail::DKIM::DNS::::BEGIN@15Mail::DKIM::DNS::BEGIN@15
0000s0sMail::DKIM::DNS::::BEGIN@2Mail::DKIM::DNS::BEGIN@2
0000s0sMail::DKIM::DNS::::BEGIN@3Mail::DKIM::DNS::BEGIN@3
0000s0sMail::DKIM::DNS::::__ANON__[:153]Mail::DKIM::DNS::__ANON__[:153]
0000s0sMail::DKIM::DNS::::__ANON__[:154]Mail::DKIM::DNS::__ANON__[:154]
0000s0sMail::DKIM::DNS::::__ANON__[:169]Mail::DKIM::DNS::__ANON__[:169]
0000s0sMail::DKIM::DNS::::__ANON__[:70]Mail::DKIM::DNS::__ANON__[:70]
0000s0sMail::DKIM::DNS::::enable_EDNS0Mail::DKIM::DNS::enable_EDNS0
0000s0sMail::DKIM::DNS::::queryMail::DKIM::DNS::query
0000s0sMail::DKIM::DNS::::query_asyncMail::DKIM::DNS::query_async
0000s0sMail::DKIM::DNS::::resolverMail::DKIM::DNS::resolver
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package Mail::DKIM::DNS;
2use strict;
3use warnings;
4our $VERSION = '1.20200907'; # VERSION
5# ABSTRACT: performs DNS queries for Mail::DKIM
6
7# Copyright 2007, 2012 Messiah College. All rights reserved.
8# Jason Long <jlong@messiah.edu>
9
10
11# This class contains a method to perform synchronous DNS queries.
12# Hopefully some day it will have a method to perform
13# asynchronous DNS queries.
14
15use Net::DNS;
16our $TIMEOUT = 10;
17our $RESOLVER;
18
19sub resolver {
20 if (@_) {
21 $RESOLVER = $_[0];
22 }
23 return $RESOLVER;
24}
25
26sub enable_EDNS0 {
27
28 # enable EDNS0, set acceptable UDP packet size to a
29 # conservative payload size that should fit into a single
30 # packet (MTU less the IP header size) in most cases;
31 # See also draft-andrews-dnsext-udp-fragmentation
32 # and RFC 3542 section 11.3.
33
34 my $res = Net::DNS::Resolver->new();
35 $res->udppacketsize( 1280 - 40 );
36 resolver($res);
37}
38
39# query- returns a list of RR objects
40# or an empty list if the domain record does not exist
41# (e.g. in the case of NXDOMAIN or NODATA)
42# or throws an error on a DNS query time-out or other transient error
43# (e.g. SERVFAIL)
44#
45# if an empty list is returned, $@ is also set to a string explaining
46# why no records were returned (e.g. "NXDOMAIN").
47#
48sub query {
49 my ( $domain, $type ) = @_;
50
51 if ( !$RESOLVER ) {
52 $RESOLVER = Net::DNS::Resolver->new()
53 or die "Internal error: can't create DNS resolver";
54 }
55
56 my $rslv = $RESOLVER;
57
58 #
59 # perform the DNS query
60 # if the query takes too long, we should generate an error
61 #
62 my $resp;
63 my $remaining_time = alarm(0); # check time left, stop the timer
64 my $deadline = time + $remaining_time;
65 my $E;
66 eval {
67 local $SIG{__DIE__};
68
69 # set a timeout, 10 seconds by default
70 local $SIG{ALRM} = sub { die "DNS query timeout for $domain\n" };
71 alarm $TIMEOUT;
72
73 # the query itself could cause an exception, which would prevent
74 # us from resetting the alarm before leaving the eval {} block
75 # so we wrap the query in a nested eval {} block
76 my $E2;
77 eval {
78 local $SIG{__DIE__};
79 $resp = $rslv->send( $domain, $type );
80 1;
81 } or do {
82 $E2 = $@;
83 };
84 alarm 0;
85 if ($E2) { chomp $E2; die "$E2\n" } # no line number here
86 1;
87 } or do {
88 $E = $@; # the $@ only makes sense if eval returns a false
89 };
90 alarm 0;
91
92 # restart the timer if it was active
93 if ( $remaining_time > 0 ) {
94 my $dt = $deadline - time;
95
96 # make sure the timer expiration will trigger a signal,
97 # even at the expense of stretching the interval by one second
98 alarm( $dt < 1 ? 1 : $dt );
99 }
100 if ($E) { chomp $E; die $E } # ensure a line number
101
102 # RFC 2308: NODATA is indicated by an answer with the RCODE set to NOERROR
103 # and no relevant answers in the answer section. The authority section
104 # will contain an SOA record, or there will be no NS records there.
105 # NODATA responses have to be algorithmically determined from the
106 # response's contents as there is no RCODE value to indicate NODATA.
107 # In some cases to determine with certainty that NODATA is the correct
108 # response it can be necessary to send another query.
109
110 if ($resp) {
111 my $header = $resp->header;
112 if ($header) {
113
114 # NOERROR, NXDOMAIN, SERVFAIL, FORMERR, REFUSED, ...
115 my $rcode = $header->rcode;
116
117 $@ = $rcode;
118 if ( $rcode eq 'NOERROR' ) {
119
120 # may or may not contain RRs in the answer sect
121 my @result = grep { lc $_->type eq lc $type } $resp->answer;
122 $@ = 'NODATA' if !@result;
123 return @result; # possibly empty
124 }
125 elsif ( $rcode eq 'NXDOMAIN' ) {
126 return; # empty list, rcode in $@
127 }
128 }
129 }
130 if ( $rslv->errorstring eq 'NOERROR' ) {
131 return;
132 }
133 if ( $rslv->errorstring =~ /\bno error\b/ ) {
134 return;
135 }
136 die 'DNS error: ' . $rslv->errorstring . "\n";
137}
138
139# query_async() - perform a DNS query asynchronously
140#
141# my $waiter = query_async('example.org', 'TXT',
142# Callbacks => {
143# Success => \&on_success,
144# Error => \&on_error,
145# },
146# );
147# my $result = $waiter->();
148#
149sub query_async {
150 my ( $domain, $type, %prms ) = @_;
151
152 my $callbacks = $prms{Callbacks} || {};
153 my $on_success = $callbacks->{Success} || sub { $_[0] };
154 my $on_error = $callbacks->{Error} || sub { die $_[0] };
155
156 my $waiter = sub {
157 my @resp;
158 my $rcode;
159 eval {
160 local $SIG{__DIE__};
161 @resp = query( $domain, $type );
162 $rcode = $@;
163 1;
164 } or do {
165 return $on_error->($@);
166 };
167 $@ = $rcode;
168 return $on_success->(@resp);
169 };
170 return $waiter;
171}
172
1731;
174
175__END__