← 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/DkimPolicy.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sMail::DKIM::DkimPolicy::::BEGIN@14Mail::DKIM::DkimPolicy::BEGIN@14
0000s0sMail::DKIM::DkimPolicy::::BEGIN@18Mail::DKIM::DkimPolicy::BEGIN@18
0000s0sMail::DKIM::DkimPolicy::::BEGIN@2Mail::DKIM::DkimPolicy::BEGIN@2
0000s0sMail::DKIM::DkimPolicy::::BEGIN@3Mail::DKIM::DkimPolicy::BEGIN@3
0000s0sMail::DKIM::DkimPolicy::::__ANON__Mail::DKIM::DkimPolicy::__ANON__ (xsub)
0000s0sMail::DKIM::DkimPolicy::::applyMail::DKIM::DkimPolicy::apply
0000s0sMail::DKIM::DkimPolicy::::defaultMail::DKIM::DkimPolicy::default
0000s0sMail::DKIM::DkimPolicy::::flagsMail::DKIM::DkimPolicy::flags
0000s0sMail::DKIM::DkimPolicy::::get_lookup_nameMail::DKIM::DkimPolicy::get_lookup_name
0000s0sMail::DKIM::DkimPolicy::::is_implied_default_policyMail::DKIM::DkimPolicy::is_implied_default_policy
0000s0sMail::DKIM::DkimPolicy::::locationMail::DKIM::DkimPolicy::location
0000s0sMail::DKIM::DkimPolicy::::nameMail::DKIM::DkimPolicy::name
0000s0sMail::DKIM::DkimPolicy::::newMail::DKIM::DkimPolicy::new
0000s0sMail::DKIM::DkimPolicy::::policyMail::DKIM::DkimPolicy::policy
0000s0sMail::DKIM::DkimPolicy::::signallMail::DKIM::DkimPolicy::signall
0000s0sMail::DKIM::DkimPolicy::::signall_strictMail::DKIM::DkimPolicy::signall_strict
0000s0sMail::DKIM::DkimPolicy::::signsomeMail::DKIM::DkimPolicy::signsome
0000s0sMail::DKIM::DkimPolicy::::testingMail::DKIM::DkimPolicy::testing
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::DkimPolicy;
2use strict;
3use warnings;
4our $VERSION = '1.20200907'; # VERSION
5# ABSTRACT: represents a DKIM Sender Signing Practices record
6
7# Copyright 2005-2007 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
21# get_lookup_name() - determine name of record to fetch
22#
23sub get_lookup_name {
24 my $self = shift;
25 my ($prms) = @_;
26
27 # in DKIM, the record to fetch is determined based on the From header
28
29 if ( $prms->{Author} && !$prms->{Domain} ) {
30 $prms->{Domain} = ( $prms->{Author} =~ /\@([^@]*)$/ and $1 );
31 }
32
33 unless ( $prms->{Domain} ) {
34 die "no domain to fetch policy for\n";
35 }
36
37 # IETF seems poised to create policy records this way
38 return '_policy._domainkey.' . $prms->{Domain};
39}
40
41
42sub new {
43 my $class = shift;
44 return $class->parse( String => 'o=~' );
45}
46
47#undocumented private class method
48our $DEFAULT_POLICY;
49
50sub default {
51 my $class = shift;
52 $DEFAULT_POLICY ||= $class->new;
53 return $DEFAULT_POLICY;
54}
55
56
57sub apply {
58 my $self = shift;
59 my ($dkim) = @_;
60
61 # first_party indicates whether there is a DKIM signature with
62 # an i= tag matching the address in the From: header
63 my $first_party;
64
65 #FIXME - if there are multiple verified signatures, each one
66 # should be checked
67
68 foreach my $signature ( $dkim->signatures ) {
69
70 # only valid/verified signatures are considered
71 next unless ( $signature->result && $signature->result eq 'pass' );
72
73 my $oa = $dkim->message_originator->address;
74 if ( $signature->identity_matches($oa) ) {
75
76 # found a first party signature
77 $first_party = 1;
78 last;
79 }
80 }
81
82 #TODO - consider testing flag
83
84 return 'accept' if $first_party;
85 return 'reject' if ( $self->signall_strict && !$self->testing );
86
87 if ( $self->signall ) {
88
89 # is there ANY valid signature?
90 my $verify_result = $dkim->result;
91 return 'accept' if $verify_result eq 'pass';
92 }
93
94 return 'reject' if ( $self->signall && !$self->testing );
95 return 'neutral';
96}
97
98
99sub flags {
100 my $self = shift;
101
102 (@_)
103 and $self->{tags}->{t} = shift;
104
105 $self->{tags}->{t};
106}
107
108
109sub is_implied_default_policy {
110 my $self = shift;
111 my $default_policy = ref($self)->default;
112 return ( $self == $default_policy );
113}
114
115
116sub location {
117 my $self = shift;
118 return $self->{Domain};
119}
120
121sub name {
122 return 'author';
123}
124
125
126sub policy {
127 my $self = shift;
128
129 (@_)
130 and $self->{tags}->{dkim} = shift;
131
132 if ( defined $self->{tags}->{dkim} ) {
133 return $self->{tags}->{dkim};
134 }
135 elsif ( defined $self->{tags}->{o} ) {
136 return $self->{tags}->{o};
137 }
138 else {
139 return 'unknown';
140 }
141}
142
143
144sub signall {
145 my $self = shift;
146
147 return $self->policy
148 && ( $self->policy =~ /all/i
149 || $self->policy eq '-' ); # an older symbol for "all"
150}
151
152
153sub signall_strict {
154 my $self = shift;
155
156 return $self->policy
157 && ( $self->policy =~ /strict/i
158 || $self->policy eq '!' ); # "!" is an older symbol for "strict"
159}
160
161sub signsome {
162 my $self = shift;
163
164 $self->policy
165 or return 1;
166
167 $self->policy eq '~'
168 and return 1;
169
170 return;
171}
172
173
174sub testing {
175 my $self = shift;
176 my $t = $self->flags;
177 ( $t && $t =~ /y/i )
178 and return 1;
179 return;
180}
181
1821;
183
184__END__