File Coverage

blib/lib/App/SpamcupNG/Summary.pm
Criterion Covered Total %
statement 75 75 100.0
branch 15 16 93.7
condition 4 6 66.6
subroutine 16 16 100.0
pod 6 6 100.0
total 116 119 97.4


line stmt bran cond sub pod time code
1             use warnings;
2 7     7   194202 use strict;
  7         29  
  7         199  
3 7     7   28 use parent qw(Class::Accessor);
  7         10  
  7         135  
4 7     7   332 use Hash::Util 'lock_keys';
  7         219  
  7         36  
5 7     7   13511 use Carp 'confess';
  7         4308  
  7         47  
6 7     7   405 use Set::Tiny 0.04;
  7         14  
  7         243  
7 7     7   2555  
  7         6882  
  7         293  
8             use App::SpamcupNG::Summary::Receiver;
9 7     7   2353  
  7         15  
  7         30  
10             our $VERSION = '0.015'; # VERSION
11              
12             =pod
13              
14             =head1 NAME
15              
16             App::SpamcupNG::Summary - class to summarise SPAM report data
17              
18             =head1 SYNOPSIS
19              
20             use App::SpamcupNG::Summary;
21             my $summary = App::SpamcupNG::Summary->new;
22             $summary->set_age(16);
23              
24             =head1 DESCRIPTION
25              
26             This class is used internally to store SPAM report data that can latter be
27             saved to generate reports.
28              
29             This class is also based on L<Class::Accessor> and uses
30             C<follow_best_practice>.
31              
32             =head1 ATTRIBUTES
33              
34             =over
35              
36             =item tracking_id: the SPAM report unique tracking ID.
37              
38             =item mailer: the e-mail header C<X-Mailer>, if available. Might be C<undef>.
39              
40             =item content_type: the e-mail header C<Content-Type>, if available. Might be C<undef>.
41              
42             =item age: the time elapsed since the SPAM e-mail was received.
43              
44             =item age_unit: the time elapsed unit since the SPAM e-mail was received.
45              
46             =item contacts: an array reference with the "best contacts" found in the report.
47              
48             =item receivers: an array reference with L<App::SpamcupNG::Summary::Receiver> instances.
49              
50             =back
51              
52             Sometimes the C<receivers> addresses will not real ones, but "counters" that
53             will not be used for the report, but only for Spamcop statistics.
54              
55             =cut
56              
57             __PACKAGE__->follow_best_practice;
58             my $fields = Set::Tiny->new(
59             (
60             'tracking_id', 'mailer', 'content_type', 'age',
61             'age_unit', 'contacts', 'receivers', 'charset'
62             )
63             );
64             my $ro_fields = Set::Tiny->new(qw(receivers));
65              
66             __PACKAGE__->mk_accessors( ( $fields->difference($ro_fields) )->members );
67             __PACKAGE__->mk_ro_accessors( $ro_fields->members );
68              
69             =head1 METHODS
70              
71             =head2 new
72              
73             Creates a new instance. No parameter is required or expected.
74              
75             =cut
76              
77             my ( $class, $attribs_ref ) = @_;
78             my $self = {
79 3     3 1 262 tracking_id => undef,
80 3         27 mailer => undef,
81             content_type => undef,
82             age => undef,
83             age_unit => undef,
84             contacts => undef,
85             receivers => undef,
86             charset => undef
87             };
88             bless $self, $class;
89             lock_keys( %{$self} );
90 3         7 return $self;
91 3         7 }
  3         36  
