File Coverage

blib/lib/Mail/DKIM/Common.pm
Criterion Covered Total %
statement 54 95 56.8
branch 8 46 17.3
condition n/a
subroutine 13 18 72.2
pod 0 13 0.0
total 75 172 43.6


line stmt bran cond sub pod time code
1             package Mail::DKIM::Common;
2 12     12   141 use strict;
  12         30  
  12         397  
3 12     12   62 use warnings;
  12         23  
  12         495  
4             our $VERSION = '1.20230630'; # VERSION
5             # ABSTRACT: Common class for Mail::DKIM
6              
7             # Copyright 2005-2007 Messiah College. All rights reserved.
8             # Jason Long
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              
14 12     12   3561 use Mail::Address;
  12         19666  
  12         378  
15              
16 12     12   94 use base 'Mail::DKIM::MessageParser';
  12         26  
  12         1230  
17 12     12   82 use Carp;
  12         25  
  12         14692  
18              
19             sub new {
20 295     295 0 189203 my $class = shift;
21 295         1891 return $class->new_object(@_);
22             }
23              
24             sub add_header {
25 3386     3386 0 4598 my $self = shift;
26 3386         5299 my ($line) = @_;
27              
28 3386         4376 foreach my $algorithm ( @{ $self->{algorithms} } ) {
  3386         6784  
29 4441         8436 $algorithm->add_header($line);
30             }
31              
32 3386 100       15485 if ( $line =~ /^([^:]+?)\s*:(.*)/s ) {
33 3384         8315 my $field_name = lc $1;
34 3384         6268 my $contents = $2;
35 3384         7313 $self->handle_header( $field_name, $contents, $line );
36             }
37 3386         4276 push @{ $self->{headers} }, $line;
  3386         8077  
38             }
39              
40             sub add_body {
41 287     287 0 493 my $self = shift;
42 287 50       660 if ( $self->{algorithm} ) {
43 0         0 $self->{algorithm}->add_body(@_);
44             }
45 287         444 foreach my $algorithm ( @{ $self->{algorithms} } ) {
  287         658  
46 458         1077 $algorithm->add_body(@_);
47             }
48             }
49              
50             sub handle_header {
51 3384     3384 0 4468 my $self = shift;
52 3384         5973 my ( $field_name, $contents, $line ) = @_;
53              
54 3384         4517 push @{ $self->{header_field_names} }, $field_name;
  3384         6962  
55              
56             # TODO - detect multiple occurrences of From: or Sender:
57             # header and reject them
58              
59 3384         9468 $self->{headers_by_name}->{$field_name} = $contents;
60             }
61              
62             sub init {
63 296     296 0 484 my $self = shift;
64 296         869 $self->SUPER::init(@_);
65              
66             #initialize variables
67 296         652 $self->{headers} = [];
68 296         567 $self->{headers_by_name} = {};
69 296         656 $self->{header_field_names} = [];
70             }
71              
72             sub load {
73 0     0 0 0 my $self = shift;
74 0         0 my ($fh) = @_;
75              
76 0         0 while (<$fh>) {
77 0         0 $self->PRINT($_);
78             }
79 0         0 $self->CLOSE;
80             }
81              
82             sub message_attributes {
83 0     0 0 0 my $self = shift;
84 0         0 my @attributes;
85              
86 0 0       0 if ( my $message_id = $self->message_id ) {
87 0         0 push @attributes, "message-id=<$message_id>";
88             }
89              
90 0 0       0 if ( my $sig = $self->signature ) {
91 0         0 push @attributes, 'signer=<' . $sig->identity . '>';
92             }
93              
94 0 0       0 if ( $self->{headers_by_name}->{sender} ) {
    0          
95 0         0 my @list = Mail::Address->parse( $self->{headers_by_name}->{sender} );
96 0 0       0 if ( $list[0] ) {
97 0         0 push @attributes, 'sender=<' . $list[0]->address . '>';
98             }
99             }
100             elsif ( $self->{headers_by_name}->{from} ) {
101 0         0 my @list = Mail::Address->parse( $self->{headers_by_name}->{from} );
102 0 0       0 if ( $list[0] ) {
103 0         0 push @attributes, 'from=<' . $list[0]->address . '>';
104             }
105             }
106              
107 0         0 return @attributes;
108             }
109              
110             sub message_id {
111 0     0 0 0 my $self = shift;
112 0 0       0 croak 'wrong number of arguments' unless ( @_ == 0 );
113              
114 0 0       0 if ( my $message_id = $self->{headers_by_name}->{'message-id'} ) {
115 0 0       0 if ( $message_id =~ /^\s*<(.*)>\s*$/ ) {
116 0         0 return $1;
117             }
118             }
119 0         0 return undef;
120             }
121              
122             sub message_originator {
123 0     0 0 0 my $self = shift;
124 0 0       0 croak 'wrong number of arguments' unless ( @_ == 0 );
125              
126 0 0       0 if ( $self->{headers_by_name}->{from} ) {
127 0         0 my @list = Mail::Address->parse( $self->{headers_by_name}->{from} );
128 0 0       0 return $list[0] if @list;
129             }
130 0         0 return Mail::Address->new;
131             }
132              
133             sub message_sender {
134 0     0 0 0 my $self = shift;
135 0 0       0 croak 'wrong number of arguments' unless ( @_ == 0 );
136              
137 0 0       0 if ( $self->{headers_by_name}->{sender} ) {
138 0         0 my @list = Mail::Address->parse( $self->{headers_by_name}->{sender} );
139 0 0       0 return $list[0] if @list;
140             }
141 0 0       0 if ( $self->{headers_by_name}->{from} ) {
142 0         0 my @list = Mail::Address->parse( $self->{headers_by_name}->{from} );
143 0 0       0 return $list[0] if @list;
144             }
145 0         0 return Mail::Address->new;
146             }
147              
148             sub result {
149 253     253 0 1056 my $self = shift;
150 253 50       569 croak 'wrong number of arguments' unless ( @_ == 0 );
151 253         552 return $self->{result};
152             }
153              
154             sub result_detail {
155 100     100 0 321 my $self = shift;
156 100 50       213 croak 'wrong number of arguments' unless ( @_ == 0 );
157              
158 100 100       207 if ( $self->{details} ) {
159 63         5991 return $self->{result} . ' (' . $self->{details} . ')';
160             }
161 37         5227 return $self->{result};
162             }
163              
164             sub signature {
165 27     27 0 2470 my $self = shift;
166 27 50       75 croak 'wrong number of arguments' unless ( @_ == 0 );
167 27         159 return $self->{signature};
168             }
169              
170             1;
171              
172             __END__