line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Mail::DMARC::Report::Aggregate; |
2
|
12
|
|
|
12
|
|
70299
|
use strict; |
|
12
|
|
|
|
|
31
|
|
|
12
|
|
|
|
|
459
|
|
3
|
12
|
|
|
12
|
|
110
|
use warnings; |
|
12
|
|
|
|
|
26
|
|
|
12
|
|
|
|
|
647
|
|
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
our $VERSION = '1.20211209'; |
6
|
|
|
|
|
|
|
|
7
|
12
|
|
|
12
|
|
89
|
use Carp; |
|
12
|
|
|
|
|
57
|
|
|
12
|
|
|
|
|
973
|
|
8
|
12
|
|
|
12
|
|
863
|
use Data::Dumper; |
|
12
|
|
|
|
|
6934
|
|
|
12
|
|
|
|
|
943
|
|
9
|
12
|
|
|
12
|
|
8575
|
use XML::LibXML; |
|
12
|
|
|
|
|
422567
|
|
|
12
|
|
|
|
|
109
|
|
10
|
|
|
|
|
|
|
|
11
|
12
|
|
|
12
|
|
3753
|
use parent 'Mail::DMARC::Base'; |
|
12
|
|
|
|
|
821
|
|
|
12
|
|
|
|
|
101
|
|
12
|
12
|
|
|
12
|
|
8157
|
use Mail::DMARC::Report::Aggregate::Metadata; |
|
12
|
|
|
|
|
156
|
|
|
12
|
|
|
|
|
19483
|
|
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
sub metadata { |
15
|
174
|
|
|
174
|
0
|
1215
|
my $self = shift; |
16
|
174
|
100
|
|
|
|
996
|
return $self->{metadata} if ref $self->{metadata}; |
17
|
19
|
|
|
|
|
172
|
return $self->{metadata} = Mail::DMARC::Report::Aggregate::Metadata->new; |
18
|
|
|
|
|
|
|
} |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
sub policy_published { |
21
|
65
|
|
|
65
|
0
|
4411
|
my ( $self, $policy ) = @_; |
22
|
65
|
100
|
|
|
|
307
|
return $self->{policy_published} if ! $policy; |
23
|
16
|
50
|
|
|
|
87
|
croak "not a policy object!" if 'Mail::DMARC::Policy' ne ref $policy; |
24
|
16
|
|
|
|
|
66
|
return $self->{policy_published} = $policy; |
25
|
|
|
|
|
|
|
} |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
sub record { ## no critic (Ambiguous) |
28
|
35
|
|
|
35
|
0
|
850
|
my ($self, $record, @extra) = @_; |
29
|
35
|
100
|
|
|
|
109
|
if ( !$record) { |
30
|
19
|
|
100
|
|
|
190
|
return $self->{record} || []; |
31
|
|
|
|
|
|
|
} |
32
|
|
|
|
|
|
|
|
33
|
16
|
50
|
|
|
|
49
|
if (@extra) { croak "invalid args"; } |
|
0
|
|
|
|
|
0
|
|
34
|
|
|
|
|
|
|
|
35
|
16
|
50
|
|
|
|
66
|
if ('Mail::DMARC::Report::Aggregate::Record' ne ref $record) { |
36
|
0
|
|
|
|
|
0
|
croak "not a record object"; |
37
|
|
|
|
|
|
|
} |
38
|
|
|
|
|
|
|
|
39
|
16
|
|
100
|
|
|
95
|
$self->{record} ||= []; |
40
|
|
|
|
|
|
|
|
41
|
16
|
|
|
|
|
33
|
push @{ $self->{record} }, $record; |
|
16
|
|
|
|
|
49
|
|
42
|
|
|
|
|
|
|
|
43
|
16
|
|
|
|
|
48
|
return $self->{record}; |
44
|
|
|
|
|
|
|
}; |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
sub dump_report { |
47
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
48
|
0
|
|
|
|
|
0
|
carp Dumper( $self->{metadata}, $self->{policy_published}, $self->{record} ); |
49
|
0
|
|
|
|
|
0
|
return; |
50
|
|
|
|
|
|
|
} |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
sub as_xml { |
53
|
5
|
|
|
5
|
0
|
9
|
my $self = shift; |
54
|
5
|
|
|
|
|
16
|
my $meta = $self->metadata->as_xml; |
55
|
5
|
|
|
|
|
35
|
my $pubp = $self->get_policy_published_as_xml; |
56
|
5
|
|
|
|
|
17
|
my $reco = $self->get_record_as_xml; |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
return <<"EO_XML" |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
\t1.0 |
62
|
|
|
|
|
|
|
$meta |
63
|
|
|
|
|
|
|
$pubp |
64
|
|
|
|
|
|
|
$reco |
65
|
|
|
|
|
|
|
EO_XML |
66
|
5
|
|
|
|
|
51
|
; |
67
|
|
|
|
|
|
|
} |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
sub get_record_as_xml { |
70
|
6
|
|
|
6
|
0
|
13
|
my $self = shift; |
71
|
|
|
|
|
|
|
|
72
|
6
|
|
|
|
|
11
|
my $rec_xml = ''; |
73
|
6
|
|
|
|
|
11
|
foreach my $rec ( @{ $self->{record} } ) { |
|
6
|
|
|
|
|
21
|
|
74
|
8
|
|
|
|
|
13
|
$rec_xml .= "\t\n"; |
75
|
8
|
50
|
|
|
|
28
|
my $ip = $rec->{row}{source_ip} or croak "no source IP!?"; |
76
|
8
|
50
|
|
|
|
26
|
my $count = $rec->{row}{count} or croak "no count!?"; |
77
|
8
|
50
|
|
|
|
22
|
$rec->{row}{policy_evaluated}{disposition} or croak "no disposition?"; |
78
|
8
|
|
|
|
|
101
|
$ip = XML::LibXML::Text->new( $ip )->toString(); |
79
|
8
|
|
|
|
|
77
|
$count = XML::LibXML::Text->new( $count )->toString(); |
80
|
8
|
|
|
|
|
61
|
$rec_xml |
81
|
|
|
|
|
|
|
.="\t\t\n" |
82
|
|
|
|
|
|
|
. "\t\t\t$ip\n" |
83
|
|
|
|
|
|
|
. "\t\t\t$count\n" |
84
|
|
|
|
|
|
|
. $self->get_policy_evaluated_as_xml( $rec ) |
85
|
|
|
|
|
|
|
. "\t\t\n" |
86
|
|
|
|
|
|
|
. $self->get_identifiers_as_xml($rec) |
87
|
|
|
|
|
|
|
. $self->get_auth_results_as_xml($rec); |
88
|
8
|
|
|
|
|
26
|
$rec_xml .= "\t\n"; |
89
|
|
|
|
|
|
|
} |
90
|
6
|
|
|
|
|
22
|
return $rec_xml; |
91
|
|
|
|
|
|
|
} |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
sub get_identifiers_as_xml { |
94
|
8
|
|
|
8
|
0
|
18
|
my ( $self, $rec ) = @_; |
95
|
8
|
|
|
|
|
17
|
my $id = "\t\t\n"; |
96
|
8
|
|
|
|
|
18
|
foreach my $f (qw/ envelope_to envelope_from header_from /) { |
97
|
24
|
100
|
|
|
|
68
|
if ( $f eq 'header_from' ) { # min occurs = 1 |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
98
|
8
|
50
|
|
|
|
35
|
croak "missing header_from!" if ! $rec->{identifiers}{$f}; |
99
|
|
|
|
|
|
|
} |
100
|
|
|
|
|
|
|
elsif ( $f eq 'envelope_from') { # min occurs = 1 |
101
|
8
|
50
|
|
|
|
23
|
$rec->{identifiers}{$f} = '' if ! $rec->{identifiers}{$f}; |
102
|
|
|
|
|
|
|
} |
103
|
|
|
|
|
|
|
elsif ( $f eq 'envelope_to' ) { # min occurs = 0 |
104
|
8
|
100
|
|
|
|
28
|
next if ! $rec->{identifiers}{$f}; |
105
|
|
|
|
|
|
|
}; |
106
|
|
|
|
|
|
|
|
107
|
20
|
|
|
|
|
164
|
my $val = XML::LibXML::Text->new( $rec->{identifiers}{$f} )->toString(); |
108
|
20
|
|
|
|
|
103
|
$id .= "\t\t\t<$f>$val$f>\n"; |
109
|
|
|
|
|
|
|
} |
110
|
8
|
|
|
|
|
22
|
$id .= "\t\t\n"; |
111
|
8
|
|
|
|
|
37
|
return $id; |
112
|
|
|
|
|
|
|
} |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
sub get_auth_results_as_xml { |
115
|
8
|
|
|
8
|
0
|
20
|
my ( $self, $rec ) = @_; |
116
|
8
|
|
|
|
|
13
|
my $ar = "\t\t\n"; |
117
|
|
|
|
|
|
|
|
118
|
8
|
|
|
|
|
12
|
foreach my $dkim_sig ( @{ $rec->{auth_results}{dkim} } ) { |
|
8
|
|
|
|
|
21
|
|
119
|
4
|
|
|
|
|
9
|
$ar .= "\t\t\t\n"; |
120
|
4
|
|
|
|
|
26
|
foreach my $g (qw/ domain selector result human_result /) { |
121
|
16
|
50
|
|
|
|
41
|
next if !defined $dkim_sig->{$g}; |
122
|
16
|
|
|
|
|
127
|
my $val = XML::LibXML::Text->new( $dkim_sig->{$g} )->toString(); |
123
|
16
|
|
|
|
|
89
|
$ar .= "\t\t\t\t<$g>$val$g>\n"; |
124
|
|
|
|
|
|
|
} |
125
|
4
|
|
|
|
|
16
|
$ar .= "\t\t\t\n"; |
126
|
|
|
|
|
|
|
} |
127
|
|
|
|
|
|
|
|
128
|
8
|
|
|
|
|
14
|
foreach my $spf ( @{ $rec->{auth_results}{spf} } ) { |
|
8
|
|
|
|
|
18
|
|
129
|
8
|
|
|
|
|
17
|
$ar .= "\t\t\t\n"; |
130
|
8
|
|
|
|
|
14
|
foreach my $g (qw/ domain scope result /) { |
131
|
24
|
50
|
|
|
|
50
|
next if !defined $spf->{$g}; |
132
|
24
|
|
|
|
|
148
|
my $val = XML::LibXML::Text->new( $spf->{$g} )->toString(); |
133
|
24
|
|
|
|
|
100
|
$ar .= "\t\t\t\t<$g>$val$g>\n"; |
134
|
|
|
|
|
|
|
} |
135
|
8
|
|
|
|
|
17
|
$ar .= "\t\t\t\n"; |
136
|
|
|
|
|
|
|
} |
137
|
|
|
|
|
|
|
|
138
|
8
|
|
|
|
|
16
|
$ar .= "\t\t\n"; |
139
|
8
|
|
|
|
|
25
|
return $ar; |
140
|
|
|
|
|
|
|
} |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
sub get_policy_published_as_xml { |
143
|
6
|
|
|
6
|
0
|
13
|
my $self = shift; |
144
|
6
|
50
|
|
|
|
32
|
my $pp = $self->policy_published or return ''; |
145
|
6
|
|
|
|
|
27
|
my $xml = "\t\n\t\t$pp->{domain}\n"; |
146
|
6
|
|
|
|
|
20
|
foreach my $f (qw/ adkim aspf p sp pct fo /) { |
147
|
36
|
|
|
|
|
65
|
my $v = $pp->{$f}; |
148
|
|
|
|
|
|
|
# Set some default values for missing optional fields if necessary |
149
|
36
|
100
|
66
|
|
|
155
|
if ( $f eq 'sp' && !defined $v ) { |
150
|
6
|
|
|
|
|
21
|
$v = $pp->{'p'}; |
151
|
|
|
|
|
|
|
} |
152
|
36
|
100
|
66
|
|
|
85
|
if ( $f eq 'pct' && !defined $v ) { |
153
|
6
|
|
|
|
|
11
|
$v = '100'; |
154
|
|
|
|
|
|
|
} |
155
|
36
|
100
|
100
|
|
|
72
|
if ( $f eq 'fo' && !defined $v ) { |
156
|
4
|
|
|
|
|
8
|
$v = '0'; |
157
|
|
|
|
|
|
|
} |
158
|
36
|
100
|
|
|
|
65
|
next if !defined $v; |
159
|
24
|
|
|
|
|
195
|
$v = XML::LibXML::Text->new( $v )->toString(); |
160
|
24
|
|
|
|
|
125
|
$xml .= "\t\t<$f>$v$f>\n"; |
161
|
|
|
|
|
|
|
} |
162
|
6
|
|
|
|
|
18
|
$xml .= "\t"; |
163
|
6
|
|
|
|
|
20
|
return $xml; |
164
|
|
|
|
|
|
|
} |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
sub get_policy_evaluated_as_xml { |
167
|
8
|
|
|
8
|
0
|
17
|
my ( $self, $rec ) = @_; |
168
|
8
|
|
|
|
|
16
|
my $pe = "\t\t\t\n"; |
169
|
|
|
|
|
|
|
|
170
|
8
|
|
|
|
|
83
|
foreach my $f (qw/ disposition dkim spf /) { |
171
|
24
|
|
|
|
|
181
|
my $val = XML::LibXML::Text->new( $rec->{row}{policy_evaluated}{$f} )->toString(); |
172
|
24
|
|
|
|
|
122
|
$pe .= "\t\t\t\t<$f>$val$f>\n"; |
173
|
|
|
|
|
|
|
} |
174
|
|
|
|
|
|
|
|
175
|
8
|
|
|
|
|
40
|
my $reasons = $rec->{row}{policy_evaluated}{reason}; |
176
|
8
|
50
|
50
|
|
|
83
|
if ( $reasons && scalar @$reasons ) { |
177
|
0
|
|
|
|
|
0
|
foreach my $reason ( @$reasons ) { |
178
|
0
|
|
|
|
|
0
|
my $typeval = XML::LibXML::Text->new( $reason->{type} )->toString(); |
179
|
0
|
|
|
|
|
0
|
my $commentval = XML::LibXML::Text->new( $reason->{comment} )->toString(); |
180
|
0
|
|
|
|
|
0
|
$pe .= "\t\t\t\t\n"; |
181
|
0
|
|
|
|
|
0
|
$pe .= "\t\t\t\t\t$typeval\n"; |
182
|
0
|
|
|
|
|
0
|
$pe .= "\t\t\t\t\t$commentval\n"; |
183
|
0
|
|
|
|
|
0
|
$pe .= "\t\t\t\t\n"; |
184
|
|
|
|
|
|
|
} |
185
|
|
|
|
|
|
|
}; |
186
|
8
|
|
|
|
|
24
|
$pe .= "\t\t\t\n"; |
187
|
8
|
|
|
|
|
39
|
return $pe; |
188
|
|
|
|
|
|
|
} |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
1; |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
__END__ |