File Coverage

blib/lib/Mail/Message/Head/SpamGroup.pm
Criterion Covered Total %
statement 30 82 36.5
branch 3 40 7.5
condition 0 6 0.0
subroutine 7 13 53.8
pod 7 7 100.0
total 47 148 31.7


line stmt bran cond sub pod time code
1             # Copyrights 2001-2022 by [Mark Overmeer ].
2             # For other contributors see ChangeLog.
3             # See the manual pages for details on the licensing terms.
4             # Pod stripped from pm file by OODoc 2.03.
5             # This code is part of distribution Mail-Message. Meta-POD processed with
6             # OODoc into POD and HTML manual-pages. See README.md
7             # Copyright Mark Overmeer. Licensed under the same terms as Perl itself.
8              
9             package Mail::Message::Head::SpamGroup;
10 2     2   1126 use vars '$VERSION';
  2         6  
  2         89  
11             $VERSION = '3.012';
12              
13 2     2   11 use base 'Mail::Message::Head::FieldGroup';
  2         3  
  2         449  
14              
15 2     2   11 use strict;
  2         2  
  2         32  
16 2     2   6 use warnings;
  2         4  
  2         39  
17              
18 2     2   8 use Carp 'confess';
  2         4  
  2         915  
19              
20              
21             #------------------------------------------
22              
23              
24             my %fighters;
25             my $fighterfields; # one regexp for all fields
26              
27 0     0 1 0 sub knownFighters() { keys %fighters }
28              
29             #------------------------------------------
30              
31              
32             sub fighter($;@)
33 6     6 1 16 { my ($thing, $name) = (shift, shift);
34              
35 6 50       15 if(@_)
36 6         24 { my %args = @_;
37 6 50       16 defined $args{fields} or confess "Spamfighters require fields\n";
38 6 50       12 defined $args{isspam} or confess "Spamfighters require isspam\n";
39 6         14 $fighters{$name} = \%args;
40              
41 6         12 my @fields = map { $_->{fields} } values %fighters;
  12         35  
42 6         11 local $" = '|';
43 6         78 $fighterfields = qr/@fields/;
44             }
45              
46 6         12 %{$fighters{$name}};
  6         1033  
47             }
48              
49              
50             BEGIN
51             { __PACKAGE__->fighter( SpamAssassin =>
52             fields => qr/^X-Spam-/i
53             , isspam =>
54 0         0 sub { my ($sg, $head) = @_;
55 0 0 0     0 my $f = $head->get('X-Spam-Flag') || $head->get('X-Spam-Status')
56             or return 0;
57              
58 0         0 $f =~ m/^yes\b/i;
59             }
60             , version =>
61 0         0 sub { my ($sg, $head) = @_;
62 0 0       0 my $assin = $head->get('X-Spam-Checker-Version') or return ();
63 0         0 my ($software, $version) = $assin =~ m/^(.*)\s+(.*?)\s*$/;
64 0         0 ($software, $version);
65             }
66 2     2   25 );
67              
68             __PACKAGE__->fighter( 'Habeas-SWE' =>
69             fields => qr/^X-Habeas-SWE/i
70             , isspam =>
71 0         0 sub { my ($sg, $head) = @_;
72 0         0 not $sg->habeasSweFieldsCorrect;
73             }
74 2         11 );
75              
76             __PACKAGE__->fighter( MailScanner =>
77             fields => qr/^X-MailScanner/i
78             , isspam =>
79 0         0 sub { my ($sg, $head) = @_;
80 0         0 my $subject = $head->get('subject');
81 0         0 $subject =~ m/^\{ (?:spam|virus)/xi;
82             }
83 2         25 );
84              
85             }
86              
87             #------------------------------------------
88              
89              
90             sub from($@)
91 0     0 1   { my ($class, $from, %args) = @_;
92 0 0         my $head = $from->isa('Mail::Message::Head') ? $from : $from->head;
93 0           my ($self, @detected);
94              
95 0 0         my @types = defined $args{types} ? @{$args{types}} : $class->knownFighters;
  0            
96              
97 0           foreach my $type (@types)
98 0 0         { $self = $class->new(head => $head) unless defined $self;
99 0 0         next unless $self->collectFields($type);
100              
101 0           my %fighter = $self->fighter($type);
102             my ($software, $version)
103 0 0         = defined $fighter{version} ? $fighter{version}->($self, $head) : ();
104            
105 0           $self->detected($type, $software, $version);
106 0           $self->spamDetected( $fighter{isspam}->($self, $head) );
107              
108 0           push @detected, $self;
109 0           undef $self; # create a new one
110             }
111              
112 0           @detected;
113             }
114              
115             #------------------------------------------
116              
117             sub collectFields($)
118 0     0 1   { my ($self, $set) = @_;
119 0 0         my %fighter = $self->fighter($set)
120             or confess "ERROR: No spam set $set.";
121              
122 0           my @names = map { $_->name } $self->head->grepNames( $fighter{fields} );
  0            
123 0 0         return () unless @names;
124              
125 0           $self->addFields(@names);
126 0           @names;
127             }
128              
129             #------------------------------------------
130              
131              
132 0     0 1   sub isSpamGroupFieldName($) { $_[1] =~ $fighterfields }
133              
134             #------------------------------------------
135              
136              
137             my @habeas_lines =
138             ( 'winter into spring', 'brightly anticipated', 'like Habeas SWE (tm)'
139             , 'Copyright 2002 Habeas (tm)'
140             , 'Sender Warranted Email (SWE) (tm). The sender of this'
141             , 'email in exchange for a license for this Habeas'
142             , 'warrant mark warrants that this is a Habeas Compliant'
143             , 'Message (HCM) and not spam. Please report use of this'
144             , 'mark in spam to .'
145             );
146              
147             sub habeasSweFieldsCorrect(;$)
148 0     0 1   { my $self;
149              
150 0 0         if(@_ > 1)
151 0           { my ($class, $thing) = @_;
152 0 0         my $head = $thing->isa('Mail::Message::Head') ? $thing : $thing->head;
153 0 0         $self = $head->spamGroups('Habeas-SWE') or return;
154             }
155             else
156 0           { $self = shift;
157 0           my $type = $self->type;
158 0 0 0       return unless defined $type && $type eq 'Habeas-SWE';
159             }
160              
161 0           my $head = $self->head;
162 0 0         return if $self->fields != @habeas_lines;
163              
164 0           for(my $nr=1; $nr <= $#habeas_lines; $nr++)
165 0 0         { my $f = $head->get("X-Habeas-SWE-$nr") or return;
166 0 0         return if $f->unfoldedBody ne $habeas_lines[$nr-1];
167             }
168              
169 0           1;
170             }
171              
172             #------------------------------------------
173              
174              
175             sub spamDetected(;$)
176 0     0 1   { my $self = shift;
177 0 0         @_? ($self->{MMFS_spam} = shift) : $self->{MMFS_spam};
178             }
179              
180             #------------------------------------------
181              
182              
183             1;