File Coverage

blib/lib/Mail/SpamAssassin/Plugin/MIMEHeader.pm
Criterion Covered Total %
statement 36 82 43.9
branch 0 24 0.0
condition 1 6 16.6
subroutine 10 12 83.3
pod 2 4 50.0
total 49 128 38.2


line stmt bran cond sub pod time code
1             # <@LICENSE>
2             # Licensed to the Apache Software Foundation (ASF) under one or more
3             # contributor license agreements. See the NOTICE file distributed with
4             # this work for additional information regarding copyright ownership.
5             # The ASF licenses this file to you under the Apache License, Version 2.0
6             # (the "License"); you may not use this file except in compliance with
7             # the License. You may obtain a copy of the License at:
8             #
9             # http://www.apache.org/licenses/LICENSE-2.0
10             #
11             # Unless required by applicable law or agreed to in writing, software
12             # distributed under the License is distributed on an "AS IS" BASIS,
13             # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
14             # See the License for the specific language governing permissions and
15             # limitations under the License.
16             # </@LICENSE>
17              
18             =head1 NAME
19              
20             MIMEHeader - perform regexp tests against MIME headers
21              
22             =head1 SYNOPSIS
23              
24             loadplugin Mail::SpamAssassin::Plugin::MIMEHeader
25             mimeheader NAME_OF_RULE Content-Id =~ /foo/
26              
27             =head1 DESCRIPTION
28              
29             This plugin allows regexp rules to be written against MIME headers in the
30             message.
31              
32             =head1 RULE DEFINITIONS AND PRIVILEGED SETTINGS
33              
34             =over 4
35              
36             =item mimeheader NAME_OF_RULE Header-Name =~ /pattern/modifiers
37              
38             Specify a rule. C<NAME_OF_RULE> is the name of the rule to be used,
39             C<Header-Name> is the name of the MIME header to check, and
40             C</pattern/modifiers> is the Perl regular expression to match against this.
41              
42             Note that in a message of multiple parts, each header will be checked
43             against the pattern separately. In other words, if multiple parts
44             have a 'Content-Type' header, each header's value will be tested
45             individually as a separate string.
46              
47             Header names are considered case-insensitive.
48              
49             The header values are normally cleaned up a little; for example, whitespace
50             around the newline character in "folded" headers will be replaced with a single
51             space. Append C<:raw> to the header name to retrieve the raw, undecoded value,
52             including pristine whitespace, instead.
53              
54             =back
55              
56             =cut
57              
58             package Mail::SpamAssassin::Plugin::MIMEHeader;
59              
60 22     22   161 use strict;
  22         321  
  22         670  
61 22     22   119 use warnings;
  22         53  
  22         732  
62             # use bytes;
63 22     22   139 use re 'taint';
  22         328  
  22         787  
64              
65 22     22   978 use Mail::SpamAssassin::Plugin;
  22         65  
  22         696  
66 22     22   277 use Mail::SpamAssassin::Conf;
  22         54  
  22         633  
67 22     22   120 use Mail::SpamAssassin::Logger;
  22         54  
  22         1170  
68 22     22   273 use Mail::SpamAssassin::Util qw(untaint_var);
  22         54  
  22         19127  
