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   56 use strict;
  7         16  
  7         234  
3 7     7   40 use warnings;
  7         13  
  7         276  
4             our $VERSION = '1.20230911'; # 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   37 use base 'Mail::DKIM::Canonicalization::Base';
  7         13  
  7         735  
14 7     7   51 use Carp;
  7         29  
  7         5042  
15              
16             sub init {
17 21     21 0 30 my $self = shift;
18 21         67 $self->SUPER::init;
19              
20 21         47 $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 200 my $self = shift;
30 140         314 $self->{header_count}++;
31             }
32              
33             sub finish_header {
34 21     21 1 38 my $self = shift;
35 21         51 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         49 my @sig_headers;
58             {
59 21         34 my $s0 = @{ $args{Headers} } - $self->{header_count};
  21         31  
  21         56  
60 21         31 my $s1 = @{ $args{Headers} } - 1;
  21         42  
61 21         64 @sig_headers = ( @{ $args{Headers} } )[ $s0 .. $s1 ];
  21         72  
62             }
63              
64             # check if signature specifies a list of headers
65 21         67 my @sig_header_names = $self->{Signature}->headerlist;
66 21 100       63 if (@sig_header_names) {
67              
68             # - first, group all header fields with the same name together
69             # (using a hash of arrays)
70 17         30 my %heads;
71 17         34 foreach my $line (@sig_headers) {
72 123 50       441 next unless $line =~ /^([^\s:]+)\s*:/;
73 123         259 my $field_name = lc $1;
74              
75 123   100     510 $heads{$field_name} ||= [];
76 123         175 push @{ $heads{$field_name} }, $line;
  123         297  
77             }
78              
79             # - second, count how many times each header field name appears
80             # in the h= tag
81 17         27 my %counts;
82 17         30 foreach my $field_name (@sig_header_names) {
83 106   100     222 $heads{ lc $field_name } ||= [];
84 106         189 $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         41 @sig_headers = ();
96 17         47 while ( my $field_name = pop @sig_header_names ) {
97 106         169 $counts{ lc $field_name }--;
98 106 50       207 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         147 unshift @sig_headers, @{ $heads{ lc $field_name } };
  106         244  
107 106         339 $heads{ lc $field_name } = [];
108             }
109             }
110             }
111              
112             # iterate through each header, in the order determined above
113 21         52 foreach my $line (@sig_headers) {
114 123 100       441 if ( $line =~ /^(from|sender)\s*:(.*)$/i ) {
115 25         60 my $field = $1;
116 25         54 my $content = $2;
117 25         101 $self->{interesting_header}->{ lc $field } = $content;
118             }
119 123         431 $line =~ s/\015\012\z//s;
120 123         438 $self->output( $self->canonicalize_header( $line . "\015\012" ) );
121             }
122              
123 21         69 $self->output( $self->canonicalize_body("\015\012") );
124             }
125              
126             sub add_body {
127 21     21 1 34 my $self = shift;
128 21         57 my ($multiline) = @_;
129              
130 21         59 $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__