File Coverage

lib/Mail/DMARC/Report/Aggregate.pm
Criterion Covered Total %
statement 111 123 90.2
branch 33 46 71.7
condition 12 15 80.0
subroutine 16 17 94.1
pod 0 10 0.0
total 172 211 81.5


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\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\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\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\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\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__