File Coverage

blib/lib/Mail/SpamAssassin/Conf/Parser.pm
Criterion Covered Total %
statement 450 669 67.2
branch 207 338 61.2
condition 58 127 45.6
subroutine 40 58 68.9
pod 0 48 0.0
total 755 1240 60.8


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             Mail::SpamAssassin::Conf::Parser - parse SpamAssassin configuration
21              
22             =head1 SYNOPSIS
23              
24             (see Mail::SpamAssassin)
25              
26             =head1 DESCRIPTION
27              
28             Mail::SpamAssassin is a module to identify spam using text analysis and
29             several internet-based realtime blacklists.
30              
31             This class is used internally by SpamAssassin to parse its configuration files.
32             Please refer to the C<Mail::SpamAssassin> documentation for public interfaces.
33              
34             =head1 STRUCTURE OF A CONFIG BLOCK
35              
36             This is the structure of a config-setting block. Each is a hashref which may
37             contain these keys:
38              
39             =over 4
40              
41             =item setting
42              
43             the name of the setting it modifies, e.g. "required_score". this also doubles
44             as the default for 'command' (below). THIS IS REQUIRED.
45              
46             =item command
47              
48             The command string used in the config file for this setting. Optional;
49             'setting' will be used for the command if this is omitted.
50              
51             =item aliases
52              
53             An [aryref] of other aliases for the same command. optional.
54              
55             =item type
56              
57             The type of this setting:
58              
59             - $CONF_TYPE_NOARGS: must not have any argument, like "clear_headers"
60             - $CONF_TYPE_STRING: string
61             - $CONF_TYPE_NUMERIC: numeric value (float or int)
62             - $CONF_TYPE_BOOL: boolean (0/no or 1/yes)
63             - $CONF_TYPE_TEMPLATE: template, like "report"
64             - $CONF_TYPE_ADDRLIST: list of mail addresses, like "whitelist_from"
65             - $CONF_TYPE_HASH_KEY_VALUE: hash key/value pair, like "describe" or tflags
66             - $CONF_TYPE_STRINGLIST list of strings, stored as an array
67             - $CONF_TYPE_IPADDRLIST list of IP addresses, stored as an array of SA::NetSet
68             - $CONF_TYPE_DURATION a nonnegative time interval in seconds - a numeric value
69             (float or int), optionally suffixed by a time unit (s, m,
70             h, d, w), seconds are implied if unit is missing
71              
72             If this is set, and a 'code' block does not already exist, a 'code' block is
73             assigned based on the type.
74              
75             In addition, the SpamAssassin test suite will validate that the settings
76             do not 'leak' between users.
77              
78             Note that C<$CONF_TYPE_HASH_KEY_VALUE>-type settings require that the
79             value be non-empty, otherwise they'll produce a warning message.
80              
81             =item code
82              
83             A subroutine to deal with the setting. ONE OF B<code> OR B<type> IS REQUIRED.
84             The arguments passed to the function are C<($self, $key, $value, $line)>,
85             where $key is the setting (*not* the command), $value is the value string,
86             and $line is the entire line.
87              
88             There are two special return values that the B<code> subroutine may return
89             to signal that there is an error in the configuration:
90              
91             C<$Mail::SpamAssassin::Conf::MISSING_REQUIRED_VALUE> -- this setting requires
92             that a value be set, but one was not provided.
93              
94             C<$Mail::SpamAssassin::Conf::INVALID_VALUE> -- this setting requires a value
95             from a set of 'valid' values, but the user provided an invalid one.
96              
97             C<$Mail::SpamAssassin::Conf::INVALID_HEADER_FIELD_NAME> -- this setting
98             requires a syntactically valid header field name, but the user provided
99             an invalid one.
100              
101             Any other values -- including C<undef> -- returned from the subroutine are
102             considered to mean 'success'.
103              
104             It is good practice to set a 'type', if possible, describing how your settings
105             are stored on the Conf object; this allows the SpamAssassin test suite to
106             validate that the settings do not 'leak' between users.
107              
108             =item default
109              
110             The default value for the setting. may be omitted if the default value is a
111             non-scalar type, which should be set in the Conf ctor. note for path types:
112             using "__userstate__" is recommended for defaults, as it allows
113             Mail::SpamAssassin module users who set that configuration setting, to receive
114             the correct values.
115              
116             =item is_priv
117              
118             Set to 1 if this setting requires 'allow_user_rules' when run from spamd.
119              
120             =item is_admin
121              
122             Set to 1 if this setting can only be set in the system-wide config when run
123             from spamd. (All settings can be used by local programs run directly by the
124             user.)
125              
126             =item is_frequent
127              
128             Set to 1 if this value occurs frequently in the config. this means it's looked
129             up first for speed.
130              
131             =back
132              
133             =cut
134              
135              
136             use Mail::SpamAssassin::Conf;
137 41     41   270 use Mail::SpamAssassin::Constants qw(:sa);
  41         75  
  41         1401  
138 41     41   191 use Mail::SpamAssassin::Logger;
  41         81  
  41         4876  
139 41     41   262 use Mail::SpamAssassin::Util qw(untaint_var compile_regexp);
  41         72  
  41         2067  
140 41     41   228 use Mail::SpamAssassin::NetSet;
  41         75  
  41         3356  
141 41     41   309  
  41         88  
  41         942  
142             use strict;
143 41     41   264 use warnings;
  41         77  
  41         911  
144 41     41   195 # use bytes;
  41         60  
  41         1417  
145             use re 'taint';
146 41     41   219  
  41         76  
  41         94414  
147             our @ISA = qw();
148              
149             my $ARITH_EXPRESSION_LEXER = ARITH_EXPRESSION_LEXER;
150             my $META_RULES_MATCHING_RE = META_RULES_MATCHING_RE;
151              
152             ###########################################################################
153              
154             my $class = shift;
155             $class = ref($class) || $class;
156 92     92 0 261 my ($conf) = @_;
157 92   33     588  
158 92         272 my $self = {
159             'conf' => $conf
160 92         330 };
161              
162             $self->{command_luts} = { };
163             $self->{command_luts}->{frequent} = { };
164 92         310 $self->{command_luts}->{remaining} = { };
165 92         347  
166 92         357 bless ($self, $class);
167             $self;
168 92         408 }
169 92         713  
170             ###########################################################################
171              
172             my($self, $arrref) = @_;
173             my $conf = $self->{conf};
174              
175 1647     1647 0 3252 $self->set_defaults_from_command_list($arrref);
176 1647         2819 $self->build_command_luts($arrref);
177             push(@{$conf->{registered_commands}}, @{$arrref});
178 1647         4076 }
179 1647         4701  
180 1647         2291 my ($self, $arrref) = @_;
  1647         2979  
  1647         7115  
181             my $conf = $self->{conf};
182             foreach my $cmd (@{$arrref}) {
183             # note! exists, not defined -- we want to be able to set
184 1647     1647 0 2758 # "undef" default values.
185 1647         2177 if (exists($cmd->{default})) {
186 1647         2053 $conf->{$cmd->{setting}} = $cmd->{default};
  1647         3804  
187             }
188             }
189 18638 100       30127 }
190 9922         28540  
191             my ($self, $arrref) = @_;
192              
193             my $conf = $self->{conf};
194              
195             my $set;
196 1647     1647 0 2751 foreach my $cmd (@{$arrref}) {
197             # first off, decide what set this is in.
198 1647         2327 if ($cmd->{is_frequent}) { $set = 'frequent'; }
199             else { $set = 'remaining'; }
200 1647         2048  
201 1647         2234 # next, its priority (used to ensure frequently-used params
  1647         2888  
202             # are parsed first)
203 18638 100       24268 my $cmdname = $cmd->{command} || $cmd->{setting};
  736         981  
204 17902         18796 $self->{command_luts}->{$set}->{$cmdname} = $cmd;
205              
206             if ($cmd->{aliases} && scalar @{$cmd->{aliases}} > 0) {
207             foreach my $name (@{$cmd->{aliases}}) {
208 18638   66     37368 $self->{command_luts}->{$set}->{$name} = $cmd;
209 18638         36710 }
210             }
211 18638 100 66     35601 }
  184         652  
212 184         287 }
  184         474  
