File Coverage

blib/lib/Mail/DKIM/Canonicalization/DkCommon.pm
Criterion Covered Total %
statement 58 61 95.0
branch 6 10 60.0
condition 4 4 100.0
subroutine 9 10 90.0
pod 2 6 33.3
total 79 91 86.8


line stmt bran cond sub pod time code
1             package Mail::DKIM::Canonicalization::DkCommon;
2 7     7   57 use strict;
  7         16  
  7         210  
3 7     7   38 use warnings;
  7         23  
  7         281  
4             our $VERSION = '1.20230212'; # VERSION
5             # ABSTRACT: dk common canonicalization
6              
7             # Copyright 2005-2006 Messiah College. All rights reserved.
8             # Jason Long
9              
10             # This program is free software; you can redistribute it and/or
11             # modify it under the same terms as Perl itself.
12              
13 7     7   41 use base 'Mail::DKIM::Canonicalization::Base';
  7         15  
  7         733  
14 7     7   51 use Carp;
  7         13  
  7         4628  
15              
16             sub init {
17 21     21 0 36 my $self = shift;
18 21         71 $self->SUPER::init;
19              
20 21         49 $self->{header_count} = 0;
21             }
22              
23             # similar to code in DkimCommon.pm
24             sub add_header {
25              
26             #Note: canonicalization of headers is performed
27             #in finish_header()
28              
29 140     140 0 228 my $self = shift;
30 140         320 $self->{header_count}++;
31             }
32              
33             sub finish_header {
34 21     21 1 41 my $self = shift;
35 21         53 my %args = @_;
36              
37             # RFC4870, 3.3:
38             # h = A colon-separated list of header field names that identify the
39             # headers presented to the signing algorithm. If present, the
40             # value MUST contain the complete list of headers in the order
41             # presented to the signing algorithm.
42             #
43             # In the presence of duplicate headers, a signer may include
44             # duplicate entries in the list of headers in this tag. If a
45             # header is included in this list, a verifier must include all
46             # occurrences of that header, subsequent to the "DomainKey-
47             # Signature:" header in the verification.
48             #
49             # RFC4870, 3.4.2.1:
50             # * Each line of the email is presented to the signing algorithm in
51             # the order it occurs in the complete email, from the first line of
52             # the headers to the last line of the body.
53             # * If the "h" tag is used, only those header lines (and their
54             # continuation lines if any) added to the "h" tag list are included.
55              
56             # only consider headers AFTER my signature
57 21         34 my @sig_headers;
58             {
59 21         34 my $s0 = @{ $args{Headers} } - $self->{header_count};
  21         30  
  21         48  
60 21         36 my $s1 = @{ $args{Headers} } - 1;
  21         49  
61 21         55 @sig_headers = ( @{ $args{Headers} } )[ $s0 .. $s1 ];
  21         78  
62             }
63              
64             # check if signature specifies a list of headers
65 21         79 my @sig_header_names = $self->{Signature}->headerlist;
66 21 100       98 if (@sig_header_names) {
67              
68             # - first, group all header fields with the same name together
69             # (using a hash of arrays)
70 17         39 my %heads;
71 17         35 foreach my $line (@sig_headers) {
72 123 50       455 next unless $line =~ /^([^\s:]+)\s*:/;
73 123         260 my $field_name = lc $1;
74              
75 123   100     580 $heads{$field_name} ||= [];
76 123         182 push @{ $heads{$field_name} }, $line;
  123         304  
77             }
78              
79             # - second, count how many times each header field name appears
80             # in the h= tag
81 17         37 my %counts;
82 17         36 foreach my $field_name (@sig_header_names) {
83 106   100     225 $heads{ lc $field_name } ||= [];
84 106         191 $counts{ lc $field_name }++;
85             }
86              
87             # - finally, working backwards through the h= tag,
88             # collect the headers we will be signing (last to first).
89             # Normally, one occurrence of a name in the h= tag
90             # correlates to one occurrence of that header being presented
91             # to canonicalization, but if (working backwards) we are
92             # at the first occurrence of that name, and there are
93             # multiple headers of that name, then put them all in.
94             #
95 17         42 @sig_headers = ();
96 17         53 while ( my $field_name = pop @sig_header_names ) {
97 106         170 $counts{ lc $field_name }--;
98 106 50       221 if ( $counts{ lc $field_name } > 0 ) {
99              
100             # this field is named more than once in the h= tag,
101             # so only take the last occuring of that header
102 0         0 my $line = pop @{ $heads{ lc $field_name } };
  0         0  
103 0 0       0 unshift @sig_headers, $line if defined $line;
104             }
105             else {
106 106         158 unshift @sig_headers, @{ $heads{ lc $field_name } };
  106         230  
107 106         347 $heads{ lc $field_name } = [];
108             }
109             }
110             }
111              
112             # iterate through each header, in the order determined above
113 21         51 foreach my $line (@sig_headers) {
114 123 100       413 if ( $line =~ /^(from|sender)\s*:(.*)$/i ) {
115 25         60 my $field = $1;
116 25         64 my $content = $2;
117 25         105 $self->{interesting_header}->{ lc $field } = $content;
118             }
119 123         424 $line =~ s/\015\012\z//s;
120 123         425 $self->output( $self->canonicalize_header( $line . "\015\012" ) );
121             }
122              
123 21         68 $self->output( $self->canonicalize_body("\015\012") );
124             }
125              
126             sub add_body {
127 21     21 1 38 my $self = shift;
128 21         60 my ($multiline) = @_;
129              
130 21         66 $self->output( $self->canonicalize_body($multiline) );
131             }
132              
133       21 0   sub finish_body {
134             }
135              
136       0 0   sub finish_message {
137             }
138              
139             1;
140              
141             __END__