← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:14 2021

Filename/usr/local/lib/perl5/site_perl/Mail/DKIM/Signer.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sMail::DKIM::Signer::::BEGIN@14Mail::DKIM::Signer::BEGIN@14
0000s0sMail::DKIM::Signer::::BEGIN@15Mail::DKIM::Signer::BEGIN@15
0000s0sMail::DKIM::Signer::::BEGIN@18Mail::DKIM::Signer::BEGIN@18
0000s0sMail::DKIM::Signer::::BEGIN@19Mail::DKIM::Signer::BEGIN@19
0000s0sMail::DKIM::Signer::::BEGIN@2Mail::DKIM::Signer::BEGIN@2
0000s0sMail::DKIM::Signer::::BEGIN@3Mail::DKIM::Signer::BEGIN@3
0000s0sMail::DKIM::Signer::::__ANON__Mail::DKIM::Signer::__ANON__ (xsub)
0000s0sMail::DKIM::Signer::::add_signatureMail::DKIM::Signer::add_signature
0000s0sMail::DKIM::Signer::::algorithmMail::DKIM::Signer::algorithm
0000s0sMail::DKIM::Signer::::domainMail::DKIM::Signer::domain
0000s0sMail::DKIM::Signer::::extended_headersMail::DKIM::Signer::extended_headers
0000s0sMail::DKIM::Signer::::finish_bodyMail::DKIM::Signer::finish_body
0000s0sMail::DKIM::Signer::::finish_headerMail::DKIM::Signer::finish_header
0000s0sMail::DKIM::Signer::::headersMail::DKIM::Signer::headers
0000s0sMail::DKIM::Signer::::initMail::DKIM::Signer::init
0000s0sMail::DKIM::Signer::::keyMail::DKIM::Signer::key
0000s0sMail::DKIM::Signer::::key_fileMail::DKIM::Signer::key_file
0000s0sMail::DKIM::Signer::::methodMail::DKIM::Signer::method
0000s0sMail::DKIM::Signer::::process_headers_hashMail::DKIM::Signer::process_headers_hash
0000s0sMail::DKIM::Signer::::selectorMail::DKIM::Signer::selector
0000s0sMail::DKIM::Signer::::signaturesMail::DKIM::Signer::signatures
0000s0sMail::DKIM::Signer::::want_headerMail::DKIM::Signer::want_header
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package Mail::DKIM::Signer;
2use strict;
3use warnings;
4our $VERSION = '1.20200907'; # VERSION
5# ABSTRACT: generates a DKIM signature for a message
6
7# Copyright 2005-2007 Messiah College. All rights reserved.
8# Jason Long <jlong@messiah.edu>
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
14use Mail::DKIM::PrivateKey;
15use Mail::DKIM::Signature;
16
17
18use base 'Mail::DKIM::Common';
19use Carp;
20
21# PROPERTIES
22#
23# public:
24#
25# $dkim->{Algorithm}
26# identifies what algorithm to use when signing the message
27# default is "rsa-sha1"
28#
29# $dkim->{Domain}
30# identifies what domain the message is signed for
31#
32# $dkim->{KeyFile}
33# name of the file containing the private key used to sign
34#
35# $dkim->{Method}
36# identifies what canonicalization method to use when signing
37# the message. default is "relaxed"
38#
39# $dkim->{Policy}
40# a signing policy (of type Mail::DKIM::SigningPolicy)
41#
42# $dkim->{Selector}
43# identifies name of the selector identifying the key
44#
45# $dkim->{Key}
46# the loaded private key
47#
48# private:
49#
50# $dkim->{algorithms} = []
51# an array of algorithm objects... an algorithm object is created for
52# each signature being added to the message
53#
54# $dkim->{result}
55# result of the signing policy: "signed" or "skipped"
56#
57# $dkim->{signature}
58# the created signature (of type Mail::DKIM::Signature)
59
60sub init {
61 my $self = shift;
62 $self->SUPER::init;
63
64 if ( defined $self->{KeyFile} ) {
65 $self->{Key} ||=
66 Mail::DKIM::PrivateKey->load( File => $self->{KeyFile} );
67 }
68
69 unless ( $self->{'Algorithm'} ) {
70
71 # use default algorithm
72 $self->{'Algorithm'} = 'rsa-sha1';
73 }
74 unless ( $self->{'Method'} ) {
75
76 # use default canonicalization method
77 $self->{'Method'} = 'relaxed';
78 }
79 unless ( $self->{'Domain'} ) {
80
81 # use default domain
82 $self->{'Domain'} = 'example.org';
83 }
84 unless ( $self->{'Selector'} ) {
85
86 # use default selector
87 $self->{'Selector'} = 'unknown';
88 }
89}
90
91sub finish_header {
92 my $self = shift;
93
94 $self->{algorithms} = [];
95
96 my $policy = $self->{Policy};
97 if ( UNIVERSAL::isa( $policy, 'CODE' ) ) {
98
99 # policy is a subroutine ref
100 my $default_sig = $policy->($self);
101 unless ( @{ $self->{algorithms} } || $default_sig ) {
102 $self->{'result'} = 'skipped';
103 return;
104 }
105 }
106 elsif ( $policy && $policy->can('apply') ) {
107
108 # policy is a Perl object or class
109 my $default_sig = $policy->apply($self);
110 unless ( @{ $self->{algorithms} } || $default_sig ) {
111 $self->{'result'} = 'skipped';
112 return;
113 }
114 }
115
116 unless ( @{ $self->{algorithms} } ) {
117
118 # no algorithms were created yet, so construct a signature
119 # using the current signature properties
120
121 # check properties
122 unless ( $self->{'Algorithm'} ) {
123 die 'invalid algorithm property';
124 }
125 unless ( $self->{'Method'} ) {
126 die 'invalid method property';
127 }
128 unless ( $self->{'Domain'} ) {
129 die 'invalid header property';
130 }
131 unless ( $self->{'Selector'} ) {
132 die 'invalid selector property';
133 }
134
135 $self->add_signature(
136 Mail::DKIM::Signature->new(
137 Algorithm => $self->{'Algorithm'},
138 Method => $self->{'Method'},
139 Headers => $self->headers,
140 Domain => $self->{'Domain'},
141 Selector => $self->{'Selector'},
142 Key => $self->{'Key'},
143 KeyFile => $self->{'KeyFile'},
144 (
145 $self->{'Identity'} ? ( Identity => $self->{'Identity'} )
146 : ()
147 ),
148 (
149 $self->{'Timestamp'} ? ( Timestamp => $self->{'Timestamp'} )
150 : ()
151 ),
152 )
153 );
154 }
155
156 foreach my $algorithm ( @{ $self->{algorithms} } ) {
157
158 # output header as received so far into canonicalization
159 foreach my $header ( @{ $self->{headers} } ) {
160 $algorithm->add_header($header);
161 }
162 $algorithm->finish_header( Headers => $self->{headers} );
163 }
164}
165
166sub finish_body {
167 my $self = shift;
168
169 foreach my $algorithm ( @{ $self->{algorithms} } ) {
170
171 # finished canonicalizing
172 $algorithm->finish_body;
173
174 # load the private key file if necessary
175 my $signature = $algorithm->signature;
176 my $key =
177 $signature->{Key}
178 || $signature->{KeyFile}
179 || $self->{Key}
180 || $self->{KeyFile};
181 if ( defined($key) && !ref($key) ) {
182 $key = Mail::DKIM::PrivateKey->load( File => $key );
183 }
184 $key
185 or die "no key available to sign with\n";
186
187 # compute signature value
188 my $signb64 = $algorithm->sign($key);
189 $signature->data($signb64);
190
191 # insert linebreaks in signature data, if desired
192 $signature->prettify_safe();
193
194 $self->{signature} = $signature;
195 $self->{result} = 'signed';
196 }
197}
198
199
200sub add_signature {
201 my $self = shift;
202 my $signature = shift;
203
204 # create a canonicalization filter and algorithm
205 my $algorithm_class =
206 $signature->get_algorithm_class( $signature->algorithm )
207 or die 'unsupported algorithm ' . ( $signature->algorithm || '' ) . "\n";
208 my $algorithm = $algorithm_class->new(
209 Signature => $signature,
210 Debug_Canonicalization => $self->{Debug_Canonicalization},
211 );
212 push @{ $self->{algorithms} }, $algorithm;
213 return;
214}
215
216
217sub algorithm {
218 my $self = shift;
219 if ( @_ == 1 ) {
220 $self->{Algorithm} = shift;
221 }
222 return $self->{Algorithm};
223}
224
225
226sub domain {
227 my $self = shift;
228 if ( @_ == 1 ) {
229 $self->{Domain} = shift;
230 }
231 return $self->{Domain};
232}
233
- -
236# these are headers that "should" be included in the signature,
237# according to the DKIM spec.
238my @DEFAULT_HEADERS = qw(From Sender Reply-To Subject Date
239 Message-ID To Cc MIME-Version
240 Content-Type Content-Transfer-Encoding Content-ID Content-Description
241 Resent-Date Resent-From Resent-Sender Resent-To Resent-cc
242 Resent-Message-ID
243 In-Reply-To References
244 List-Id List-Help List-Unsubscribe List-Subscribe
245 List-Post List-Owner List-Archive);
246
247sub process_headers_hash {
248 my $self = shift;
249
250 my @headers;
251
252 # these are the header fields we found in the message we're signing
253 my @found_headers = @{ $self->{header_field_names} };
254
255 # Convert all keys to lower case
256 foreach my $header ( keys %{ $self->{'ExtendedHeaders'} } ) {
257 next if $header eq lc $header;
258 if ( exists $self->{'ExtendedHeaders'}->{ lc $header } ) {
259
260 # Merge
261 my $first = $self->{'ExtendedHeaders'}->{ lc $header };
262 my $second = $self->{'ExtendedHeaders'}->{$header};
263 if ( $first eq '+' || $second eq '+' ) {
264 $self->{'ExtendedHeaders'}->{ lc $header } = '+';
265 }
266 elsif ( $first eq '*' || $second eq '*' ) {
267 $self->{'ExtendedHeaders'}->{ lc $header } = '*';
268 }
269 else {
270 $self->{'ExtendedHeaders'}->{ lc $header } = $first + $second;
271 }
272 }
273 else {
274 # Rename
275 $self->{'ExtendedHeaders'}->{ lc $header } =
276 $self->{'ExtendedHeaders'}->{$header};
277 }
278 delete $self->{'ExtendedHeaders'}->{$header};
279 }
280
281 # Add the default headers
282 foreach my $default (@DEFAULT_HEADERS) {
283 if ( !exists $self->{'ExtendedHeaders'}->{ lc $default } ) {
284 $self->{'ExtendedHeaders'}->{ lc $default } = '*';
285 }
286 }
287
288 # Build a count of found headers
289 my $header_counts = {};
290 foreach my $header (@found_headers) {
291 if ( !exists $header_counts->{ lc $header } ) {
292 $header_counts->{ lc $header } = 1;
293 }
294 else {
295 $header_counts->{ lc $header } = $header_counts->{ lc $header } + 1;
296 }
297 }
298
299 foreach my $header ( sort keys %{ $self->{'ExtendedHeaders'} } ) {
300 my $want_count = $self->{'ExtendedHeaders'}->{$header};
301 my $have_count = $header_counts->{ lc $header } || 0;
302 my $add_count = 0;
303 if ( $want_count eq '+' ) {
304 $add_count = $have_count + 1;
305 }
306 elsif ( $want_count eq '*' ) {
307 $add_count = $have_count;
308 }
309 else {
310 if ( $want_count > $have_count ) {
311 $add_count = $have_count;
312 }
313 else {
314 $add_count = $want_count;
315 }
316 }
317 for ( 1 .. $add_count ) {
318 push @headers, $header;
319 }
320 }
321 return join( ':', @headers );
322}
323
324sub extended_headers {
325 my $self = shift;
326 $self->{'ExtendedHeaders'} = shift;
327 return;
328}
329
330sub headers {
331 my $self = shift;
332 croak 'unexpected argument' if @_;
333
334 if ( exists $self->{'ExtendedHeaders'} ) {
335 return $self->process_headers_hash();
336 }
337
338 # these are the header fields we found in the message we're signing
339 my @found_headers = @{ $self->{header_field_names} };
340
341 # these are the headers we actually want to sign
342 my @wanted_headers = @DEFAULT_HEADERS;
343 if ( $self->{Headers} ) {
344 push @wanted_headers, split /:/, $self->{Headers};
345 }
346
347 my @headers =
348 grep {
349 my $a = $_;
350 scalar grep { lc($a) eq lc($_) } @wanted_headers
351 } @found_headers;
352 return join( ':', @headers );
353}
354
355# return nonzero if this is header we should sign
356sub want_header {
357 my $self = shift;
358 my ($header_name) = @_;
359
360 #TODO- provide a way for user to specify which headers to sign
361 return scalar grep { lc($_) eq lc($header_name) } @DEFAULT_HEADERS;
362}
363
364
365sub key {
366 my $self = shift;
367 if (@_) {
368 $self->{Key} = shift;
369 $self->{KeyFile} = undef;
370 }
371 return $self->{Key};
372}
373
374
375sub key_file {
376 my $self = shift;
377 if (@_) {
378 $self->{Key} = undef;
379 $self->{KeyFile} = shift;
380 }
381 return $self->{KeyFile};
382}
383
384
385sub method {
386 my $self = shift;
387 if ( @_ == 1 ) {
388 $self->{Method} = shift;
389 }
390 return $self->{Method};
391}
392
- -
395sub selector {
396 my $self = shift;
397 if ( @_ == 1 ) {
398 $self->{Selector} = shift;
399 }
400 return $self->{Selector};
401}
402
403
404sub signatures {
405 my $self = shift;
406 croak 'no arguments allowed' if @_;
407 return map { $_->signature } @{ $self->{algorithms} };
408}
409
410
4111;
412
413__END__