File Coverage

blib/lib/Mail/DKIM/Policy.pm
Criterion Covered Total %
statement 50 71 70.4
branch 7 22 31.8
condition 1 5 20.0
subroutine 9 12 75.0
pod 4 7 57.1
total 71 117 60.6


line stmt bran cond sub pod time code
1             package Mail::DKIM::Policy;
2 6     6   51 use strict;
  6         17  
  6         220  
3 6     6   40 use warnings;
  6         13  
  6         276  
4             our $VERSION = '1.20230911'; # VERSION
5             # ABSTRACT: abstract base class for originator "signing" policies
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   475 use Mail::DKIM::DNS;
  6         16  
  6         5269  
15              
16              
17             sub fetch {
18 1     1 0 277 my $class = shift;
19 1         7 my $waiter = $class->fetch_async(@_);
20 1         3 return $waiter->();
21             }
22              
23             sub fetch_async {
24 1     1 0 3 my $class = shift;
25 1         4 my %prms = @_;
26              
27 1 50       6 ( $prms{'Protocol'} eq 'dns' )
28             or die "invalid protocol '$prms{Protocol}'\n";
29              
30 1         5 my $host = $class->get_lookup_name( \%prms );
31 1 50       2 my %callbacks = %{ $prms{Callbacks} || {} };
  1         9  
32 1   50 1   8 my $on_success = $callbacks{Success} || sub { $_[0] };
  1         80  
33             $callbacks{Success} = sub {
34 1     1   5 my @resp = @_;
35 1 50       6 unless (@resp) {
36              
37             # no requested resource records or NXDOMAIN,
38             # use default policy
39 0         0 return $on_success->( $class->default );
40             }
41              
42 1         4 my $strn;
43 1         5 foreach my $rr (@resp) {
44 1 50       6 next unless $rr->type eq 'TXT';
45              
46             # join with no intervening spaces, RFC 5617
47 1 50       47 if ( Net::DNS->VERSION >= 0.69 ) {
48              
49             # must call txtdata() in a list context
50 1         8 $strn = join '', $rr->txtdata;
51             }
52             else {
53             # char_str_list method is 'historical'
54 0         0 $strn = join '', $rr->char_str_list;
55             }
56             }
57              
58 1 50       91 unless ($strn) {
59              
60             # empty record found in DNS, use default policy
61 0         0 return $on_success->( $class->default );
62             }
63              
64             my $self = $class->parse(
65             String => $strn,
66             Domain => $prms{Domain},
67 1         16 );
68 1         8 return $on_success->($self);
69 1         5 };
70              
71             #
72             # perform DNS query for domain policy...
73             #
74 1         5 my $waiter =
75             Mail::DKIM::DNS::query_async( $host, 'TXT', Callbacks => \%callbacks, );
76 1         3 return $waiter;
77             }
78              
79             sub parse {
80 8     8 0 1225 my $class = shift;
81 8         44 my %prms = @_;
82              
83 8         24 my $text = $prms{'String'};
84 8         13 my %tags;
85 8         38 foreach my $tag ( split /;/, $text ) {
86              
87             # strip whitespace
88 9         62 $tag =~ s/^\s+|\s+$//g;
89              
90 9         34 my ( $tagname, $value ) = split /=/, $tag, 2;
91 9 50       33 unless ( defined $value ) {
92 0         0 die "policy syntax error\n";
93             }
94              
95 9         24 $tagname =~ s/\s+$//;
96 9         26 $value =~ s/^\s+//;
97 9         30 $tags{$tagname} = $value;
98             }
99              
100 8         25 $prms{tags} = \%tags;
101 8         51 return bless \%prms, $class;
102             }
103              
104              
105             sub apply {
106 0     0 1 0 my $self = shift;
107 0         0 my ($dkim) = @_;
108              
109 0         0 my $first_party;
110 0         0 foreach my $signature ( $dkim->signatures ) {
111 0 0       0 next if $signature->result ne 'pass';
112              
113 0         0 my $oa = $dkim->message_sender->address;
114 0 0       0 if ( $signature->identity_matches($oa) ) {
115              
116             # found a first party signature
117 0         0 $first_party = 1;
118 0         0 last;
119             }
120             }
121              
122 0 0       0 return 'accept' if $first_party;
123 0 0 0     0 return 'reject' if ( $self->signall && !$self->testing );
124 0         0 return 'neutral';
125             }
126              
127              
128             sub as_string {
129 1     1 1 4 my $self = shift;
130              
131             return join(
132 2         15 '; ', map { "$_=" . $self->{tags}->{$_} }
133 1         3 keys %{ $self->{tags} }
  1         6  
134             );
135             }
136              
137              
138             sub is_implied_default_policy {
139 0     0 1   my $self = shift;
140 0           my $default_policy = ref($self)->default;
141 0           return ( $self == $default_policy );
142             }
143              
144              
145             sub location {
146 0     0 1   my $self = shift;
147 0           return $self->{Domain};
148             }
149              
150              
151             1;
152              
153             __END__