213 184         700  
214             ###########################################################################
215              
216             my ($self, undef, $scoresonly) = @_; # leave $rules in $_[1]
217              
218             my $conf = $self->{conf};
219             $self->{scoresonly} = $scoresonly;
220              
221             # Language selection:
222 91     91 0 447 # See http://www.gnu.org/manual/glibc-2.2.5/html_node/Locale-Categories.html
223             # and http://www.gnu.org/manual/glibc-2.2.5/html_node/Using-gettextized-software.html
224 91         295 my $lang = $ENV{'LANGUAGE'}; # LANGUAGE has the highest precedence but has a
225 91         434 if ($lang) { # special format: The user may specify more than
226             $lang =~ s/:.*$//; # one language here, colon separated. We use the
227             } # first one only (lazy bums we are :o)
228             $lang ||= $ENV{'LC_ALL'};
229             $lang ||= $ENV{'LC_MESSAGES'};
230 91         313 $lang ||= $ENV{'LANG'};
231 91 50       306 $lang ||= 'C'; # Nothing set means C/POSIX
232 0         0  
233             if ($lang =~ /^(C|POSIX)$/) {
234 91   33     703 $lang = 'en_US'; # Our default language
235 91   33     563 } else {
236 91   33     432 $lang =~ s/[@.+,].*$//; # Strip codeset, modifier/audience, etc.
237 91   50     527 } # (eg. .utf8 or @euro)
238              
239 91 50       729 # get fast-access handles on the command lookup tables
240 91         378 my $lut_frequent = $self->{command_luts}->{frequent};
241             my $lut_remaining = $self->{command_luts}->{remaining};
242 0         0 my %migrated_keys = map { $_ => 1 }
243             @Mail::SpamAssassin::Conf::MIGRATED_SETTINGS;
244              
245             $self->{currentfile} = '(no file)';
246 91         304 my $skip_parsing = 0;
247 91         204 my @curfile_stack;
248 91         436 my @if_stack;
  91         708  
