← 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/Common.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sMail::DKIM::Common::::BEGIN@14Mail::DKIM::Common::BEGIN@14
0000s0sMail::DKIM::Common::::BEGIN@16Mail::DKIM::Common::BEGIN@16
0000s0sMail::DKIM::Common::::BEGIN@17Mail::DKIM::Common::BEGIN@17
0000s0sMail::DKIM::Common::::BEGIN@2Mail::DKIM::Common::BEGIN@2
0000s0sMail::DKIM::Common::::BEGIN@3Mail::DKIM::Common::BEGIN@3
0000s0sMail::DKIM::Common::::__ANON__Mail::DKIM::Common::__ANON__ (xsub)
0000s0sMail::DKIM::Common::::add_bodyMail::DKIM::Common::add_body
0000s0sMail::DKIM::Common::::add_headerMail::DKIM::Common::add_header
0000s0sMail::DKIM::Common::::handle_headerMail::DKIM::Common::handle_header
0000s0sMail::DKIM::Common::::initMail::DKIM::Common::init
0000s0sMail::DKIM::Common::::loadMail::DKIM::Common::load
0000s0sMail::DKIM::Common::::message_attributesMail::DKIM::Common::message_attributes
0000s0sMail::DKIM::Common::::message_idMail::DKIM::Common::message_id
0000s0sMail::DKIM::Common::::message_originatorMail::DKIM::Common::message_originator
0000s0sMail::DKIM::Common::::message_senderMail::DKIM::Common::message_sender
0000s0sMail::DKIM::Common::::newMail::DKIM::Common::new
0000s0sMail::DKIM::Common::::resultMail::DKIM::Common::result
0000s0sMail::DKIM::Common::::result_detailMail::DKIM::Common::result_detail
0000s0sMail::DKIM::Common::::signatureMail::DKIM::Common::signature
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::Common;
2use strict;
3use warnings;
4our $VERSION = '1.20200907'; # VERSION
5# ABSTRACT: Common class for Mail::DKIM
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::Address;
15
16use base 'Mail::DKIM::MessageParser';
17use Carp;
18
19sub new {
20 my $class = shift;
21 return $class->new_object(@_);
22}
23
24sub add_header {
25 my $self = shift;
26 my ($line) = @_;
27
28 foreach my $algorithm ( @{ $self->{algorithms} } ) {
29 $algorithm->add_header($line);
30 }
31
32 if ( $line =~ /^([^:]+?)\s*:(.*)/s ) {
33 my $field_name = lc $1;
34 my $contents = $2;
35 $self->handle_header( $field_name, $contents, $line );
36 }
37 push @{ $self->{headers} }, $line;
38}
39
40sub add_body {
41 my $self = shift;
42 if ( $self->{algorithm} ) {
43 $self->{algorithm}->add_body(@_);
44 }
45 foreach my $algorithm ( @{ $self->{algorithms} } ) {
46 $algorithm->add_body(@_);
47 }
48}
49
50sub handle_header {
51 my $self = shift;
52 my ( $field_name, $contents, $line ) = @_;
53
54 push @{ $self->{header_field_names} }, $field_name;
55
56 # TODO - detect multiple occurrences of From: or Sender:
57 # header and reject them
58
59 $self->{headers_by_name}->{$field_name} = $contents;
60}
61
62sub init {
63 my $self = shift;
64 $self->SUPER::init(@_);
65
66 #initialize variables
67 $self->{headers} = [];
68 $self->{headers_by_name} = {};
69 $self->{header_field_names} = [];
70}
71
72sub load {
73 my $self = shift;
74 my ($fh) = @_;
75
76 while (<$fh>) {
77 $self->PRINT($_);
78 }
79 $self->CLOSE;
80}
81
82sub message_attributes {
83 my $self = shift;
84 my @attributes;
85
86 if ( my $message_id = $self->message_id ) {
87 push @attributes, "message-id=<$message_id>";
88 }
89
90 if ( my $sig = $self->signature ) {
91 push @attributes, 'signer=<' . $sig->identity . '>';
92 }
93
94 if ( $self->{headers_by_name}->{sender} ) {
95 my @list = Mail::Address->parse( $self->{headers_by_name}->{sender} );
96 if ( $list[0] ) {
97 push @attributes, 'sender=<' . $list[0]->address . '>';
98 }
99 }
100 elsif ( $self->{headers_by_name}->{from} ) {
101 my @list = Mail::Address->parse( $self->{headers_by_name}->{from} );
102 if ( $list[0] ) {
103 push @attributes, 'from=<' . $list[0]->address . '>';
104 }
105 }
106
107 return @attributes;
108}
109
110sub message_id {
111 my $self = shift;
112 croak 'wrong number of arguments' unless ( @_ == 0 );
113
114 if ( my $message_id = $self->{headers_by_name}->{'message-id'} ) {
115 if ( $message_id =~ /^\s*<(.*)>\s*$/ ) {
116 return $1;
117 }
118 }
119 return undef;
120}
121
122sub message_originator {
123 my $self = shift;
124 croak 'wrong number of arguments' unless ( @_ == 0 );
125
126 if ( $self->{headers_by_name}->{from} ) {
127 my @list = Mail::Address->parse( $self->{headers_by_name}->{from} );
128 return $list[0] if @list;
129 }
130 return Mail::Address->new;
131}
132
133sub message_sender {
134 my $self = shift;
135 croak 'wrong number of arguments' unless ( @_ == 0 );
136
137 if ( $self->{headers_by_name}->{sender} ) {
138 my @list = Mail::Address->parse( $self->{headers_by_name}->{sender} );
139 return $list[0] if @list;
140 }
141 if ( $self->{headers_by_name}->{from} ) {
142 my @list = Mail::Address->parse( $self->{headers_by_name}->{from} );
143 return $list[0] if @list;
144 }
145 return Mail::Address->new;
146}
147
148sub result {
149 my $self = shift;
150 croak 'wrong number of arguments' unless ( @_ == 0 );
151 return $self->{result};
152}
153
154sub result_detail {
155 my $self = shift;
156 croak 'wrong number of arguments' unless ( @_ == 0 );
157
158 if ( $self->{details} ) {
159 return $self->{result} . ' (' . $self->{details} . ')';
160 }
161 return $self->{result};
162}
163
164sub signature {
165 my $self = shift;
166 croak 'wrong number of arguments' unless ( @_ == 0 );
167 return $self->{signature};
168}
169
1701;
171
172__END__