File Coverage

blib/lib/Mail/DKIM/DkimPolicy.pm
Criterion Covered Total %
statement 12 67 17.9
branch 0 32 0.0
condition 0 27 0.0
subroutine 4 17 23.5
pod 10 13 76.9
total 26 156 16.6


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