249             my @conf_lines = split (/\n/, $_[1]);
250             my $line;
251 91         462 $self->{if_stack} = \@if_stack;
252 91         183 $self->{file_scoped_attrs} = { };
253 91         201  
254             my $keepmetadata = $conf->{main}->{keep_config_parsing_metadata};
255 91         72651  
256 91         511 while (defined ($line = shift @conf_lines)) {
257 91         324 local ($1); # bug 3838: prevent random taint flagging of $1
258 91         305  
259             if (index($line,'#') > -1) {
260 91         262 # bug 5545: used to support testing rules in the ruleqa system
261             if ($keepmetadata && $line =~ /^\#testrules/) {
262 91         536 $self->{file_scoped_attrs}->{testrules}++;
263 140874         250811 next;
264             }
265 140874 100       357309  
266             # bug 6800: let X-Spam-Checker-Version also show what sa-update we are at
267 51386 50 33     82077 if ($line =~ /^\# UPDATE version (\d+)$/) {
268 0         0 for ($self->{currentfile}) { # just aliasing, not a loop
269 0         0 $conf->{update_version}{$_} = $1 if defined $_ && $_ ne '(no file)';
270             }
271             }
272              
273 51386 50       75313 $line =~ s/(?<!\\)#.*$//; # remove comments
274 0         0 $line =~ s/\\#/#/g; # hash chars are escaped, so unescape them
275 0 0 0     0 }
276              
277             $line =~ s/^\s+//; # remove leading whitespace
278             $line =~ s/\s+$//; # remove tailing whitespace
279 51386         126931 next unless($line); # skip empty lines
280 51386         72093  
281             # handle i18n
282             if ($line =~ s/^lang\s+(\S+)\s+//) { next if ($lang !~ /^$1/i); }
283 140874         236955  
284 140874         232393 my($key, $value) = split(/\s+/, $line, 2);
285 140874 100       325565 $key = lc $key;
286             # convert all dashes in setting name to underscores.
287             $key =~ tr/-/_/;
288 75498 0       130843 $value = '' unless defined($value);
  0 50       0  
289              
290 75498         269475 # # Do a better job untainting this info ...
291 75498         153022 # # $value = untaint_var($value);
292             # Do NOT blindly untaint now, do it carefully later when semantics is known!
293 75498         122530  
294 75498 100       139897 my $parse_error; # undef by default, may be overridden
295              
296             # File/line number assertions
297             if ($key eq 'file') {
298             if ($value =~ /^start\s+(.+)$/) {
299             push (@curfile_stack, $self->{currentfile});
300 75498         81918 $self->{currentfile} = $1;
301             next;
302             }
303 75498 100       289002  
    50          
    100          
    100          
    50          
    100          
304 3314 100       9303 if ($value =~ /^end\s/) {
305 1657         3754 $self->{file_scoped_attrs} = { };
306 1657         3591  
307 1657         6981 if (scalar @if_stack > 0) {
308             my $cond = pop @if_stack;
309              
310 1657 50       5800 if ($cond->{type} eq 'if') {
311 1657         4479 my $msg = "config: unclosed 'if' in ".
312             $self->{currentfile}.": if ".$cond->{conditional}."\n";
313 1657 50       3861 warn $msg;
314 0         0 $self->lint_warn($msg, undef);
315             }
316 0 0       0 else {
317             # die seems a bit excessive here, but this shouldn't be possible
318 0         0 # so I suppose it's okay.
319 0         0 die "config: unknown 'if' type: ".$cond->{type}."\n";
320 0         0 }
321              
322             @if_stack = ();
323             }
324             $skip_parsing = 0;
325 0         0  
326             my $curfile = pop @curfile_stack;
327             if (defined $curfile) {
328 0         0 $self->{currentfile} = $curfile;
329             } else {
330 1657         2440 $self->{currentfile} = '(no file)';
331             }
332 1657         2741 next;
333 1657 50       3089 }
334 1657         3125 }
335              
336 0         0 # now handle the commands.
337             elsif ($key eq 'include') {
338 1657         6924 $value = $self->fix_path_relative_to_current_file($value);
339             my $text = $conf->{main}->read_cf($value, 'included file');
340             unshift (@conf_lines, split (/\n/, $text));
341             next;
342             }
343              
344 0         0 elsif ($key eq 'ifplugin') {
345 0         0 $self->handle_conditional ($key, "plugin ($value)",
346 0         0 \@if_stack, \$skip_parsing);
347 0         0 next;
348             }
349              
350             elsif ($key eq 'if') {
351 746         4583 $self->handle_conditional ($key, $value,
352             \@if_stack, \$skip_parsing);
353 746         5449 next;
354             }
355              
356             elsif ($key eq 'else') {
357 239         1184 # TODO: if/else/else won't get flagged here :(
358             if (!@if_stack) {
359 239         1750 $parse_error = "config: found else without matching conditional";
360             goto failed_line;
361             }
362              
363             $skip_parsing = !$skip_parsing;
364 0 0       0 next;
365 0         0 }
366 0         0  
367             # and the endif statement:
368             elsif ($key eq 'endif') {
369 0         0 my $lastcond = pop @if_stack;
370 0         0 if (!defined $lastcond) {
371             $parse_error = "config: found endif without matching conditional";
372             goto failed_line;
373             }
374              
375 985         1771 $skip_parsing = $lastcond->{skip_parsing};
376 985 50       2089 next;
377 0         0 }
378 0         0  
379             # preprocessing? skip all other commands
380             next if $skip_parsing;
381 985         1651  
382 985         5101 if ($key eq 'require_version') {
383             # if it wasn't replaced during install, assume current version ...
384             next if ($value eq "\@\@VERSION\@\@");
385              
386 70214 100       109980 my $ver = $Mail::SpamAssassin::VERSION;
387              
388 70055 50       114196 # if we want to allow "require_version 3.0" be good for all
389             # "3.0.x" versions:
390 0 0       0 ## make sure it's a numeric value
391             #$value += 0.0;
392 0         0 ## convert 3.000000 -> 3.0, stay backward compatible ...
393             #$ver =~ s/^(\d+)\.(\d{1,3}).*$/sprintf "%d.%d", $1, $2/e;
394             #$value =~ s/^(\d+)\.(\d{1,3}).*$/sprintf "%d.%d", $1, $2/e;
395              
396             if ($ver ne $value) {
397             my $msg = "config: configuration file \"$self->{currentfile}\" requires ".
398             "version $value of SpamAssassin, but this is code version ".
399             "$ver. Maybe you need to use ".
400             "the -C switch, or remove the old config files? ".
401             "Skipping this file";
402 0 0       0 warn $msg;
403 0         0 $self->lint_warn($msg, undef);
404             $skip_parsing = 1;
405             }
406             next;
407             }
408 0         0  
409 0         0 my $cmd = $lut_frequent->{$key}; # check the frequent command set
410 0         0 if (!$cmd) {
411             $cmd = $lut_remaining->{$key}; # no? try the rest
412 0         0 }
413              
414             # we've either fallen through with no match, in which case this
415 70055         101379 # if() will fail, or we have a match.
416 70055 100       99769 if ($cmd) {
417 61781         83798 if ($self->{scoresonly}) { # reading user config from spamd
418             if ($cmd->{is_priv} && !$conf->{allow_user_rules}) {
419             info("config: not parsing, 'allow_user_rules' is 0: $line");
420             goto failed_line;
421             }
422 70055 100       98532 if ($cmd->{is_admin}) {
423 70042 50       111263 info("config: not parsing, administrator setting: $line");
424 0 0 0     0 goto failed_line;
425 0         0 }
426 0         0 }
427              
428 0 0       0 if (!$cmd->{code}) {
429 0         0 if (! $self->setup_default_code_cb($cmd)) {
430 0         0 goto failed_line;
431             }
432             }
433              
434 70042 100       107147 my $ret = &{$cmd->{code}} ($conf, $cmd->{setting}, $value, $line);
435 726 50       2067  
436 0         0 if ($ret && $ret eq $Mail::SpamAssassin::Conf::INVALID_VALUE)
437             {
438             $parse_error = "config: SpamAssassin failed to parse line, ".
439             "\"$value\" is not valid for \"$key\", ".
440 70042         78814 "skipping: $line";
  70042         137070  
441             goto failed_line;
442 70042 50 66     342611 }
    50 66        
    50 66        
443             elsif ($ret && $ret eq $Mail::SpamAssassin::Conf::INVALID_HEADER_FIELD_NAME)
444 0         0 {
445             $parse_error = "config: SpamAssassin failed to parse line, ".
446             "it does not specify a valid header field name, ".
447 0         0 "skipping: $line";
448             goto failed_line;
449             }
450             elsif ($ret && $ret eq $Mail::SpamAssassin::Conf::MISSING_REQUIRED_VALUE)
451 0         0 {
452             $parse_error = "config: SpamAssassin failed to parse line, ".
453             "no value provided for \"$key\", ".
454 0         0 "skipping: $line";
455             goto failed_line;
456             }
457             else {
458 0         0 next;
459             }
460             }
461 0         0  
462             # last ditch: try to see if the plugins know what to do with it
463             if ($conf->{main}->call_plugins("parse_config", {
464 70042         339866 key => $key,
465             value => $value,
466             line => $line,
467             conf => $conf,
468             user_config => $self->{scoresonly}
469 13 50       93 }))
470             {
471             # a plugin dealt with it successfully.
472             next;
473             }
474              
475             failed_line:
476             my $msg = $parse_error;
477             my $is_error = 1;
478 0         0 if (!$msg) {
479             # use a default warning, if a more specific one wasn't output
480             if ($migrated_keys{$key}) {
481             # this key was moved into a plugin; non-fatal for lint
482 13         49 $is_error = 0;
483 13         17 $msg = "config: failed to parse, now a plugin, skipping, in \"$self->{currentfile}\": $line";
484 13 50       21 } else {
485             # a real syntax error; this is fatal for --lint
486 13 50       29 $msg = "config: failed to parse line, skipping, in \"$self->{currentfile}\": $line";
487             }
488 0         0 }
489 0         0  
490             $self->lint_warn($msg, undef, $is_error);
491             }
492 13         40  
493             delete $self->{if_stack};
494              
495             $self->lint_check();
496 13         46 $self->set_default_scores();
497             $self->check_for_missing_descriptions();
498              
499 91         326 delete $self->{scoresonly};
500             }
501 91         498  
502 91         368 my ($self, $key, $value, $if_stack_ref, $skip_parsing_ref) = @_;
503 91         590 my $conf = $self->{conf};
504              
505 91         901 my @tokens = ($value =~ /($ARITH_EXPRESSION_LEXER)/og);
506              
507             my $eval = '';
508             my $bad = 0;
509 985     985 0 3255 foreach my $token (@tokens) {
510 985         2056 if ($token =~ /^(?:\W{1,5}|[+-]?\d+(?:\.\d+)?)$/) {
511             # using tainted subr. argument may taint the whole expression, avoid
512 985         12398 my $u = untaint_var($token);
513             $eval .= $u . " ";
514 985         2453 }
515 985         1508 elsif ($token eq 'plugin') {
516 985         2078 # replace with a method call
517 4021 100       17415 $eval .= '$self->cond_clause_plugin_loaded';
    100          
    100          
    50          
    100          
    50          
    50          
518             }
519 2132         5342 elsif ($token eq 'can') {
520 2132         4651 # replace with a method call
521             $eval .= '$self->cond_clause_can';
522             }
523             elsif ($token eq 'has') {
524 746         1713 # replace with a method call
525             $eval .= '$self->cond_clause_has';
526             }
527             elsif ($token eq 'version') {
528 158         451 $eval .= $Mail::SpamAssassin::VERSION." ";
529             }
530             elsif ($token eq 'perl_version') {
531             $eval .= $]." ";
532 0         0 }
533             elsif ($token =~ /^\w[\w\:]+$/) { # class name
534             # Strictly controlled form:
535 81         357 if ($token =~ /^(?:\w+::){0,10}\w+$/) {
536             my $u = untaint_var($token);
537             $eval .= "'$u'";
538 0         0 } else {
539             warn "config: illegal name '$token' in 'if $value'\n";
540             $bad++;
541             last;
542 904 50       4061 }
543 904         2053 }
544 904         2731 else {
545             $bad++;
546 0         0 warn "config: unparseable chars in 'if $value': '$token'\n";
547 0         0 last;
548 0         0 }
549             }
550              
551             if ($bad) {
552 0         0 $self->lint_warn("config: bad 'if' line, in \"$self->{currentfile}\"", undef);
553 0         0 return -1;
554 0         0 }
555              
556             push (@{$if_stack_ref}, {
557             type => 'if',
558 985 50       2074 conditional => $value,
559 0         0 skip_parsing => $$skip_parsing_ref
560 0         0 });
561              
562             if (eval $eval) {
563 985         1401 # leave $skip_parsing as-is; we may not be parsing anyway in this block.
  985         4778  
564             # in other words, support nested 'if's and 'require_version's
565             } else {
566             warn "config: error in $key - $eval: $@" if $@ ne '';
567             $$skip_parsing_ref = 1;
568             }
569 985 100       63035 }
570              
571             # functions supported in the "if" eval:
572             return $_[0]->{conf}->{plugins_loaded}->{$_[1]};
573 76 50       315 }
574 76         313  
575             my ($self, $method) = @_;
576             if ($self->{currentfile} =~ q!\buser_prefs$! ) {
577             warn "config: 'if can $method' not available in user_prefs";
578             return 0
579             }
580 746     746 0 8859 $self->cond_clause_can_or_has('can', $method);
581             }
582              
583             my ($self, $method) = @_;
584 158     158 0 529 $self->cond_clause_can_or_has('has', $method);
585 158 50       676 }
586 0         0  
587 0         0 my ($self, $fn_name, $method) = @_;
588              
589 158         621 local($1,$2);
590             if (!defined $method) {
591             $self->lint_warn("config: bad 'if' line, no argument to $fn_name(), ".
592             "in \"$self->{currentfile}\"", undef);
593 0     0 0 0 } elsif ($method =~ /^(.*)::([^:]+)$/) {
594 0         0 no strict "refs";
595             my($module, $meth) = ($1, $2);
596             return 1 if $module->can($meth) &&
597             ( $fn_name eq 'has' || &{$method}() );
598 158     158 0 443 } else {
599             $self->lint_warn("config: bad 'if' line, cannot find '::' in $fn_name($method), ".
600 158         591 "in \"$self->{currentfile}\"", undef);
601 158 50       1265 }
    50          
602 0         0 return;
603             }
604              
605 41     41   378 # Let's do some linting here ...
  41         80  
  41         225555  
