File Coverage

blib/lib/Mail/DKIM/DkPolicy.pm
Criterion Covered Total %
statement 41 63 65.0
branch 11 28 39.2
condition 4 21 19.0
subroutine 12 16 75.0
pod 10 12 83.3
total 78 140 55.7


line stmt bran cond sub pod time code
1             package Mail::DKIM::DkPolicy;
2 6     6   98406 use strict;
  6         20  
  6         172  
3 6     6   29 use warnings;
  6         10  
  6         304  
4             our $VERSION = '1.20230212'; # VERSION
5             # ABSTRACT: represents a DomainKeys Sender Signing Policy record
6              
7             # Copyright 2005-2009 Messiah College.
8             # Jason Long
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              
14 6     6   41 use base 'Mail::DKIM::Policy';
  6         20  
  6         966  
15 6     6   92 use Mail::DKIM::DNS;
  6         28  
  6         4980  
16              
17              
18             # get_lookup_name() - determine name of record to fetch
19             #
20             sub get_lookup_name {
21 1     1 0 3 my $self = shift;
22 1         2 my ($prms) = @_;
23              
24             # in DomainKeys, the record to fetch is determined based on the
25             # Sender header, then the From header
26              
27 1 50 33     5 if ( $prms->{Author} && !$prms->{Sender} ) {
28 0         0 $prms->{Sender} = $prms->{Author};
29             }
30 1 50 33     6 if ( $prms->{Sender} && !$prms->{Domain} ) {
31              
32             # pick domain from email address
33 0   0     0 $prms->{Domain} = ( $prms->{Sender} =~ /\@([^@]*)$/ and $1 );
34             }
35              
36 1 50       3 unless ( $prms->{Domain} ) {
37 0         0 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 1         4 return '_domainkey.' . $prms->{Domain};
46             }
47              
48              
49             sub new {
50 2     2 1 12 my $class = shift;
51 2         12 return $class->parse( String => 'o=~' );
52             }
53              
54              
55             #undocumented private class method
56             our $DEFAULT_POLICY;
57              
58             sub default {
59 1     1 1 4 my $class = shift;
60 1   33     10 $DEFAULT_POLICY ||= $class->new;
61 1         3 return $DEFAULT_POLICY;
62             }
63              
64              
65             sub apply {
66 0     0 1 0 my $self = shift;
67 0         0 my ($dkim) = @_;
68              
69 0         0 my $first_party;
70 0         0 foreach my $signature ( $dkim->signatures ) {
71 0 0       0 next if $signature->result ne 'pass';
72              
73 0         0 my $oa = $dkim->message_sender->address;
74 0 0       0 if ( $signature->identity_matches($oa) ) {
75              
76             # found a first party signature
77 0         0 $first_party = 1;
78 0         0 last;
79             }
80             }
81              
82 0 0       0 return 'accept' if $first_party;
83 0 0 0     0 return 'reject' if ( $self->signall && !$self->testing );
84 0         0 return 'neutral';
85             }
86              
87              
88             sub flags {
89 1     1 1 4 my $self = shift;
90              
91             (@_)
92 1 50       7 and $self->{tags}->{t} = shift;
93              
94 1         4 $self->{tags}->{t};
95             }
96              
97              
98             sub is_implied_default_policy {
99 1     1 1 685 my $self = shift;
100 1         18 my $default_policy = ref($self)->default;
101 1         8 return ( $self == $default_policy );
102             }
103              
104              
105             sub name {
106 0     0 1 0 return 'sender';
107             }
108              
109              
110             sub note {
111 3     3 1 406 my $self = shift;
112              
113             (@_)
114 3 100       14 and $self->{tags}->{n} = shift;
115              
116 3         21 $self->{tags}->{n};
117             }
118              
119              
120             sub policy {
121 3     3 1 9 my $self = shift;
122              
123             (@_)
124 3 100       14 and $self->{tags}->{o} = shift;
125              
126 3 100       12 if ( defined $self->{tags}->{o} ) {
127 2         10 return $self->{tags}->{o};
128             }
129             else {
130 1         8 return '~'; # the default
131             }
132             }
133              
134              
135             sub signall {
136 0     0 1 0 my $self = shift;
137 0   0     0 return ( $self->policy && $self->policy eq '-' );
138             }
139              
140             sub signsome {
141 0     0 0 0 my $self = shift;
142              
143 0 0       0 $self->policy
144             or return 1;
145              
146 0 0       0 $self->policy eq '~'
147             and return 1;
148              
149 0         0 return;
150             }
151              
152              
153             sub testing {
154 1     1 1 5 my $self = shift;
155 1         7 my $t = $self->flags;
156 1 50 33     19 ( $t && $t =~ /y/i )
157             and return 1;
158 1         8 return;
159             }
160              
161             1;
162              
163             __END__