← 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:15 2021

Filename/usr/local/lib/perl5/site_perl/Mail/DKIM/AuthorDomainPolicy.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sMail::DKIM::AuthorDomainPolicy::::BEGIN@14Mail::DKIM::AuthorDomainPolicy::BEGIN@14
0000s0sMail::DKIM::AuthorDomainPolicy::::BEGIN@18Mail::DKIM::AuthorDomainPolicy::BEGIN@18
0000s0sMail::DKIM::AuthorDomainPolicy::::BEGIN@2Mail::DKIM::AuthorDomainPolicy::BEGIN@2
0000s0sMail::DKIM::AuthorDomainPolicy::::BEGIN@3Mail::DKIM::AuthorDomainPolicy::BEGIN@3
0000s0sMail::DKIM::AuthorDomainPolicy::::__ANON__Mail::DKIM::AuthorDomainPolicy::__ANON__ (xsub)
0000s0sMail::DKIM::AuthorDomainPolicy::::applyMail::DKIM::AuthorDomainPolicy::apply
0000s0sMail::DKIM::AuthorDomainPolicy::::defaultMail::DKIM::AuthorDomainPolicy::default
0000s0sMail::DKIM::AuthorDomainPolicy::::fetchMail::DKIM::AuthorDomainPolicy::fetch
0000s0sMail::DKIM::AuthorDomainPolicy::::get_lookup_nameMail::DKIM::AuthorDomainPolicy::get_lookup_name
0000s0sMail::DKIM::AuthorDomainPolicy::::is_implied_default_policyMail::DKIM::AuthorDomainPolicy::is_implied_default_policy
0000s0sMail::DKIM::AuthorDomainPolicy::::locationMail::DKIM::AuthorDomainPolicy::location
0000s0sMail::DKIM::AuthorDomainPolicy::::nameMail::DKIM::AuthorDomainPolicy::name
0000s0sMail::DKIM::AuthorDomainPolicy::::newMail::DKIM::AuthorDomainPolicy::new
0000s0sMail::DKIM::AuthorDomainPolicy::::nxdomain_policyMail::DKIM::AuthorDomainPolicy::nxdomain_policy
0000s0sMail::DKIM::AuthorDomainPolicy::::policyMail::DKIM::AuthorDomainPolicy::policy
0000s0sMail::DKIM::AuthorDomainPolicy::::signallMail::DKIM::AuthorDomainPolicy::signall
0000s0sMail::DKIM::AuthorDomainPolicy::::signall_strictMail::DKIM::AuthorDomainPolicy::signall_strict
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::AuthorDomainPolicy;
2use strict;
3use warnings;
4our $VERSION = '1.20200907'; # VERSION
5# ABSTRACT: represents an Author Domain Signing Practices (ADSP) record
6
7# Copyright 2005-2009 Messiah College.
8# Jason Long <jlong@messiah.edu>
9
10# Copyright (c) 2004 Anthony D. Urso. All rights reserved.
11# This program is free software; you can redistribute it and/or
12# modify it under the same terms as Perl itself.
13
14use base 'Mail::DKIM::Policy';
15
16# base class is used for parse(), as_string()
17
18use Mail::DKIM::DNS;
19
20
21sub fetch {
22 my $class = shift;
23 my %prms = @_;
24
25 my $self;
26 my $had_error= not eval {
27 local $SIG{__DIE__};
28 $self= $class->SUPER::fetch(%prms);
29 1
30 };
31 my $E = $@;
32
33 if ( $self && !$self->is_implied_default_policy ) {
34 return $self;
35 }
36
37 # didn't find a policy; check the domain itself
38 {
39 #FIXME- not good to have this code duplicated between
40 #here and get_lookup_name()
41 #
42 if ( $prms{Author} && !$prms{Domain} ) {
43 $prms{Domain} = ( $prms{Author} =~ /\@([^@]*)$/ and $1 );
44 }
45
46 unless ( $prms{Domain} ) {
47 die "no domain to fetch policy for\n";
48 }
49
50 my @resp = Mail::DKIM::DNS::query( $prms{Domain}, 'MX' );
51 if ( !@resp && $@ eq 'NXDOMAIN' ) {
52 return $class->nxdomain_policy;
53 }
54 }
55
56 die $E if $had_error;
57 return $self;
58}
59
60# get_lookup_name() - determine name of record to fetch
61#
62sub get_lookup_name {
63 my $self = shift;
64 my ($prms) = @_;
65
66 # in ADSP, the record to fetch is determined based on the From header
67
68 if ( $prms->{Author} && !$prms->{Domain} ) {
69 $prms->{Domain} = ( $prms->{Author} =~ /\@([^@]*)$/ and $1 );
70 }
71
72 unless ( $prms->{Domain} ) {
73 die "no domain to fetch policy for\n";
74 }
75
76 # IETF seems poised to create policy records this way
77 return '_adsp._domainkey.' . $prms->{Domain};
78}
79
80
81sub new {
82 my $class = shift;
83 return $class->parse( String => '' );
84}
85
86
87#undocumented private class method
88our $DEFAULT_POLICY;
89
90sub default {
91 my $class = shift;
92 $DEFAULT_POLICY ||= $class->new;
93 return $DEFAULT_POLICY;
94}
95
96#undocumented private class method
97our $NXDOMAIN_POLICY;
98
99sub nxdomain_policy {
100 my $class = shift;
101 if ( !$NXDOMAIN_POLICY ) {
102 $NXDOMAIN_POLICY = $class->new;
103 $NXDOMAIN_POLICY->policy('NXDOMAIN');
104 }
105 return $NXDOMAIN_POLICY;
106}
107
108
109sub apply {
110 my $self = shift;
111 my ($dkim) = @_;
112
113 # first_party indicates whether there is a DKIM signature with
114 # a d= tag matching the address in the From: header
115 my $first_party;
116
117 my @passing_signatures =
118 grep { $_->result && $_->result eq 'pass' } $dkim->signatures;
119
120 foreach my $signature (@passing_signatures) {
121 my $author_domain = $dkim->message_originator->host;
122 if ( lc $author_domain eq lc $signature->domain ) {
123
124 # found a first party signature
125 $first_party = 1;
126 last;
127 }
128 }
129
130 return 'accept' if $first_party;
131 return 'reject' if ( $self->signall_strict );
132
133 return 'neutral';
134}
135
136
137sub is_implied_default_policy {
138 my $self = shift;
139 my $default_policy = ref($self)->default;
140 return ( $self == $default_policy );
141}
142
143
144sub location {
145 my $self = shift;
146 return $self->{Domain};
147}
148
149sub name {
150 return 'ADSP';
151}
152
153
154sub policy {
155 my $self = shift;
156
157 (@_)
158 and $self->{tags}->{dkim} = shift;
159
160 if ( defined $self->{tags}->{dkim} ) {
161 return $self->{tags}->{dkim};
162 }
163 else {
164 return 'unknown';
165 }
166}
167
168
169sub signall {
170 my $self = shift;
171
172 return $self->policy
173 && ( $self->policy =~ /all/i );
174}
175
176
177sub signall_strict {
178 my $self = shift;
179
180 return $self->policy
181 && ( $self->policy =~ /discardable/i );
182}
183
1841;
185
186__END__