606 158         598 # This is called from _parse(), BTW, so we can check for $conf->{tests}
607             # easily before finish_parsing() is called and deletes it.
608 158 50 33     2269 #
      33        
609             my ($self) = @_;
610 0         0 my $conf = $self->{conf};
611              
612             if ($conf->{lint_rules}) {
613 0         0 # Check for description and score issues in lint fashion
614             while ( my $k = each %{$conf->{descriptions}} ) {
615             if (!exists $conf->{tests}->{$k}) {
616             dbg("config: warning: description exists for non-existent rule $k");
617             }
618             }
619              
620             while ( my($sk) = each %{$conf->{scores}} ) {
621 91     91 0 274 if (!exists $conf->{tests}->{$sk}) {
622 91         251 # bug 5514: not a lint warning any more
623             dbg("config: warning: score set for non-existent rule $sk");
624 91 100       359 }
625             }
626 32         63 }
  928         1851  
627 896 50       1963 }
628 0         0  
629             # we should set a default score for all valid rules... Do this here
630             # instead of add_test because mostly 'score' occurs after the rule is
631             # specified, so why set the scores to default, then set them again at
632 32         68 # 'score'?
  672         1327  
633 640 50       1096 #
634             my ($self) = @_;
635 0         0 my $conf = $self->{conf};
636              
637             while ( my $k = each %{$conf->{tests}} ) {
638             if ( ! exists $conf->{scores}->{$k} ) {
639             # T_ rules (in a testing probationary period) get low, low scores
640             my $set_score = ($k =~/^T_/) ? 0.01 : 1.0;
641              
642             $set_score = -$set_score if ( ($conf->{tflags}->{$k}||'') =~ /\bnice\b/ );
643             for my $index (0..3) {
644             $conf->{scoreset}->[$index]->{$k} = $set_score;
645             }
646             }
647 91     91 0 266 }
648 91         210 }
649              
650 91         168 # loop through all the tests and if we are missing a description with debug
  3788         7641  
651 3697 100       5869 # set, throw a warning except for testing T_ or meta __ rules.
652             my ($self) = @_;
653 2458 50       3676 my $conf = $self->{conf};
654              
655 2458 100 100     8532 while ( my $k = each %{$conf->{tests}} ) {
656 2458         3811 if ($k !~ m/^(?:T_|__)/i) {
657 9832         16845 if ( ! exists $conf->{descriptions}->{$k} ) {
658             dbg("config: warning: no description set for $k");
659             }
660             }
661             }
662             }
663              
664             ###########################################################################
665              
666 91     91 0 269 my ($self, $cmd) = @_;
667 91         209 my $type = $cmd->{type};
668              
669 91         163 if ($type == $Mail::SpamAssassin::Conf::CONF_TYPE_STRING) {
  3788         6848  
670 3697 100       6711 $cmd->{code} = \&set_string_value;
671 3509 100       6148 }
672 1785         3644 elsif ($type == $Mail::SpamAssassin::Conf::CONF_TYPE_BOOL) {
673             $cmd->{code} = \&set_bool_value;
674             }
675             elsif ($type == $Mail::SpamAssassin::Conf::CONF_TYPE_NUMERIC) {
676             $cmd->{code} = \&set_numeric_value;
677             }
678             elsif ($type == $Mail::SpamAssassin::Conf::CONF_TYPE_HASH_KEY_VALUE) {
679             $cmd->{code} = \&set_hash_key_value;
680             }
681 726     726 0 1320 elsif ($type == $Mail::SpamAssassin::Conf::CONF_TYPE_ADDRLIST) {
682 726         1357 $cmd->{code} = \&set_addrlist_value;
683             }
684 726 100       2864 elsif ($type == $Mail::SpamAssassin::Conf::CONF_TYPE_TEMPLATE) {
    100          
    100          
    100          
    50          
    100          
    50          
    50          
    50          
    0          
685 124         380 $cmd->{code} = \&set_template_append;
686             }
687             elsif ($type == $Mail::SpamAssassin::Conf::CONF_TYPE_NOARGS) {
688 97         424 $cmd->{code} = \&set_no_value;
689             }
690             elsif ($type == $Mail::SpamAssassin::Conf::CONF_TYPE_STRINGLIST) {
691 213         533 $cmd->{code} = \&set_string_list;
692             }
693             elsif ($type == $Mail::SpamAssassin::Conf::CONF_TYPE_IPADDRLIST) {
694 124         394 $cmd->{code} = \&set_ipaddr_list;
695             }
696             elsif ($type == $Mail::SpamAssassin::Conf::CONF_TYPE_DURATION) {
697 0         0 $cmd->{code} = \&set_duration_value;
698             }
699             else {
700 124         327 warn "config: unknown conf type $type!";
701             return 0;
702             }
703 0         0 return 1;
704             }
705              
706 0         0 my ($conf, $key, $value, $line) = @_;
707              
708             unless (!defined $value || $value eq '') {
709 44         135 return $Mail::SpamAssassin::Conf::INVALID_VALUE;
710             }
711             }
712 0         0  
713             my ($conf, $key, $value, $line) = @_;
714              
715 0         0 unless (defined $value && $value !~ /^$/) {
716 0         0 return $Mail::SpamAssassin::Conf::MISSING_REQUIRED_VALUE;
717             }
718 726         1885 unless ($value =~ /^ [+-]? \d+ (?: \. \d* )? \z/sx) {
719             return $Mail::SpamAssassin::Conf::INVALID_VALUE;
720             }
721             # it is safe to untaint now that we know the syntax is a valid number
722 0     0 0 0 $conf->{$key} = untaint_var($value) + 0;
723             }
724 0 0 0     0  
725 0         0 my ($conf, $key, $value, $line) = @_;
726              
727             local ($1,$2);
728             unless (defined $value && $value !~ /^$/) {
729             return $Mail::SpamAssassin::Conf::MISSING_REQUIRED_VALUE;
730 213     213 0 694 }
731             unless ($value =~ /^( \+? \d+ (?: \. \d* )? ) (?: \s* ([smhdw]))? \z/sxi) {
732 213 50 33     1483 return $Mail::SpamAssassin::Conf::INVALID_VALUE;
733 0         0 }
734             $value = $1;
735 213 50       1093 $value *= { s => 1, m => 60, h => 3600,
736 0         0 d => 24*3600, w => 7*24*3600 }->{lc $2} if defined $2;
737             # it is safe to untaint now that we know the syntax is a valid time interval
738             $conf->{$key} = untaint_var($value) + 0;
739 213         731 }
740              
741             my ($conf, $key, $value, $line) = @_;
742              
743 0     0 0 0 unless (defined $value && $value !~ /^$/) {
744             return $Mail::SpamAssassin::Conf::MISSING_REQUIRED_VALUE;
745 0         0 }
746 0 0 0     0  
747 0         0 # bug 4462: allow yes/1 and no/0 for boolean values
748             $value = lc $value;
749 0 0       0 if ($value eq 'yes' || $value eq '1') {
750 0         0 $value = 1;
751             }
752 0         0 elsif ($value eq 'no' || $value eq '0') {
753             $value = 0;
754 0 0       0 }
755             else {
756 0         0 return $Mail::SpamAssassin::Conf::INVALID_VALUE;
757             }
758              
759             $conf->{$key} = $value;
760 97     97 0 602 }
761              
762 97 50 33     1197 my ($conf, $key, $value, $line) = @_;
763 0         0  
764             unless (defined $value && $value !~ /^$/) {
765             return $Mail::SpamAssassin::Conf::MISSING_REQUIRED_VALUE;
766             }
767 97         360  
768 97 100 66     1064 $conf->{$key} = $value; # keep tainted
    50 33        
769 64         188 }
770              
771             my ($conf, $key, $value, $line) = @_;
772 33         79  
773             unless (defined $value && $value !~ /^$/) {
774             return $Mail::SpamAssassin::Conf::MISSING_REQUIRED_VALUE;
775 0         0 }
776              
777             push(@{$conf->{$key}}, split(' ', $value));
778 97         440 }
779              
780             my ($conf, $key, $value, $line) = @_;
781              
782 124     124 0 540 unless (defined $value && $value !~ /^$/) {
783             return $Mail::SpamAssassin::Conf::MISSING_REQUIRED_VALUE;
784 124 50 33     1098 }
785 0         0  
786             foreach my $net (split(' ', $value)) {
787             $conf->{$key}->add_cidr($net);
788 124         578 }
789             $conf->{$key.'_configured'} = 1;
790             }
791              
792 0     0 0 0 my ($conf, $key, $value, $line) = @_;
793             my($k,$v) = split(/\s+/, $value, 2);
794 0 0 0     0  
795 0         0 unless (defined $v && $v ne '') {
796             return $Mail::SpamAssassin::Conf::MISSING_REQUIRED_VALUE;
797             }
798 0         0  
  0         0  