92 3         49  
93             =head2 as_text
94              
95             Returns the summary attributes as strings, separated by commas.
96              
97             If some of attributes are C<undef>, the string C<not avaialable> will be used
98             instead.
99              
100             =cut
101              
102             my $self = shift;
103             my @simple;
104              
105 4     4 1 8 # Set::Tiny->members is not ordered and we need that to have deterministic text
106 4         5 my @fields = sort( $fields->members );
107             my $complex = Set::Tiny->new(qw(contacts receivers age));
108              
109 4         10 foreach my $field (@fields) {
110 4         40 next if ( $complex->has( ($field) ) );
111             push( @simple, $field );
112 4         28 }
113 32 100       86  
114 20         76 my @dump = map { $_ . '=' . ( $self->{$_} || $self->na ) } @simple;
115              
116             # age can be zero
117 4   66     7 if ( defined( $self->{age} ) ) {
  20         45  
118             push( @dump, 'age=' . $self->{age} );
119             }
120 4 100       9 else {
121 3         6 push( @dump, 'age=' . $self->na );
122             }
123              
124 1         2 foreach my $key (qw(receivers contacts)) {
125             if ( $self->{$key} ) {
126              
127 4         6 if ( $key eq 'contacts' ) {
128 8 100       12 push( @dump,
129             ( "$key=(" . join( ';', @{ $self->{$key} } ) . ')' ) );
130 6 100       12 next;
131             }
132 3         4  
  3         6  
133 3         5 push( @dump, $self->_receivers_as_text );
134              
135             }
136 3         7 else {
137             push( @dump, "$key=()" );
138             }
139             }
140 2         4  
141             return join( ',', @dump );
142             }
143              
144 4         33 =head2 tracking_url
145              
146             Returns the tracking URL of the SPAM report as a string.
147              
148             =cut
149              
150             my $self = shift;
151             return 'https://www.spamcop.net/sc?id=' . $self->{tracking_id};
152             }
153              
154 1     1 1 236 =head2 to_text
155 1         6  
156             Getter for attributes that returns the value as a string.
157              
158             If the attribute value is C<undef>, the string return by C<na()> will be used
159             instead.
160              
161             Expects as parameter the name of the parameter, returns a string.
162              
163             =cut
164              
165             my $self = shift;
166             my @receivers;
167              
168             foreach my $receiver ( @{ $self->{receivers} } ) {
169             push( @receivers, '(' . $receiver->as_text . ')' );
170 5     5   6 }
171 5         7  
172             return "receivers=(" . join( ';', @receivers ) . ')';
173 5         5 }
  5         10  
174 9         21  
175             my $self = shift;
176             return '(' . join( ';', @{ $self->{contacts} } ) . ')'
177 5         30 if ( $self->{contacts} );
178             return '()';
179             }
180              
181 2     2   3 my ( $self, $attrib ) = @_;
182 1         7 return $self->_receivers_as_text if ( $attrib eq 'receivers' );
183 2 100       7 return $self->_contacts_as_text if ( $attrib eq 'contacts' );
184 1         3 return $self->{$attrib} || $self->na;
185             }
186              
187             =head2 na
188 8     8 1 451  
189 8 100       24 Returns the "not available" string. Can be used as class method.
190 6 100       13  
191 4   66     19 =cut
192              
193             return 'not available';
194             }
195              
196             my @fields = sort( $fields->members );
197             return \@fields;
198             }
199              
200             =head2 set_receivers
201 11     11 1 33  
202             Setter for the C<receivers> attribute.
203              
204             Expects as parameter an array reference, with inner array references inside.
205 2     2   864  
206 2         30 Returns "true" (1) if everything goes fine.
207              
208             =cut
209              
210             my ( $self, $receivers_ref ) = @_;
211             confess 'An array reference is expected as parameter'
212             unless ( ref($receivers_ref) eq 'ARRAY' );
213             my @items;
214              
215             foreach my $receiver_ref ( @{$receivers_ref} ) {
216             push( @items, App::SpamcupNG::Summary::Receiver->new($receiver_ref) );
217             }
218              
219             $self->{receivers} = \@items;
220 4     4 1 949 return 1;
221 4 50       17 }
222              
223 4         6 =head1 SEE ALSO
224              
225 4         7 =over
  4         9  
226 8         33  
227             =item *
228              
229 4         15 L<Class::Accessor>
230 4         11  
231             =back
232              
233             =head1 AUTHOR
234              
235             Alceu Rodrigues de Freitas Junior, E<lt>arfreitas@cpan.orgE<gt>
236              
237             =head1 COPYRIGHT AND LICENSE
238              
239             This software is copyright (c) 2018 of Alceu Rodrigues de Freitas Junior,
240             E<lt>arfreitas@cpan.orgE<gt>
241              
242             This file is part of App-SpamcupNG distribution.
243              
244             App-SpamcupNG is free software: you can redistribute it and/or modify it under
245             the terms of the GNU General Public License as published by the Free Software
246             Foundation, either version 3 of the License, or (at your option) any later
247             version.
248              
249             App-SpamcupNG is distributed in the hope that it will be useful, but WITHOUT
250             ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
251             FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
252              
253             You should have received a copy of the GNU General Public License along with
254             App-SpamcupNG. If not, see <http://www.gnu.org/licenses/>.
255              
256             =cut
257              
258             1;