← 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/DkPolicy.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sMail::DKIM::DkPolicy::::BEGIN@14Mail::DKIM::DkPolicy::BEGIN@14
0000s0sMail::DKIM::DkPolicy::::BEGIN@15Mail::DKIM::DkPolicy::BEGIN@15
0000s0sMail::DKIM::DkPolicy::::BEGIN@2Mail::DKIM::DkPolicy::BEGIN@2
0000s0sMail::DKIM::DkPolicy::::BEGIN@3Mail::DKIM::DkPolicy::BEGIN@3
0000s0sMail::DKIM::DkPolicy::::__ANON__Mail::DKIM::DkPolicy::__ANON__ (xsub)
0000s0sMail::DKIM::DkPolicy::::applyMail::DKIM::DkPolicy::apply
0000s0sMail::DKIM::DkPolicy::::defaultMail::DKIM::DkPolicy::default
0000s0sMail::DKIM::DkPolicy::::flagsMail::DKIM::DkPolicy::flags
0000s0sMail::DKIM::DkPolicy::::get_lookup_nameMail::DKIM::DkPolicy::get_lookup_name
0000s0sMail::DKIM::DkPolicy::::is_implied_default_policyMail::DKIM::DkPolicy::is_implied_default_policy
0000s0sMail::DKIM::DkPolicy::::nameMail::DKIM::DkPolicy::name
0000s0sMail::DKIM::DkPolicy::::newMail::DKIM::DkPolicy::new
0000s0sMail::DKIM::DkPolicy::::noteMail::DKIM::DkPolicy::note
0000s0sMail::DKIM::DkPolicy::::policyMail::DKIM::DkPolicy::policy
0000s0sMail::DKIM::DkPolicy::::signallMail::DKIM::DkPolicy::signall
0000s0sMail::DKIM::DkPolicy::::signsomeMail::DKIM::DkPolicy::signsome
0000s0sMail::DKIM::DkPolicy::::testingMail::DKIM::DkPolicy::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::DkPolicy;
2use strict;
3use warnings;
4our $VERSION = '1.20200907'; # VERSION
5# ABSTRACT: represents a DomainKeys Sender Signing Policy 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';
15use Mail::DKIM::DNS;
16
17
18# get_lookup_name() - determine name of record to fetch
19#
20sub get_lookup_name {
21 my $self = shift;
22 my ($prms) = @_;
23
24 # in DomainKeys, the record to fetch is determined based on the
25 # Sender header, then the From header
26
27 if ( $prms->{Author} && !$prms->{Sender} ) {
28 $prms->{Sender} = $prms->{Author};
29 }
30 if ( $prms->{Sender} && !$prms->{Domain} ) {
31
32 # pick domain from email address
33 $prms->{Domain} = ( $prms->{Sender} =~ /\@([^@]*)$/ and $1 );
34 }
35
36 unless ( $prms->{Domain} ) {
37 die "no domain to fetch policy for\n";
38 }
39
40 # IETF seems poised to create policy records this way
41 #my $host = '_policy._domainkey.' . $prms{Domain};
42
43 # but Yahoo! policy records are still much more common
44 # see historic RFC4870, section 3.6
45 return '_domainkey.' . $prms->{Domain};
46}
47
48
49sub new {
50 my $class = shift;
51 return $class->parse( String => 'o=~' );
52}
53
54
55#undocumented private class method
56our $DEFAULT_POLICY;
57
58sub default {
59 my $class = shift;
60 $DEFAULT_POLICY ||= $class->new;
61 return $DEFAULT_POLICY;
62}
63
64
65sub apply {
66 my $self = shift;
67 my ($dkim) = @_;
68
69 my $first_party;
70 foreach my $signature ( $dkim->signatures ) {
71 next if $signature->result ne 'pass';
72
73 my $oa = $dkim->message_sender->address;
74 if ( $signature->identity_matches($oa) ) {
75
76 # found a first party signature
77 $first_party = 1;
78 last;
79 }
80 }
81
82 return 'accept' if $first_party;
83 return 'reject' if ( $self->signall && !$self->testing );
84 return 'neutral';
85}
86
87
88sub flags {
89 my $self = shift;
90
91 (@_)
92 and $self->{tags}->{t} = shift;
93
94 $self->{tags}->{t};
95}
96
97
98sub is_implied_default_policy {
99 my $self = shift;
100 my $default_policy = ref($self)->default;
101 return ( $self == $default_policy );
102}
103
104
105sub name {
106 return 'sender';
107}
108
109
110sub note {
111 my $self = shift;
112
113 (@_)
114 and $self->{tags}->{n} = shift;
115
116 $self->{tags}->{n};
117}
118
119
120sub policy {
121 my $self = shift;
122
123 (@_)
124 and $self->{tags}->{o} = shift;
125
126 if ( defined $self->{tags}->{o} ) {
127 return $self->{tags}->{o};
128 }
129 else {
130 return '~'; # the default
131 }
132}
133
134
135sub signall {
136 my $self = shift;
137 return ( $self->policy && $self->policy eq '-' );
138}
139
140sub signsome {
141 my $self = shift;
142
143 $self->policy
144 or return 1;
145
146 $self->policy eq '~'
147 and return 1;
148
149 return;
150}
151
152
153sub testing {
154 my $self = shift;
155 my $t = $self->flags;
156 ( $t && $t =~ /y/i )
157 and return 1;
158 return;
159}
160
1611;
162
163__END__