799             $conf->{$key}->{$k} = $v; # keep tainted
800             }
801              
802 44     44 0 181 my ($conf, $key, $value, $line) = @_;
803              
804 44 50 33     371 unless (defined $value && $value !~ /^$/) {
805 0         0 return $Mail::SpamAssassin::Conf::MISSING_REQUIRED_VALUE;
806             }
807             $conf->{parser}->add_to_addrlist ($key, split (' ', $value)); # keep tainted
808 44         164 }
809 60         252  
810             my ($conf, $key, $value, $line) = @_;
811 44         199  
812             unless (defined $value && $value !~ /^$/) {
813             return $Mail::SpamAssassin::Conf::MISSING_REQUIRED_VALUE;
814             }
815 3699     3699 0 9188 $conf->{parser}->remove_from_addrlist ($key, split (' ', $value));
816 3699         15228 }
817              
818 3699 50 33     15611 my ($conf, $key, $value, $line) = @_;
819 0         0 if ( $value =~ /^"(.*?)"$/ ) { $value = $1; }
820             $conf->{$key} .= $value."\n"; # keep tainted
821             }
822 3699         14726  
823             my ($conf, $key, $value, $line) = @_;
824             unless (!defined $value || $value eq '') {
825             return $Mail::SpamAssassin::Conf::INVALID_VALUE;
826 0     0 0 0 }
827             $conf->{$key} = '';
828 0 0 0     0 }
829 0         0  
830             ###########################################################################
831 0         0  
832             my ($self, $isuserconf) = @_;
833             my $conf = $self->{conf};
834              
835 0     0 0 0 # note: this function is called once for system-wide configuration
836             # with $isuserconf set to 0, then again for user conf with $isuserconf set to 1.
837 0 0 0     0 if (!$isuserconf) {
838 0         0 $conf->{main}->call_plugins("finish_parsing_start", { conf => $conf });
839             } else {
840 0         0 $conf->{main}->call_plugins("user_conf_parsing_start", { conf => $conf });
841             }
842              
843             $self->trace_meta_dependencies();
844 1054     1054 0 2553 $self->fix_priorities();
845 1054 100       2918  
  62         265  
846 1054         4379 # don't do this if allow_user_rules is active, since it deletes entries
847             # from {tests}
848             if (!$conf->{allow_user_rules}) {
849             $self->find_dup_rules(); # must be after fix_priorities()
850 124     124 0 506 }
851 124 50 33     802  
852 0         0 dbg("config: finish parsing");
853              
854 124         539 while (my ($name, $text) = each %{$conf->{tests}}) {
855             my $type = $conf->{test_types}->{$name};
856             my $priority = $conf->{priority}->{$name} || 0;
857             $conf->{priorities}->{$priority}++;
858              
859             # eval type handling
860 91     91 0 263 if (($type & 1) == 1) {
861 91         199 if (my ($function, $args) = ($text =~ /^(\w+)\((.*?)\)$/)) {
862             my $argsref = $self->pack_eval_args($args);
863             if (!defined $argsref) {
864             $self->lint_warn("syntax error for eval function $name: $text");
865 91 50       316 next;
866 91         843 }
867             elsif ($type == $Mail::SpamAssassin::Conf::TYPE_BODY_EVALS) {
868 0         0 $conf->{body_evals}->{$priority}->{$name} = [ $function, [@$argsref] ];
869             }
870             elsif ($type == $Mail::SpamAssassin::Conf::TYPE_HEAD_EVALS) {
871 91         670 $conf->{head_evals}->{$priority}->{$name} = [ $function, [@$argsref] ];
872 91         582 }
873             elsif ($type == $Mail::SpamAssassin::Conf::TYPE_RBL_EVALS) {
874             # We don't do priorities for $Mail::SpamAssassin::Conf::TYPE_RBL_EVALS
875             # we also use the arrayref instead of the packed string
876 91 50       455 $conf->{rbl_evals}->{$name} = [ $function, [@$argsref] ];
877 91         564 }
878             elsif ($type == $Mail::SpamAssassin::Conf::TYPE_RAWBODY_EVALS) {
879             $conf->{rawbody_evals}->{$priority}->{$name} = [ $function, [@$argsref] ];
880 91         625 }
881             elsif ($type == $Mail::SpamAssassin::Conf::TYPE_FULL_EVALS) {
882 91         197 $conf->{full_evals}->{$priority}->{$name} = [ $function, [@$argsref] ];
  3787         10760  
883 3696         5022 }
884 3696   100     8567 #elsif ($type == $Mail::SpamAssassin::Conf::TYPE_URI_EVALS) {
885 3696         5418 # $conf->{uri_evals}->{$priority}->{$name} = [ $function, [@$argsref] ];
886             #}
887             else {
888 3696 100       6103 $self->lint_warn("unknown type $type for $name: $text", $name);
889 2713 50       13213 next;
890 2713         5313 }
891 2713 50       6616 }
    100          
    100          
    100          
    50          
    50          
892 0         0 else {
893 0         0 $self->lint_warn("syntax error for eval function $name: $text", $name);
894             next;
895             }
896 84         612 }
897             # non-eval tests
898             else {
899 2323         10963 if ($type == $Mail::SpamAssassin::Conf::TYPE_BODY_TESTS) {
900             $conf->{body_tests}->{$priority}->{$name} = $text;
901             }
902             elsif ($type == $Mail::SpamAssassin::Conf::TYPE_HEAD_TESTS) {
903             $conf->{head_tests}->{$priority}->{$name} = $text;
904 1         6 }
905             elsif ($type == $Mail::SpamAssassin::Conf::TYPE_META_TESTS) {
906             $conf->{meta_tests}->{$priority}->{$name} = $text;
907 0         0 }
908             elsif ($type == $Mail::SpamAssassin::Conf::TYPE_URI_TESTS) {
909             $conf->{uri_tests}->{$priority}->{$name} = $text;
910 305         1512 }
911             elsif ($type == $Mail::SpamAssassin::Conf::TYPE_RAWBODY_TESTS) {
912             $conf->{rawbody_tests}->{$priority}->{$name} = $text;
913             }
914             elsif ($type == $Mail::SpamAssassin::Conf::TYPE_FULL_TESTS) {
915             $conf->{full_tests}->{$priority}->{$name} = $text;
916 0         0 }
917 0         0 elsif ($type == $Mail::SpamAssassin::Conf::TYPE_EMPTY_TESTS) {
918             }
919             else {
920             $self->lint_warn("unknown type $type for $name: $text", $name);
921 0         0 next;
922 0         0 }
923             }
924             }
925              
926             $self->lint_trusted_networks();
927 983 100       2111  
    100          
    100          
    50          
    0          
    0          
    0          
928 231         929 if (!$isuserconf) {
929             $conf->{main}->call_plugins("finish_parsing_end", { conf => $conf });
930             } else {
931 558         1721 $conf->{main}->call_plugins("user_conf_parsing_end", { conf => $conf });
932             }
933              
934 132         477 $conf->found_any_rules(); # before we might delete {tests}
935              
936             if (!$conf->{allow_user_rules}) {
937 62         335 # free up stuff we no longer need
938             delete $conf->{tests};
939             delete $conf->{priority};
940 0         0 #test_types are needed - see bug 5503
941             #delete $conf->{test_types};
942             }
943 0         0 }
944              
945             my ($self) = @_;
946             my $conf = $self->{conf};
947             $conf->{meta_dependencies} = { };
948 0         0  
949 0         0 foreach my $name (keys %{$conf->{tests}}) {
950             next unless ($conf->{test_types}->{$name}
951             == $Mail::SpamAssassin::Conf::TYPE_META_TESTS);
952             my $alreadydone = {};
953             $self->_meta_deps_recurse($conf, $name, $name, $alreadydone);
954 91         1282 }
955             }
956 91 50       264  
957 91         667 my ($self, $conf, $toprule, $name, $alreadydone) = @_;
958              
959 0         0 # Avoid recomputing the dependencies of a rule
960             return split(' ', $conf->{meta_dependencies}->{$name}) if defined $conf->{meta_dependencies}->{$name};
961              
962 91         1055 # Obviously, don't trace empty or nonexistent rules
963             my $rule = $conf->{tests}->{$name};
964 91 50       344 unless ($rule) {
965             $conf->{meta_dependencies}->{$name} = '';
966 91         2009 return ( );
967 91         1130 }
968              
969             # Avoid infinite recursion
970             return ( ) if exists $alreadydone->{$name};
971             $alreadydone->{$name} = ( );
972              
973             my %deps;
974 91     91 0 279  
975 91         202 # Lex the rule into tokens using a rather simple RE method ...
976 91         368 my @tokens = ($rule =~ /($ARITH_EXPRESSION_LEXER)/og);
977              
978 91         194 # Go through each token in the meta rule
  91         1076  