69              
70             our @ISA = qw(Mail::SpamAssassin::Plugin);
71              
72             our @TEMPORARY_METHODS;
73              
74             # ---------------------------------------------------------------------------
75              
76             # constructor
77             sub new {
78 63     63 1 202 my $class = shift;
79 63         366 my $samain = shift;
80              
81             # some boilerplate...
82 63   33     416 $class = ref($class) || $class;
83 63         339 my $self = $class->SUPER::new($samain);
84 63         162 bless ($self, $class);
85              
86 63         284 $self->set_config($samain->{conf});
87              
88 63         560 return $self;
89             }
90              
91             # ---------------------------------------------------------------------------
92              
93             sub set_config {
94 63     63 0 412 my($self, $conf) = @_;
95 63         2325 my @cmds;
96              
97 63         157 my $pluginobj = $self; # allow use inside the closure below
98              
99             push (@cmds, {
100             setting => 'mimeheader',
101             is_priv => 1,
102             code => sub {
103 0     0   0 my ($self, $key, $value, $line) = @_;
104 0         0 local ($1,$2,$3,$4);
105 0 0       0 if ($value !~ /^(\S+)\s+(\S+)\s*([\=\!]\~)\s*(.+)$/) {
106 0         0 return $Mail::SpamAssassin::Conf::INVALID_VALUE;
107             }
108              
109             # provide stricter syntax for rule name!?
110 0         0 my $rulename = untaint_var($1);
111 0         0 my $hdrname = $2;
112 0 0       0 my $negated = ($3 eq '!~') ? 1 : 0;
113 0         0 my $pattern = $4;
114              
115 0 0       0 return unless $self->{parser}->is_delimited_regexp_valid($rulename, $pattern);
116              
117 0         0 $pattern = Mail::SpamAssassin::Util::make_qr($pattern);
118 0 0       0 return $Mail::SpamAssassin::Conf::INVALID_VALUE unless $pattern;
119              
120 0         0 $self->{mimeheader_tests}->{$rulename} = {
121             hdr => $hdrname,
122             negated => $negated,
123             if_unset => '', # TODO!
124             pattern => $pattern
125             };
126              
127             # now here's a hack; generate a fake eval rule function to
128             # call this rule's _real_ code!
129             # TODO: we should have a more elegant way for new rule types to
130             # be defined
131 0         0 my $evalfn = "_mimeheader_eval_$rulename";
132 0         0 $evalfn =~ s/[^a-zA-Z0-9_]/_/gs;
133              
134             # don't redefine the subroutine if it already exists!
135             # this causes lots of annoying warnings and such during things like
136             # "make test".
137 0 0       0 return if (defined &{'Mail::SpamAssassin::Plugin::MIMEHeader::'.$evalfn});
  0         0  
138              
139 0         0 $self->{parser}->add_test($rulename, $evalfn."()",
140             $Mail::SpamAssassin::Conf::TYPE_BODY_EVALS);
141              
142 0         0 my $evalcode = '
143             sub Mail::SpamAssassin::Plugin::MIMEHeader::'.$evalfn.' {
144             $_[0]->eval_hook_called($_[1], q{'.$rulename.'});
145             }
146             ';
147              
148             eval
149             $evalcode . '; 1'
150 0 0       0 or do {
151 0 0       0 my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
  0         0  
152 0         0 warn "mimeheader: plugin error: $eval_stat\n";
153 0         0 return $Mail::SpamAssassin::Conf::INVALID_VALUE;
154             };
155              
156 0         0 $pluginobj->register_eval_rule($evalfn);
157              
158 0         0 push @TEMPORARY_METHODS, "Mail::SpamAssassin::Plugin::MIMEHeader::${evalfn}";
159             }
160 63         1556 });
161              
162 63         335 $conf->{parser}->register_commands(\@cmds);
163             }
164              
165             # ---------------------------------------------------------------------------
166              
167             sub eval_hook_called {
168 0     0 0 0 my ($pobj, $scanner, $rulename) = @_;
169              
170 0         0 my $rule = $scanner->{conf}->{mimeheader_tests}->{$rulename};
171 0         0 my $hdr = $rule->{hdr};
172 0         0 my $negated = $rule->{negated};
173 0         0 my $if_unset = $rule->{if_unset};
174 0         0 my $pattern = $rule->{pattern};
175              
176              
177 0         0 my $getraw;
178 0 0       0 if ($hdr =~ s/:raw$//i) {
179 0         0 $getraw = 1;
180             } else {
181 0         0 $getraw = 0;
182             }
183              
184 0         0 foreach my $p ($scanner->{msg}->find_parts(qr/./)) {
185 0         0 my $val;
186 0 0       0 if ($getraw) {
187 0         0 $val = $p->raw_header($hdr);
188             } else {
189 0         0 $val = $p->get_header($hdr);
190             }
191 0   0     0 $val ||= $if_unset;
192              
193 0 0       0 if ($val =~ ${pattern}) {
194 0 0       0 return ($negated ? 0 : 1);
195             }
196             }
197              
198 0 0       0 return ($negated ? 1 : 0);
199             }
200              
201             # ---------------------------------------------------------------------------
202              
203             sub finish_tests {
204 40     40 1 117 my ($self, $params) = @_;
205              
206 40         163 foreach my $method (@TEMPORARY_METHODS) {
207 0         0 undef &{$method};
  0         0  
208             }
209 40         139 @TEMPORARY_METHODS = (); # clear for next time
210             }
211              
212             # ---------------------------------------------------------------------------
213              
214             1;