← 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/Signature.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sMail::DKIM::Signature::::BEGIN@14Mail::DKIM::Signature::BEGIN@14
0000s0sMail::DKIM::Signature::::BEGIN@15Mail::DKIM::Signature::BEGIN@15
0000s0sMail::DKIM::Signature::::BEGIN@16Mail::DKIM::Signature::BEGIN@16
0000s0sMail::DKIM::Signature::::BEGIN@177Mail::DKIM::Signature::BEGIN@177
0000s0sMail::DKIM::Signature::::BEGIN@18Mail::DKIM::Signature::BEGIN@18
0000s0sMail::DKIM::Signature::::BEGIN@19Mail::DKIM::Signature::BEGIN@19
0000s0sMail::DKIM::Signature::::BEGIN@2Mail::DKIM::Signature::BEGIN@2
0000s0sMail::DKIM::Signature::::BEGIN@3Mail::DKIM::Signature::BEGIN@3
0000s0sMail::DKIM::Signature::::DEFAULT_PREFIXMail::DKIM::Signature::DEFAULT_PREFIX
0000s0sMail::DKIM::Signature::::__ANON__Mail::DKIM::Signature::__ANON__ (xsub)
0000s0sMail::DKIM::Signature::::__ANON__[:355]Mail::DKIM::Signature::__ANON__[:355]
0000s0sMail::DKIM::Signature::::__ANON__[:364]Mail::DKIM::Signature::__ANON__[:364]
0000s0sMail::DKIM::Signature::::_refetch_public_keyMail::DKIM::Signature::_refetch_public_key
0000s0sMail::DKIM::Signature::::algorithmMail::DKIM::Signature::algorithm
0000s0sMail::DKIM::Signature::::as_stringMail::DKIM::Signature::as_string
0000s0sMail::DKIM::Signature::::as_string_debugMail::DKIM::Signature::as_string_debug
0000s0sMail::DKIM::Signature::::as_string_without_dataMail::DKIM::Signature::as_string_without_data
0000s0sMail::DKIM::Signature::::body_countMail::DKIM::Signature::body_count
0000s0sMail::DKIM::Signature::::body_hashMail::DKIM::Signature::body_hash
0000s0sMail::DKIM::Signature::::canonicalizationMail::DKIM::Signature::canonicalization
0000s0sMail::DKIM::Signature::::check_canonicalizationMail::DKIM::Signature::check_canonicalization
0000s0sMail::DKIM::Signature::::check_expirationMail::DKIM::Signature::check_expiration
0000s0sMail::DKIM::Signature::::check_protocolMail::DKIM::Signature::check_protocol
0000s0sMail::DKIM::Signature::::check_versionMail::DKIM::Signature::check_version
0000s0sMail::DKIM::Signature::::dataMail::DKIM::Signature::data
0000s0sMail::DKIM::Signature::::decode_qpMail::DKIM::Signature::decode_qp
0000s0sMail::DKIM::Signature::::domainMail::DKIM::Signature::domain
0000s0sMail::DKIM::Signature::::encode_qpMail::DKIM::Signature::encode_qp
0000s0sMail::DKIM::Signature::::expirationMail::DKIM::Signature::expiration
0000s0sMail::DKIM::Signature::::fetch_public_keyMail::DKIM::Signature::fetch_public_key
0000s0sMail::DKIM::Signature::::get_algorithm_classMail::DKIM::Signature::get_algorithm_class
0000s0sMail::DKIM::Signature::::get_public_keyMail::DKIM::Signature::get_public_key
0000s0sMail::DKIM::Signature::::hash_algorithmMail::DKIM::Signature::hash_algorithm
0000s0sMail::DKIM::Signature::::headerlistMail::DKIM::Signature::headerlist
0000s0sMail::DKIM::Signature::::identityMail::DKIM::Signature::identity
0000s0sMail::DKIM::Signature::::identity_matchesMail::DKIM::Signature::identity_matches
0000s0sMail::DKIM::Signature::::keyMail::DKIM::Signature::key
0000s0sMail::DKIM::Signature::::methodMail::DKIM::Signature::method
0000s0sMail::DKIM::Signature::::newMail::DKIM::Signature::new
0000s0sMail::DKIM::Signature::::parseMail::DKIM::Signature::parse
0000s0sMail::DKIM::Signature::::prefixMail::DKIM::Signature::prefix
0000s0sMail::DKIM::Signature::::prettifyMail::DKIM::Signature::prettify
0000s0sMail::DKIM::Signature::::prettify_safeMail::DKIM::Signature::prettify_safe
0000s0sMail::DKIM::Signature::::protocolMail::DKIM::Signature::protocol
0000s0sMail::DKIM::Signature::::resultMail::DKIM::Signature::result
0000s0sMail::DKIM::Signature::::result_detailMail::DKIM::Signature::result_detail
0000s0sMail::DKIM::Signature::::selectorMail::DKIM::Signature::selector
0000s0sMail::DKIM::Signature::::timestampMail::DKIM::Signature::timestamp
0000s0sMail::DKIM::Signature::::versionMail::DKIM::Signature::version
0000s0sMail::DKIM::Signature::::wantheaderMail::DKIM::Signature::wantheader
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::Signature;
2use strict;
3use warnings;
4our $VERSION = '1.20200907'; # VERSION
5# ABSTRACT: represents a DKIM-Signature header
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::PublicKey;
15use Mail::DKIM::Algorithm::rsa_sha1;
16use Mail::DKIM::Algorithm::rsa_sha256;
17
18use base 'Mail::DKIM::KeyValueList';
19use Carp;
20
21
22sub new {
23 my $class = shift;
24 my %prms = @_;
25 my $self = {};
26 bless $self, $class;
27
28 $self->version('1');
29 $self->algorithm( $prms{'Algorithm'} || 'rsa-sha1' );
30 $self->signature( $prms{'Signature'} );
31 $self->canonicalization( $prms{'Method'} ) if exists $prms{'Method'};
32 $self->domain( $prms{'Domain'} );
33 $self->headerlist( $prms{'Headers'} );
34 $self->protocol( $prms{'Query'} ) if exists $prms{'Query'};
35 $self->selector( $prms{'Selector'} );
36 $self->identity( $prms{'Identity'} ) if exists $prms{'Identity'};
37 $self->timestamp( $prms{'Timestamp'} ) if defined $prms{'Timestamp'};
38 $self->expiration( $prms{'Expiration'} ) if defined $prms{'Expiration'};
39 $self->key( $prms{'Key'} ) if defined $prms{'Key'};
40
41 return $self;
42}
43
44
45sub parse {
46 my $class = shift;
47 croak 'wrong number of arguments' unless ( @_ == 1 );
48 my ($string) = @_;
49
50 # remove line terminator, if present
51 $string =~ s/\015\012\z//;
52
53 # remove field name, if present
54 my $prefix = $class->prefix();
55 if ( $string =~ s/^($prefix)//i ) {
56
57 # save the field name (capitalization), so that it can be
58 # restored later
59 $prefix = $1;
60 }
61
62 my $self = $class->SUPER::parse($string);
63 $self->{prefix} = $prefix;
64
65 return $self;
66}
67
68
69# deprecated
70sub wantheader {
71 my $self = shift;
72 my $attr = shift;
73
74 $self->headerlist
75 or return 1;
76
77 foreach my $key ( $self->headerlist ) {
78 lc $attr eq lc $key
79 and return 1;
80 }
81
82 return;
83}
84
85
86sub algorithm {
87 my $self = shift;
88
89 if (@_) {
90 $self->set_tag( 'a', shift );
91 }
92
93 my $a = $self->get_tag('a');
94 return defined $a ? lc $a : undef;
95}
96
97
98sub as_string {
99 my $self = shift;
100
101 return $self->prefix() . $self->SUPER::as_string;
102}
103
104# undocumented method
105sub as_string_debug {
106 my $self = shift;
107
108 return $self->prefix()
109 . join( ';', map { '>' . $_->{raw} . '<' } @{ $self->{tags} } );
110}
111
112
113sub as_string_without_data {
114 my $self = shift;
115 croak 'wrong number of arguments' unless ( @_ == 0 );
116
117 my $alt = $self->clone;
118 $alt->signature('');
119
120 return $alt->as_string;
121}
122
123
124sub body_count {
125 my $self = shift;
126
127 # set new body count if provided
128 (@_)
129 and $self->set_tag( 'l', shift );
130
131 return $self->get_tag('l');
132}
133
134
135sub body_hash {
136 my $self = shift;
137
138 # set new body hash if provided
139 (@_)
140 and $self->set_tag( 'bh', shift );
141
142 my $result = $self->get_tag('bh');
143 if ( defined $result ) {
144 $result =~ s/\s+//gs;
145 }
146 return $result;
147}
148
149
150sub canonicalization {
151 my $self = shift;
152
153 if (@_) {
154 $self->set_tag( 'c', join( '/', @_ ) );
155 }
156
157 my $c = $self->get_tag('c');
158 $c = lc $c if defined $c;
159 if ( not $c ) {
160 $c = 'simple/simple';
161 }
162 my ( $c1, $c2 ) = split( /\//, $c, 2 );
163 if ( not defined $c2 ) {
164
165 # default body canonicalization is "simple"
166 $c2 = 'simple';
167 }
168
169 if (wantarray) {
170 return ( $c1, $c2 );
171 }
172 else {
173 return "$c1/$c2";
174 }
175}
176
177use MIME::Base64;
178
179# checks whether this signature specifies a legal canonicalization method
180# returns true if the canonicalization is acceptable, false otherwise
181#
182sub check_canonicalization {
183 my $self = shift;
184
185 my ( $c1, $c2 ) = $self->canonicalization;
186
187 my @known = ( 'nowsp', 'simple', 'relaxed', 'seal' );
188 return undef unless ( grep { $_ eq $c1 } @known );
189 return undef unless ( grep { $_ eq $c2 } @known );
190 return 1;
191}
192
193# checks whether the expiration time on this signature is acceptable
194# returns a true value if acceptable, false otherwise
195#
196sub check_expiration {
197 my $self = shift;
198 my $x = $self->expiration;
199 return 1 if not defined $x;
200
201 $self->{_verify_time} ||= time();
202 return ( $self->{_verify_time} <= $x );
203}
204
205# Returns a filtered list of protocols that can be used to fetch the
206# public key corresponding to this signature. An empty list means that
207# all designated protocols are unrecognized.
208# Note: at this time, the only recognized protocol is "dns/txt".
209#
210sub check_protocol {
211 my $self = shift;
212
213 my $v = $self->version;
214
215 foreach my $prot ( split /:/, $self->protocol ) {
216 my ( $type, $options ) = split( /\//, $prot, 2 );
217 if ( $type eq 'dns' ) {
218 return ('dns/txt') if $options && $options eq 'txt';
219
220 # prior to DKIM version 1, the '/txt' part was optional
221 if ( !$v ) {
222 return ('dns/txt') if !defined($options);
223 }
224 }
225 }
226
227 # unrecognized
228 return;
229}
230
231# checks whether the version tag has an acceptable value
232# returns true if so, otherwise false
233#
234sub check_version {
235 my $self = shift;
236
237 # check version
238 if ( my $version = $self->version ) {
239 my @ALLOWED_VERSIONS = ( '0.5', '1' );
240 return ( grep { $_ eq $version } @ALLOWED_VERSIONS );
241 }
242
243 # we still consider a missing v= tag acceptable,
244 # for backwards-compatibility
245 return 1;
246}
247
248
249sub data {
250 my $self = shift;
251
252 if (@_) {
253 $self->set_tag( 'b', shift );
254 }
255
256 my $b = $self->get_tag('b');
257 $b =~ tr/\015\012 \t//d if defined $b;
258 return $b;
259}
260
261*signature = \*data;
262
263#undocumented, private function
264#derived from MIME::Base64::Perl (allowed, thanks to the Perl license)
265#
266sub decode_qp {
267 my $res = shift;
268
269 #TODO- should I worry about non-ASCII systems here?
270 $res =~ s/=([\da-fA-F]{2})/pack('C', hex($1))/ge
271 if defined $res;
272 return $res;
273}
274
275#undocumented, private function
276#derived from MIME::Base64::Perl (allowed, thanks to the Perl license)
277#
278sub encode_qp {
279 my $res = shift;
280
281 # note- unlike MIME quoted-printable, we don't allow whitespace chars
282 my $DISALLOWED = qr/[^!"#\$%&'()*+,\-.\/0-9:;<>?\@A-Z[\\\]^_`a-z{|}~]/;
283
284 #TODO- should I worry about non-ASCII systems here?
285 $res =~ s/($DISALLOWED)/sprintf('=%02X', ord($1))/eg
286 if defined $res;
287 return $res;
288}
289
290sub DEFAULT_PREFIX {
291 return 'DKIM-Signature:';
292}
293
294sub prefix {
295 my $class = shift;
296 if ( ref($class) ) {
297 $class->{prefix} = shift if @_;
298 return $class->{prefix} if $class->{prefix};
299 }
300 return $class->DEFAULT_PREFIX();
301}
302
303
304sub domain {
305 my $self = shift;
306
307 if (@_) {
308 $self->set_tag( 'd', shift );
309 }
310
311 my $d = $self->get_tag('d');
312 return defined $d ? lc $d : undef;
313}
314
315
316sub expiration {
317 my $self = shift;
318
319 (@_)
320 and $self->set_tag( 'x', shift );
321
322 return $self->get_tag('x');
323}
324
325# allows the type of signature to determine what "algorithm" gets used
326sub get_algorithm_class {
327 my $self = shift;
328 croak 'wrong number of arguments' unless ( @_ == 1 );
329 my ($algorithm) = @_;
330
331 my $class =
332 $algorithm eq 'rsa-sha1' ? 'Mail::DKIM::Algorithm::rsa_sha1'
333 : $algorithm eq 'rsa-sha256' ? 'Mail::DKIM::Algorithm::rsa_sha256'
334 : undef;
335 return $class;
336}
337
338# [private method]
339# fetch_public_key() - initiate a DNS query for fetching the key
340#
341# This method does NOT return the public key.
342# Use get_public_key() for that.
343#
344sub fetch_public_key {
345 my $self = shift;
346 return if exists $self->{public_key_query};
347
348 my $on_success = sub {
349 if ( $_[0] ) {
350 $self->{public} = $_[0];
351 }
352 else {
353 $self->{public_error} = "not available\n";
354 }
355 };
356
357 my @methods = $self->check_protocol;
358 $self->{public_key_query} = Mail::DKIM::PublicKey->fetch_async(
359 Protocol => $methods[0],
360 Selector => $self->selector,
361 Domain => $self->domain,
362 Callbacks => {
363 Success => $on_success,
364 Error => sub { $self->{public_error} = shift },
365 },
366 );
367 return;
368}
369
370#EXPERIMENTAL
371sub _refetch_public_key {
372 my $self = shift;
373 if ( $self->{public_key_query} ) {
374
375 # clear the existing query by waiting for it to complete
376 $self->{public_key_query}->();
377 }
378 delete $self->{public_key_query};
379 delete $self->{public};
380 delete $self->{public_error};
381 $self->fetch_public_key;
382}
383
384
385sub get_public_key {
386 my $self = shift;
387
388 # this ensures we only try fetching once, even if an error occurs
389 if ( not exists $self->{public_key_query} ) {
390 $self->fetch_public_key;
391 }
392
393 if ( $self->{public_key_query} ) {
394
395 # wait for public key query to finish
396 $self->{public_key_query}->();
397 $self->{public_key_query} = 0;
398 }
399
400 if ( exists $self->{public} ) {
401 return $self->{public};
402 }
403 else {
404 die $self->{public_error};
405 }
406}
407
408
409sub hash_algorithm {
410 my $self = shift;
411 my $algorithm = $self->algorithm;
412
413 return
414 $algorithm eq 'rsa-sha1' ? 'sha1'
415 : $algorithm eq 'rsa-sha256' ? 'sha256'
416 : undef;
417}
418
419
420sub headerlist {
421 my $self = shift;
422
423 (@_)
424 and $self->set_tag( 'h', shift );
425
426 my $h = $self->get_tag('h') || '';
427
428 # remove whitespace next to colons
429 $h =~ s/\s+:/:/g;
430 $h =~ s/:\s+/:/g;
431 $h = lc $h;
432
433 if ( wantarray and $h ) {
434 my @list = split /:/, $h;
435 @list = map { s/^\s+|\s+$//g; $_ } @list;
436 return @list;
437 }
438 elsif (wantarray) {
439 return ();
440 }
441
442 return $h;
443}
444
445
446sub identity {
447 my $self = shift;
448
449 # set new identity if provided
450 (@_)
451 and $self->set_tag( 'i', encode_qp(shift) );
452
453 my $i = $self->get_tag('i');
454 if ( defined $i ) {
455 return decode_qp($i);
456 }
457 else {
458 return '@' . ( $self->domain || '' );
459 }
460}
461
462sub identity_matches {
463 my $self = shift;
464 my ($addr) = @_;
465
466 my $id = $self->identity;
467 if ( $id =~ /^\@/ ) {
468
469 # the identity is a domain-name only, so it only needs to match
470 # the domain part of the sender address
471 return ( lc( substr( $addr, -length($id) ) ) eq lc($id) );
472
473 # TODO - compare the parent domains?
474 }
475 return lc($addr) eq lc($id);
476}
477
478
479sub key {
480 my $self = shift;
481 if (@_) {
482 $self->{Key} = shift;
483 $self->{KeyFile} = undef;
484 }
485 return $self->{Key};
486}
487
488
489sub method {
490 my $self = shift;
491
492 if (@_) {
493 $self->set_tag( 'c', shift );
494 }
495
496 return ( lc $self->get_tag('c') ) || 'simple';
497}
498
499
500sub protocol {
501 my $self = shift;
502
503 (@_)
504 and $self->set_tag( 'q', shift );
505
506 my $q = $self->get_tag('q');
507 if ( defined $q ) {
508 return $q;
509 }
510 else {
511 return 'dns/txt';
512 }
513}
514
515
516sub result {
517 my $self = shift;
518 @_ and $self->{verify_result} = shift;
519 @_ and $self->{verify_details} = shift;
520 return $self->{verify_result};
521}
522
523
524sub result_detail {
525 my $self = shift;
526 croak 'wrong number of arguments' unless ( @_ == 0 );
527
528 if ( $self->{verify_result} && $self->{verify_details} ) {
529 return $self->{verify_result} . ' (' . $self->{verify_details} . ')';
530 }
531 return $self->{verify_result};
532}
533
534
535sub selector {
536 my $self = shift;
537
538 (@_)
539 and $self->set_tag( 's', shift );
540
541 return $self->get_tag('s');
542}
543
544
545sub prettify {
546 my $self = shift;
547 $self->wrap(
548 Start => length( $self->prefix() ),
549 Tags => {
550 b => 'b64',
551 bh => 'b64',
552 h => 'list',
553 },
554 );
555}
556
557
558sub prettify_safe {
559 my $self = shift;
560 $self->wrap(
561 Start => length( $self->prefix() ),
562 Tags => {
563 b => 'b64',
564 },
565 PreserveNames => 1,
566 Default => 'preserve', #preserves unknown tags
567 );
568}
569
570
571sub timestamp {
572 my $self = shift;
573
574 (@_)
575 and $self->set_tag( 't', shift );
576
577 return $self->get_tag('t');
578}
579
580
581sub version {
582 my $self = shift;
583
584 (@_)
585 and $self->set_tag( 'v', shift );
586
587 return $self->get_tag('v');
588}
589
590
5911;
592
593__END__