979 3697 100       7123 my $conf_tests = $conf->{tests};
980             foreach my $token (@tokens) {
981 132         275 # has to be an alpha+numeric token
982 132         644 next if $token =~ tr{A-Za-z0-9_}{}c || substr($token,0,1) =~ tr{A-Za-z_}{}c; # even faster
983              
984             # and has to be a rule name
985             next unless exists $conf_tests->{$token};
986              
987 447     447   846 # add and recurse
988             $deps{untaint_var($token)} = ( );
989             my @subdeps = $self->_meta_deps_recurse($conf, $toprule, $token, $alreadydone);
990 447 100       942 @deps{@subdeps} = ( );
991             }
992             $conf->{meta_dependencies}->{$name} = join (' ', keys %deps);
993 443         1029 return keys %deps;
994 443 50       978 }
995 0         0  
996 0         0 my ($self) = @_;
997             my $conf = $self->{conf};
998              
999             die unless $conf->{meta_dependencies}; # order requirement
1000 443 50       872 my $pri = $conf->{priority};
1001 443         673  
1002             # sort into priority order, lowest first -- this way we ensure that if we
1003 443         484 # rearrange the pri of a rule early on, we cannot accidentally increase its
1004             # priority later.
1005             foreach my $rule (sort {
1006 443         9782 $pri->{$a} <=> $pri->{$b}
1007             } keys %{$pri})
1008             {
1009 443         1090 # we only need to worry about meta rules -- they are the
1010 443         806 # only type of rules which depend on other rules
1011             my $deps = $conf->{meta_dependencies}->{$rule};
1012 3860 100 100     11353 next unless (defined $deps);
1013              
1014             my $basepri = $pri->{$rule};
1015 1637 100       3923 foreach my $dep (split ' ', $deps) {
1016             my $deppri = $pri->{$dep};
1017             if ($deppri > $basepri) {
1018 315         872 dbg("rules: $rule (pri $basepri) requires $dep (pri $deppri): fixed");
1019 315         1298 $pri->{$dep} = $basepri;
1020 315         652 }
1021             }
1022 443         1281 }
1023 443         1626 }
1024              
1025             my ($self) = @_;
1026             my $conf = $self->{conf};
1027 91     91 0 242  
1028 91         205 my %names_for_text;
1029             my %dups;
1030 91 50       278 while (my ($name, $text) = each %{$conf->{tests}}) {
1031 91         276 my $type = $conf->{test_types}->{$name};
1032              
1033             # skip eval and empty tests
1034             next if ($type & 1) ||
1035             ($type eq $Mail::SpamAssassin::Conf::TYPE_EMPTY_TESTS);
1036 91         252  
1037 9041         12569 my $tf = ($conf->{tflags}->{$name}||''); $tf =~ s/\s+/ /gs;
1038 91         1306 # ensure similar, but differently-typed, rules are not marked as dups;
1039             # take tflags into account too due to "tflags multiple"
1040             $text = "$type\t$text\t$tf";
1041              
1042 3700         4636 if (defined $names_for_text{$text}) {
1043 3700 100       5544 $names_for_text{$text} .= " ".$name;
1044             $dups{$text} = undef; # found (at least) one
1045 443         573 } else {
1046 443         1017 $names_for_text{$text} = $name;
1047 317         450 }
1048 317 100       710 }
1049 7         166  
1050 7         21 foreach my $text (keys %dups) {
1051             my $first;
1052             my $first_pri;
1053             my @names = sort {$a cmp $b} split(' ', $names_for_text{$text});
1054             foreach my $name (@names) {
1055             my $priority = $conf->{priority}->{$name} || 0;
1056              
1057 91     91 0 239 if (!defined $first || $priority < $first_pri) {
1058 91         213 $first_pri = $priority;
1059             $first = $name;
1060 91         182 }
1061             }
1062 91         240 # $first is now the earliest-occurring rule. mark others as dups
  3788         10317  
1063 3697         4466  
1064             my @dups;
1065             foreach my $name (@names) {
1066 3697 100 66     8481 next if $name eq $first;
1067             push @dups, $name;
1068             delete $conf->{tests}->{$name};
1069 984   100     2450 }
  984         1576  
1070              
1071             dbg("rules: $first merged duplicates: ".join(' ', @dups));
1072 984         2378 $conf->{duplicate_rules}->{$first} = \@dups;
1073             }
1074 984 100       1982 }
1075 1         5  
1076 1         4 # Deprecated function
1077             warn "deprecated function pack_eval_method() used\n";
1078 983         3262 return ('',undef);
1079             }
1080              
1081             my ($self, $args) = @_;
1082 91         688  
1083 1         3 return [] if $args =~ /^\s+$/;
1084              
1085 1         5 # bug 4419: Parse quoted strings, unquoted alphanumerics/floats,
  1         5  
1086 1         4 # unquoted IPv4 and IPv6 addresses, and unquoted common domain names.
1087 2   50     15 # s// is used so that we can determine whether or not we successfully
1088             # parsed ALL arguments.
1089 2 100 66     16 my @args;
1090 1         2 local($1,$2,$3);
1091 1         3 while ($args =~ s/^\s* (?: (['"]) (.*?) \1 | ( [\d\.:A-Za-z-]+? ) )
1092             \s* (?: , \s* | $ )//x) {
1093             # DO NOT UNTAINT THESE ARGS
1094             # The eval function that handles these should do that as necessary,
1095             # we have no idea what acceptable arguments look like here.
1096 1         15 push @args, defined $2 ? $2 : $3;
1097 1         2 }
1098 2 100       6  
1099 1         4 if ($args ne '') {
1100 1         4 return undef; ## no critic (ProhibitExplicitReturnUndef)
1101             }
1102              
1103 1         8 return \@args;
1104 1         11 }
1105              
1106             ###########################################################################
1107              
1108             my ($self) = @_;
1109             my $conf = $self->{conf};
1110 0     0 0 0  
1111 0         0 # validate trusted_networks and internal_networks, bug 4760.
1112             # check that all internal_networks are listed in trusted_networks
1113             # too. do the same for msa_networks, but check msa_networks against
1114             # internal_networks if trusted_networks aren't defined
1115 2713     2713 0 5360  
1116             my ($nt, $matching_against);
1117 2713 50       5561 if ($conf->{trusted_networks_configured}) {
1118             $nt = $conf->{trusted_networks};
1119             $matching_against = 'trusted_networks';
1120             } elsif ($conf->{internal_networks_configured}) {
1121             $nt = $conf->{internal_networks};
1122             $matching_against = 'internal_networks';
1123 2713         2994 } else {
1124 2713         6750 return;
1125 2713         7498 }
1126              
1127             foreach my $net_type ('internal_networks', 'msa_networks') {
1128             next unless $conf->{"${net_type}_configured"};
1129             next if $net_type eq $matching_against;
1130 1554 50       6832  
1131             my $replace_nets;
1132             my @valid_net_list;
1133 2713 50       4955 my $net_list = $conf->{$net_type};
1134 0         0  
1135             foreach my $net (@{$net_list->{nets}}) {
1136             # don't check to see if an excluded network is included - that's senseless
1137 2713         7102 if (!$net->{exclude} && !$nt->contains_net($net)) {
1138             my $msg = "$matching_against doesn't contain $net_type entry '".
1139             ($net->{as_string})."'";
1140              
1141             $self->lint_warn($msg, undef); # complain
1142             $replace_nets = 1; # and omit it from the new internal set
1143 91     91 0 265 }
1144 91         222 else {
1145             push @valid_net_list, $net;
1146             }
1147             }
1148              
1149             if ($replace_nets) {
1150             # something was invalid. replace the old nets list with a fixed version
1151 91         208 # (which may be empty)
1152 91 100       364 $net_list->{nets} = \@valid_net_list;
    100          
1153 28         73 }
1154 28         54 }
1155             }
1156 1         3  
1157 1         3 ###########################################################################
1158              
1159 62         164 my ($self, $name, $text, $type) = @_;
1160             my $conf = $self->{conf};
1161              
1162 29         94 # Don't allow invalid names ...
1163 58 100       218 if ($name !~ IS_RULENAME) {
1164 16 100       61 $self->lint_warn("config: error: rule '$name' has invalid characters ".
1165             "(not Alphanumeric + Underscore + starting with a non-digit)\n", $name);
1166 15         29 return;
1167             }
1168 15         39  
1169             # Also set a hard limit for ALL rules (rule names longer than 40
1170 15         23 # characters throw warnings). Check this separately from the above
  15         55  
1171             # pattern to avoid vague error messages.
1172 38 100 100     205 if (length $name > 100) {
1173             $self->lint_warn("config: error: rule '$name' is too long ".
1174 4         27 "(recommended maximum length is 22 characters)\n", $name);
1175             return;
1176 4         97 }
1177 4         13  
1178             # Warn about, but use, long rule names during --lint
1179             if ($conf->{lint_rules}) {
1180 34         78 if (length($name) > 40 && $name !~ /^__/ && $name !~ /^T_/) {
1181             $self->lint_warn("config: warning: rule name '$name' is over 40 chars ".
1182             "(recommended maximum length is 22 characters)\n", $name);
1183             }
1184 15 100       59 }
1185              
1186             # parameter to compile_regexp()
1187 4         37 my $ignore_amre =
1188             $self->{conf}->{lint_rules} ||
1189             $self->{conf}->{ignore_always_matching_regexps};
1190              
1191             # all of these rule types are regexps
1192             if ($type == $Mail::SpamAssassin::Conf::TYPE_BODY_TESTS ||
1193             $type == $Mail::SpamAssassin::Conf::TYPE_FULL_TESTS ||
1194             $type == $Mail::SpamAssassin::Conf::TYPE_RAWBODY_TESTS ||
1195 3697     3697 0 10279 $type == $Mail::SpamAssassin::Conf::TYPE_URI_TESTS)
1196 3697         6432 {
1197             my ($rec, $err) = compile_regexp($text, 1, $ignore_amre);
1198             if (!$rec) {
1199 3697 50       10542 $self->lint_warn("config: invalid regexp for $name '$text': $err", $name);
1200 0         0 return;
1201             }
1202 0         0 $conf->{test_qrs}->{$name} = $rec;
1203             }
1204             elsif ($type == $Mail::SpamAssassin::Conf::TYPE_HEAD_TESTS)
1205             {
1206             local($1,$2,$3);
1207             # RFC 5322 section 3.6.8, ftext printable US-ASCII chars not including ":"
1208 3697 50       8695 # no re "strict"; # since perl 5.21.8: Ranges of ASCII printables...
1209 0         0 if ($text =~ /^exists:(.*)/) {
1210             my $hdr = $1;
1211 0         0 # check :addr etc header options
1212             # $hdr used in eval text, validate carefully
1213             if ($hdr !~ /^[\w.-]+:?$/) {
1214             $self->lint_warn("config: invalid head test $name header: $hdr");
1215 3697 100       7266 return;
1216 1888 0 33     4186 }
      33        
1217 0         0 $hdr =~ s/:$//;
1218             $conf->{test_opt_header}->{$name} = $hdr;
1219             $conf->{test_opt_exists}->{$name} = 1;
1220             } else {
1221             # $hdr used in eval text, validate carefully
1222             if ($text !~ /^([\w.-]+(?:\:|(?:\:[a-z]+){1,2})?)\s*([=!]~)\s*(.+)$/) {
1223             $self->lint_warn("config: invalid head test $name: $text");
1224             return;
1225 3697   66     8936 }
1226             my ($hdr, $op, $pat) = ($1, $2, $3);
1227             $hdr =~ s/:$//;
1228 3697 100 66     21332 if ($pat =~ s/\s+\[if-unset:\s+(.+)\]$//) {
    100 66        
    100 66        
1229             $conf->{test_opt_unset}->{$name} = $1;
1230             }
1231             my ($rec, $err) = compile_regexp($pat, 1, $ignore_amre);
1232             if (!$rec) {
1233 294         1136 $self->lint_warn("config: invalid regexp for $name '$pat': $err", $name);
1234 294 50       834 return;
1235 0         0 }
1236 0         0 $conf->{test_qrs}->{$name} = $rec;
1237             $conf->{test_opt_header}->{$name} = $hdr;
1238 294         1088 $conf->{test_opt_neg}->{$name} = 1 if $op eq '!~';
1239             }
1240             }
1241             elsif ($type == $Mail::SpamAssassin::Conf::TYPE_META_TESTS)
1242 558         1670 {
1243             if ($self->is_meta_valid($name, $text)) {
1244             # Untaint now once and not repeatedly later
1245 558 100       1708 $text = untaint_var($text);
1246 62         294 } else {
1247             return;
1248             }
1249 62 50       438 }
1250 0         0  
1251 0         0 $conf->{tests}->{$name} = $text;
1252             $conf->{test_types}->{$name} = $type;
1253 62         198  
1254 62         288 if ($name =~ /AUTOLEARNTEST/i) {
1255 62         391 dbg("config: auto-learn: $name has type $type = $conf->{test_types}->{$name} during add_test\n");
1256             }
1257              
1258 496 50       2864
1259 0         0 if ($type == $Mail::SpamAssassin::Conf::TYPE_META_TESTS) {
1260 0         0 $conf->{priority}->{$name} ||= 500;
1261             }
1262 496         2239 else {
1263 496         876 $conf->{priority}->{$name} ||= 0;
1264 496 100       2114 }
1265 124         624 $conf->{priority}->{$name} ||= 0;
1266             $conf->{source_file}->{$name} = $self->{currentfile};
1267 496         1765  
1268 496 50       1192 if ($conf->{main}->{keep_config_parsing_metadata}) {
1269 0         0 $conf->{if_stack}->{$name} = $self->get_if_stack_as_string();
1270 0         0  
1271             if ($self->{file_scoped_attrs}->{testrules}) {
1272 496         1558 $conf->{testrules}->{$name} = 1; # used in build/mkupdates/listpromotable
1273 496         1504 }
1274 496 100       2724 }
1275              
1276             # if we found this rule in a user_prefs file, it's a user rule -- note that
1277             # we may need to recompile the rule code for this type (if they've already
1278             # been compiled, e.g. in spamd).
1279 132 50       607 #
1280             # Note: the want_rebuild_for_type 'flag' is actually a counter; it is decremented
1281 132         415 # after each scan. This ensures that we always recompile at least once more;
1282             # once to *define* the rule, and once afterwards to *undefine* the rule in the
1283 0         0 # compiled ruleset again.
1284             #
1285             # If two consecutive scans use user rules, that's ok -- the second one will
1286             # reset the counter, and we'll still recompile just once afterwards to undefine
1287 3697         11601 # the rule again.
1288 3697         6686 #
1289             if ($self->{scoresonly}) {
1290 3697 50       7576 $conf->{want_rebuild_for_type}->{$type} = 2;
1291 0         0 $conf->{user_defined_rules}->{$name} = 1;
1292             }
1293             }
1294              
1295 3697 100       5817 my ($self, $name, $ok_or_fail, $string) = @_;
1296 132   50     815 my $conf = $self->{conf};
1297              
1298             if ($conf->{regression_tests}->{$name}) {
1299 3565   50     13243 push @{$conf->{regression_tests}->{$name}}, [$ok_or_fail, $string];
1300             }
1301 3697   100     14045 else {
1302 3697         8871 # initialize the array, and create one element
1303             $conf->{regression_tests}->{$name} = [ [$ok_or_fail, $string] ];
1304 3697 50       7659 }
1305 0         0 }
1306              
1307 0 0       0 my ($self, $name, $rule) = @_;
1308 0         0  
1309             # $meta is a degenerate translation of the rule, replacing all variables (i.e. rule names) with 0.
1310             my $meta = '';
1311              
1312             # Paranoid check (Bug #7557)
1313             if ($rule =~ /(?:\:\:|->)/) {
1314             warn("config: invalid meta $name rule: $rule") ;
1315             return 0;
1316             }
1317              
1318             # Process expandable functions before lexing
1319             $rule =~ s/${META_RULES_MATCHING_RE}/ 0 /g;
1320              
1321             # Lex the rule into tokens using a rather simple RE method ...
1322             my @tokens = ($rule =~ /($ARITH_EXPRESSION_LEXER)/og);
1323              
1324             # Go through each token in the meta rule
1325 3697 50       19373 foreach my $token (@tokens) {
1326 0         0 # If the token is a syntactically legal rule name, make it zero
1327 0         0 if ($token =~ IS_RULENAME) {
1328             $meta .= "0 ";
1329             }
1330             # if it is a (decimal) number or a string of 1 or 2 punctuation
1331             # characters (i.e. operators) tack it onto the degenerate rule
1332 0     0 0 0 elsif ($token =~ /^(\d+(?:\.\d+)?|[[:punct:]]{1,2})\z/s) {
1333 0         0 $meta .= "$token ";
1334             }
1335 0 0       0 # Skip anything unknown (Bug #7557)
1336 0         0 else {
  0         0  
1337             $self->lint_warn("config: invalid meta $name token: $token", $name);
1338             return 0;
1339             }
1340 0         0 }
1341              
1342             $meta = untaint_var($meta); # was carefully checked
1343             my $evalstr = 'my $x = '.$meta.'; 1;';
1344             if (eval $evalstr) {
1345 132     132 0 518 return 1;
1346             }
1347             my $err = $@ ne '' ? $@ : "errno=$!"; chomp $err;
1348 132         338 $err =~ s/\s+(?:at|near)\b.*//s;
1349             $err =~ s/Illegal division by zero/division by zero possible/i;
1350             $self->lint_warn("config: invalid expression for rule $name: \"$rule\": $err\n", $name);
1351 132 50       654 return 0;
1352 0         0 }
1353 0         0  
1354             # Deprecated functions, leave just in case..
1355             my ($self, $rule, $re) = @_;
1356             warn "deprecated is_delimited_regexp_valid() called, use compile_regexp()\n";
1357 132         912 my ($rec, $err) = compile_regexp($re, 1, 1);
1358             return $rec;
1359             }
1360 132         5145 my ($self, $rule, $re) = @_;
1361             warn "deprecated is_regexp_valid() called, use compile_regexp()\n";
1362             my ($rec, $err) = compile_regexp($re, 1, 1);
1363 132         694 return $rec;
1364             }
1365 817 100       2625 warn "deprecated is_always_matching_regexp() called\n";
    50          
1366 334         751 return;
1367             }
1368              
1369             ###########################################################################
1370              
1371 483         1177 my ($self, $singlelist, @addrs) = @_;
1372             my $conf = $self->{conf};
1373              
1374             foreach my $addr (@addrs) {
1375 0         0 $addr = lc $addr;
1376 0         0 my $re = $addr;
1377             $re =~ s/[\000\\\(]/_/gs; # paranoia
1378             $re =~ s/([^\*\?_a-zA-Z0-9])/\\$1/g; # escape any possible metachars
1379             $re =~ tr/?/./; # "?" -> "."
1380 132         514 $re =~ s/\*+/\.\*/g; # "*" -> "any string"
1381 132         481 $conf->{$singlelist}->{$addr} = "^${re}\$";
1382 132 50       7793 }
1383 132         851 }
1384              
1385 0 0       0 my ($self, $listname, $addr, $domain) = @_;
  0         0  
1386 0         0 my $conf = $self->{conf};
1387 0         0  
1388 0         0 $domain = lc $domain;
1389 0         0 $addr = lc $addr;
1390             if ($conf->{$listname}->{$addr}) {
1391             push @{$conf->{$listname}->{$addr}{domain}}, $domain;
1392             }
1393             else {
1394 0     0 0 0 my $re = $addr;
1395 0         0 $re =~ s/[\000\\\(]/_/gs; # paranoia
1396 0         0 $re =~ s/([^\*\?_a-zA-Z0-9])/\\$1/g; # escape any possible metachars
1397 0         0 $re =~ tr/?/./; # "?" -> "."
1398             $re =~ s/\*+/\.\*/g; # "*" -> "any string"
1399             $conf->{$listname}->{$addr}{re} = "^${re}\$";
1400 0     0 0 0 $conf->{$listname}->{$addr}{domain} = [ $domain ];
1401 0         0 }
1402 0         0 }
1403 0         0  
1404             my ($self, $singlelist, @addrs) = @_;
1405             my $conf = $self->{conf};
1406 0     0 0 0  
1407 0         0 foreach my $addr (@addrs) {
1408             delete($conf->{$singlelist}->{lc $addr});
1409             }
1410             }
1411              
1412             my ($self, $listname, @addrs) = @_;
1413 34     34 0 56 my $conf = $self->{conf};
1414 34         41  
1415             foreach my $addr (@addrs) {
1416 34         49 delete($conf->{$listname}->{lc $addr});
1417 34         44 }
1418 34         36 }
1419 34         55  
1420 34         161 add_to_addrlist_rcvd(@_);
1421 34         56 }
1422 34         51  
1423 34         140 my ($self, $listname, $addr, $domain) = @_;
1424             my $conf = $self->{conf};
1425             my $conf_lname = $conf->{$listname};
1426              
1427             $addr = lc $addr;
1428 0     0 0 0 if ($conf_lname->{$addr}) {
1429 0         0 $domain = lc $domain;
1430             my $domains_listref = $conf_lname->{$addr}{domain};
1431 0         0 # removing $domain from the list
1432 0         0 my @replacement = grep { lc $_ ne $domain } @$domains_listref;
1433 0 0       0 if (!@replacement) { # nothing left, remove the entire addr entry
1434 0         0 delete($conf_lname->{$addr});
  0         0  
1435             } elsif (@replacement != @$domains_listref) { # anything changed?
1436             $conf_lname->{$addr}{domain} = \@replacement;
1437 0         0 }
1438 0         0 }
1439 0         0 }
1440 0         0  
1441 0         0  
1442 0         0 ###########################################################################
1443 0         0  
1444             my ($self, $path) = @_;
1445              
1446             # the path may be specified as "~/foo", so deal with that
1447             $path = $self->{conf}->{main}->sed_path($path);
1448 0     0 0 0  
1449 0         0 if (!File::Spec->file_name_is_absolute ($path)) {
1450             my ($vol, $dirs, $file) = File::Spec->splitpath ($self->{currentfile});
1451 0         0 $path = File::Spec->catpath ($vol, $dirs, $path);
1452 0         0 dbg("config: fixed relative path: $path");
1453             }
1454             return $path;
1455             }
1456              
1457 0     0 0 0 ###########################################################################
1458 0         0  
1459             my ($self, $msg, $rule, $iserror) = @_;
1460 0         0  
1461 0         0 if (!defined $iserror) { $iserror = 1; }
1462              
1463             if ($self->{conf}->{main}->{lint_callback}) {
1464             $self->{conf}->{main}->{lint_callback}->(
1465             msg => $msg,
1466 0     0 0 0 rule => $rule,
1467             iserror => $iserror
1468             );
1469             }
1470 0     0 0 0 elsif ($self->{conf}->{lint_rules}) {
1471 0         0 warn $msg."\n";
1472 0         0 }
1473             else {
1474 0         0 info($msg);
1475 0 0       0 }
1476 0         0  
1477 0         0 if ($iserror) {
1478             $self->{conf}->{errors}++;
1479 0         0 }
  0         0  
1480 0 0       0 }
    0          
1481 0         0  
1482             ###########################################################################
1483 0         0  
1484             my ($self) = @_;
1485             return join ' ', map {
1486             $_->{conditional}
1487             } @{$self->{if_stack}};
1488             }
1489              
1490             ###########################################################################
1491              
1492 0     0 0 0 1;