@ISA
}
;
@ISA
=
qw()
;
sub
new {
my
$class
=
shift
;
$class
=
ref
(
$class
) ||
$class
;
my
(
$conf
) =
@_
;
my
$self
= {
'conf'
=>
$conf
};
$self
->{command_luts} = { };
$self
->{command_luts}->{frequent} = { };
$self
->{command_luts}->{remaining} = { };
bless
(
$self
,
$class
);
$self
;
}
sub
register_commands {
my
(
$self
,
$arrref
) =
@_
;
my
$conf
=
$self
->{conf};
$self
->set_defaults_from_command_list(
$arrref
);
$self
->build_command_luts(
$arrref
);
push
(@{
$conf
->{registered_commands}}, @{
$arrref
});
}
sub
set_defaults_from_command_list {
my
(
$self
,
$arrref
) =
@_
;
my
$conf
=
$self
->{conf};
foreach
my
$cmd
(@{
$arrref
}) {
if
(
exists
(
$cmd
->{
default
})) {
$conf
->{
$cmd
->{setting}} =
$cmd
->{
default
};
}
}
}
sub
build_command_luts {
my
(
$self
,
$arrref
) =
@_
;
my
$conf
=
$self
->{conf};
my
$set
;
foreach
my
$cmd
(@{
$arrref
}) {
if
(
$cmd
->{is_frequent}) {
$set
=
'frequent'
; }
else
{
$set
=
'remaining'
; }
my
$cmdname
=
$cmd
->{command} ||
$cmd
->{setting};
foreach
my
$name
(
$cmdname
, @{
$cmd
->{aliases}}) {
$self
->{command_luts}->{
$set
}->{
$name
} =
$cmd
;
}
}
}
sub
parse {
my
(
$self
,
undef
,
$scoresonly
) =
@_
;
$self
->{scoresonly} =
$scoresonly
;
my
$conf
=
$self
->{conf};
my
$lang
=
$ENV
{
'LANGUAGE'
};
if
(
$lang
) {
$lang
=~ s/:.*$//;
}
$lang
||=
$ENV
{
'LC_ALL'
};
$lang
||=
$ENV
{
'LC_MESSAGES'
};
$lang
||=
$ENV
{
'LANG'
};
$lang
||=
'C'
;
if
(
$lang
=~ /^(C|POSIX)$/) {
$lang
=
'en_US'
;
}
else
{
$lang
=~ s/[@.+,].*$//;
}
my
$lut_frequent
=
$self
->{command_luts}->{frequent};
my
$lut_remaining
=
$self
->{command_luts}->{remaining};
my
%migrated_keys
=
map
{
$_
=> 1 }
@Mail::SpamAssassin::Conf::MIGRATED_SETTINGS
;
$self
->{currentfile} =
'(no file)'
;
my
$skip_parsing
= 0;
my
@curfile_stack
= ();
my
@if_stack
= ();
my
@conf_lines
=
split
(/\n/,
$_
[1]);
my
$line
;
while
(
defined
(
$line
=
shift
@conf_lines
)) {
local
($1);
$line
=~ s/(?<!\\)
$line
=~ s/^\s+//;
$line
=~ s/\s+$//;
next
unless
(
$line
);
if
(
$line
=~ s/^lang\s+(\S+)\s+//) {
next
if
(
$lang
!~ /^$1/i); }
my
(
$key
,
$value
) =
split
(/\s+/,
$line
, 2);
$key
=
lc
$key
;
$key
=~ s/-/_/g;
$value
=
''
unless
defined
(
$value
);
$value
=~ /^(.*)$/;
$value
= $1;
my
$parse_error
;
if
(
$key
eq
'file'
) {
if
(
$value
=~ /^start\s+(.+)$/) {
push
(
@curfile_stack
,
$self
->{currentfile});
$self
->{currentfile} = $1;
next
;
}
if
(
$value
=~ /^end\s/) {
if
(
scalar
@if_stack
> 0) {
my
$cond
=
pop
@if_stack
;
if
(
$cond
->{type} eq
'if'
) {
warn
"config: unclosed 'if' in "
.
$self
->{currentfile}.
": if "
.
$cond
->{conditional}.
"\n"
;
}
else
{
die
"config: unknown 'if' type: "
.
$cond
->{type}.
"\n"
;
}
$conf
->{errors}++;
@if_stack
= ();
}
$skip_parsing
= 0;
my
$curfile
=
pop
@curfile_stack
;
if
(
defined
$curfile
) {
$self
->{currentfile} =
$curfile
;
}
else
{
$self
->{currentfile} =
'(no file)'
;
}
next
;
}
}
if
(
$key
eq
'include'
) {
$value
=
$self
->fix_path_relative_to_current_file(
$value
);
my
$text
=
$conf
->{main}->read_cf(
$value
,
'included file'
);
unshift
(
@conf_lines
,
split
(/\n/,
$text
));
next
;
}
if
(
$key
eq
'ifplugin'
) {
$self
->handle_conditional (
$key
,
"plugin ($value)"
,
\
@if_stack
, \
$skip_parsing
);
next
;
}
if
(
$key
eq
'if'
) {
$self
->handle_conditional (
$key
,
$value
,
\
@if_stack
, \
$skip_parsing
);
next
;
}
if
(
$key
eq
'endif'
) {
my
$lastcond
=
pop
@if_stack
;
$skip_parsing
=
$lastcond
->{skip_parsing};
next
;
}
next
if
$skip_parsing
;
if
(
$key
eq
'require_version'
) {
next
if
(
$value
eq
"\@\@VERSION\@\@"
);
my
$ver
=
$Mail::SpamAssassin::VERSION
;
if
(
$ver
ne
$value
) {
warn
"config: configuration file \"$self->{currentfile}\" requires version "
.
"$value of SpamAssassin, but this is code version "
.
"$ver. Maybe you need to use "
.
"the -C switch, or remove the old config files? "
.
"Skipping this file"
;
$skip_parsing
= 1;
$conf
->{errors}++;
}
next
;
}
my
$cmd
=
$lut_frequent
->{
$key
};
if
(!
$cmd
) {
$cmd
=
$lut_remaining
->{
$key
};
}
if
(
$cmd
) {
if
(
$self
->{scoresonly}) {
if
(
$cmd
->{is_priv} && !
$conf
->{allow_user_rules}) {
info(
"config: not parsing, 'allow_user_rules' is 0: $line"
);
goto
failed_line;
}
if
(
$cmd
->{is_admin}) {
info(
"config: not parsing, administrator setting: $line"
);
goto
failed_line;
}
}
if
(!
$cmd
->{code}) {
if
(!
$self
->setup_default_code_cb(
$cmd
)) {
goto
failed_line;
}
}
my
$ret
= &{
$cmd
->{code}} (
$conf
,
$cmd
->{setting},
$value
,
$line
);
if
(
$ret
&&
$ret
eq
$Mail::SpamAssassin::Conf::INVALID_VALUE
)
{
$parse_error
=
"config: SpamAssassin failed to parse line, "
.
"\"$value\" is not valid for \"$key\", "
.
"skipping: $line"
;
goto
failed_line;
}
elsif
(
$ret
&&
$ret
eq
$Mail::SpamAssassin::Conf::MISSING_REQUIRED_VALUE
)
{
$parse_error
=
"config: SpamAssassin failed to parse line, "
.
"no value provided for \"$key\", "
.
"skipping: $line"
;
goto
failed_line;
}
else
{
next
;
}
}
if
(
$conf
->{main}->call_plugins(
"parse_config"
, {
key
=>
$key
,
value
=>
$value
,
line
=>
$line
,
conf
=>
$conf
,
user_config
=>
$self
->{scoresonly}
}))
{
next
;
}
failed_line:
my
$msg
=
$parse_error
;
my
$is_error
= 1;
if
(!
$msg
) {
if
(
$migrated_keys
{
$key
}) {
$is_error
= 0;
$msg
=
"config: failed to parse, now a plugin, skipping: $line"
;
}
else
{
$msg
=
"config: failed to parse line, skipping: $line"
;
}
}
if
(
$conf
->{lint_rules}) {
warn
$msg
.
"\n"
;
}
else
{
info(
$msg
);
}
if
(
$is_error
) {
$conf
->{errors}++;
}
}
$self
->lint_check();
$self
->set_default_scores();
delete
$self
->{scoresonly};
}
sub
handle_conditional {
my
(
$self
,
$key
,
$value
,
$if_stack_ref
,
$skip_parsing_ref
) =
@_
;
my
$conf
=
$self
->{conf};
my
$lexer
= ARITH_EXPRESSION_LEXER;
my
@tokens
= (
$value
=~ m/(
$lexer
)/g);
my
$eval
=
''
;
my
$bad
= 0;
foreach
my
$token
(
@tokens
) {
if
(
$token
=~ /^(\W+|[\-\+\d\.]+)$/) {
$eval
.= $1.
" "
;
}
elsif
(
$token
eq
'plugin'
) {
$eval
.=
"\$self->cond_clause_plugin_loaded"
;
}
elsif
(
$token
eq
'version'
) {
$eval
.=
$Mail::SpamAssassin::VERSION
.
" "
;
}
elsif
(
$token
=~ /^(\w[\w\:]+)$/) {
$eval
.=
"\"$1\" "
;
}
else
{
$bad
++;
warn
"config: unparseable chars in 'if $value': '$token'\n"
;
}
}
if
(
$bad
) {
$conf
->{errors}++;
return
-1;
}
push
(@{
$if_stack_ref
}, {
type
=>
'if'
,
conditional
=>
$value
,
skip_parsing
=>
$$skip_parsing_ref
});
if
(
eval
$eval
) {
}
else
{
$$skip_parsing_ref
= 1;
}
}
sub
cond_clause_plugin_loaded {
return
$_
[0]->{conf}->{plugins_loaded}->{
$_
[1]};
}
sub
lint_check {
my
(
$self
) =
@_
;
my
$conf
=
$self
->{conf};
my
(
$k
,
$v
);
if
(
$conf
->{lint_rules})
{
while
( (
$k
,
$v
) =
each
%{
$conf
->{descriptions}} ) {
if
(!
exists
$conf
->{tests}->{
$k
}) {
warn
"config: warning: description exists for non-existent rule $k\n"
;
$conf
->{errors}++;
}
}
while
(
my
(
$sk
) =
each
%{
$conf
->{scores}} ) {
if
(!
exists
$conf
->{tests}->{
$sk
}) {
warn
"config: warning: score set for non-existent rule $sk\n"
;
$conf
->{errors}++;
}
}
}
}
sub
set_default_scores {
my
(
$self
) =
@_
;
my
$conf
=
$self
->{conf};
my
(
$k
,
$v
);
while
( (
$k
,
$v
) =
each
%{
$conf
->{tests}} ) {
if
( !
exists
$conf
->{scores}->{
$k
} ) {
my
$set_score
= (
$k
=~/^T_/) ? 0.01 : 1.0;
$set_score
= -
$set_score
if
(
$conf
->{tflags}->{
$k
} =~ /\bnice\b/ );
for
my
$index
(0..3) {
$conf
->{scoreset}->[
$index
]->{
$k
} =
$set_score
;
}
}
}
}
sub
setup_default_code_cb {
my
(
$self
,
$cmd
) =
@_
;
my
$type
=
$cmd
->{type};
if
(
$type
==
$Mail::SpamAssassin::Conf::CONF_TYPE_STRING
) {
$cmd
->{code} = \
&set_string_value
;
}
elsif
(
$type
==
$Mail::SpamAssassin::Conf::CONF_TYPE_BOOL
) {
$cmd
->{code} = \
&set_bool_value
;
}
elsif
(
$type
==
$Mail::SpamAssassin::Conf::CONF_TYPE_NUMERIC
) {
$cmd
->{code} = \
&set_numeric_value
;
}
elsif
(
$type
==
$Mail::SpamAssassin::Conf::CONF_TYPE_HASH_KEY_VALUE
) {
$cmd
->{code} = \
&set_hash_key_value
;
}
elsif
(
$type
==
$Mail::SpamAssassin::Conf::CONF_TYPE_ADDRLIST
) {
$cmd
->{code} = \
&set_addrlist_value
;
}
elsif
(
$type
==
$Mail::SpamAssassin::Conf::CONF_TYPE_TEMPLATE
) {
$cmd
->{code} = \
&set_template_append
;
}
else
{
warn
"config: unknown conf type $type!"
;
return
0;
}
return
1;
}
sub
set_numeric_value {
my
(
$conf
,
$key
,
$value
,
$line
) =
@_
;
unless
(
defined
$value
&&
$value
!~ /^$/) {
return
$Mail::SpamAssassin::Conf::MISSING_REQUIRED_VALUE
;
}
unless
(
$value
=~ /^-?\d+(?:\.\d+)?$/) {
return
$Mail::SpamAssassin::Conf::INVALID_VALUE
;
}
$conf
->{
$key
} =
$value
+0.0;
}
sub
set_bool_value {
my
(
$conf
,
$key
,
$value
,
$line
) =
@_
;
unless
(
defined
$value
&&
$value
!~ /^$/) {
return
$Mail::SpamAssassin::Conf::MISSING_REQUIRED_VALUE
;
}
unless
(
$value
=~ /^[01]$/) {
return
$Mail::SpamAssassin::Conf::INVALID_VALUE
;
}
$conf
->{
$key
} =
$value
+0;
}
sub
set_string_value {
my
(
$conf
,
$key
,
$value
,
$line
) =
@_
;
unless
(
defined
$value
&&
$value
!~ /^$/) {
return
$Mail::SpamAssassin::Conf::MISSING_REQUIRED_VALUE
;
}
$conf
->{
$key
} =
$value
;
}
sub
set_hash_key_value {
my
(
$conf
,
$key
,
$value
,
$line
) =
@_
;
my
(
$k
,
$v
) =
split
(/\s+/,
$value
, 2);
unless
(
defined
$v
&&
$v
ne
''
) {
return
$Mail::SpamAssassin::Conf::MISSING_REQUIRED_VALUE
;
}
$conf
->{
$key
}->{
$k
} =
$v
;
}
sub
set_addrlist_value {
my
(
$conf
,
$key
,
$value
,
$line
) =
@_
;
unless
(
defined
$value
&&
$value
!~ /^$/) {
return
$Mail::SpamAssassin::Conf::MISSING_REQUIRED_VALUE
;
}
$conf
->{parser}->add_to_addrlist (
$key
,
split
(
' '
,
$value
));
}
sub
remove_addrlist_value {
my
(
$conf
,
$key
,
$value
,
$line
) =
@_
;
unless
(
defined
$value
&&
$value
!~ /^$/) {
return
$Mail::SpamAssassin::Conf::MISSING_REQUIRED_VALUE
;
}
$conf
->{parser}->remove_from_addrlist (
$key
,
split
(
' '
,
$value
));
}
sub
set_template_append {
my
(
$conf
,
$key
,
$value
,
$line
) =
@_
;
if
(
$value
=~ /^
"(.*?)"
$/ ) {
$value
= $1; }
$conf
->{
$key
} .=
$value
.
"\n"
;
}
sub
set_template_clear {
my
(
$conf
,
$key
,
$value
,
$line
) =
@_
;
$conf
->{
$key
} =
''
;
}
sub
finish_parsing {
my
(
$self
) =
@_
;
my
$conf
=
$self
->{conf};
while
(
my
(
$name
,
$text
) =
each
%{
$conf
->{tests}}) {
my
$type
=
$conf
->{test_types}->{
$name
};
my
$priority
=
$conf
->{priority}->{
$name
} || 0;
$conf
->{priorities}->{
$priority
}++;
if
((
$type
& 1) == 1) {
my
@args
;
if
(
my
(
$function
,
$args
) = (
$text
=~ m/(.*?)\s*\((.*?)\)\s*$/)) {
if
(
$args
) {
while
(
$args
=~ s/^\s*(?:[
'"](.*?)['
"]|([\d\.:A-Za-z]+?))\s*(?:,\s*|$)//) {
if
(
defined
$1) {
push
@args
, $1;
}
else
{
push
@args
, $2;
}
}
}
unshift
(
@args
,
$function
);
if
(
$args
) {
$conf
->{errors}++;
warn
(
"syntax error (unparsable argument: $args) for eval function: $name: $text"
);
}
elsif
(
$type
==
$Mail::SpamAssassin::Conf::TYPE_BODY_EVALS
) {
$conf
->{body_evals}->{
$priority
}->{
$name
} = \
@args
;
}
elsif
(
$type
==
$Mail::SpamAssassin::Conf::TYPE_HEAD_EVALS
) {
$conf
->{head_evals}->{
$priority
}->{
$name
} = \
@args
;
}
elsif
(
$type
==
$Mail::SpamAssassin::Conf::TYPE_RBL_EVALS
) {
$conf
->{rbl_evals}->{
$name
} = \
@args
;
}
elsif
(
$type
==
$Mail::SpamAssassin::Conf::TYPE_RAWBODY_EVALS
) {
$conf
->{rawbody_evals}->{
$priority
}->{
$name
} = \
@args
;
}
elsif
(
$type
==
$Mail::SpamAssassin::Conf::TYPE_FULL_EVALS
) {
$conf
->{full_evals}->{
$priority
}->{
$name
} = \
@args
;
}
else
{
$conf
->{errors}++;
warn
(
"unknown type $type for $name: $text"
);
}
}
else
{
$conf
->{errors}++;
warn
(
"syntax error for eval function $name: $text"
);
}
}
else
{
if
(
$type
==
$Mail::SpamAssassin::Conf::TYPE_BODY_TESTS
) {
$conf
->{body_tests}->{
$priority
}->{
$name
} =
$text
;
}
elsif
(
$type
==
$Mail::SpamAssassin::Conf::TYPE_HEAD_TESTS
) {
$conf
->{head_tests}->{
$priority
}->{
$name
} =
$text
;
}
elsif
(
$type
==
$Mail::SpamAssassin::Conf::TYPE_META_TESTS
) {
if
(
$priority
< META_TEST_MIN_PRIORITY) {
$conf
->{priorities}->{
$priority
}--;
$priority
= META_TEST_MIN_PRIORITY;
$conf
->{priorities}->{
$priority
}++;
}
$conf
->{meta_tests}->{
$priority
}->{
$name
} =
$text
;
}
elsif
(
$type
==
$Mail::SpamAssassin::Conf::TYPE_URI_TESTS
) {
$conf
->{uri_tests}->{
$priority
}->{
$name
} =
$text
;
}
elsif
(
$type
==
$Mail::SpamAssassin::Conf::TYPE_RAWBODY_TESTS
) {
$conf
->{rawbody_tests}->{
$priority
}->{
$name
} =
$text
;
}
elsif
(
$type
==
$Mail::SpamAssassin::Conf::TYPE_FULL_TESTS
) {
$conf
->{full_tests}->{
$priority
}->{
$name
} =
$text
;
}
else
{
$conf
->{errors}++;
warn
(
"unknown type $type for $name: $text"
);
}
}
}
$self
->lint_trusted_networks();
$conf
->{main}->call_plugins(
"finish_parsing_end"
, {
conf
=>
$conf
});
delete
$conf
->{tests};
delete
$conf
->{priority};
}
sub
lint_trusted_networks {
my
(
$self
) =
@_
;
my
$conf
=
$self
->{conf};
my
$nt
=
$conf
->{trusted_networks};
my
$ni
=
$conf
->{internal_networks};
if
(
$ni
->get_num_nets() > 0 &&
$nt
->get_num_nets() > 0) {
my
$replace_nets
;
my
@valid_ni
= ();
foreach
my
$net
(@{
$ni
->{nets}}) {
if
(!
$net
->{exclude} && !
$nt
->contains_net(
$net
)) {
my
$msg
=
"trusted_networks doesn't contain internal_networks entry '"
.
(
$net
->{as_string}).
"'\n"
;
if
(
$conf
->{lint_rules}) {
warn
$msg
;
$conf
->{errors}++;
}
$replace_nets
= 1;
}
else
{
push
@valid_ni
,
$net
;
}
}
if
(
$replace_nets
) {
$ni
->{nets} = \
@valid_ni
;
}
}
}
sub
add_test {
my
(
$self
,
$name
,
$text
,
$type
) =
@_
;
my
$conf
=
$self
->{conf};
if
(
$name
!~ /^\D\w*$/) {
warn
"config: error: rule '$name' has invalid characters "
.
"(not Alphanumeric + Underscore + starting with a non-digit)\n"
;
$conf
->{errors}++;
return
;
}
if
(
length
$name
> 200) {
warn
"config: error: rule '$name' is way too long "
.
"(recommended maximum length is 22 characters)\n"
;
$conf
->{errors}++;
return
;
}
if
(
$conf
->{lint_rules}) {
if
(
length
(
$name
) > 50 &&
$name
!~ /^__/ &&
$name
!~ /^T_/) {
warn
"config: warning: rule name '$name' is over 50 chars "
.
"(recommended maximum length is 22 characters)\n"
;
$conf
->{errors}++;
}
}
if
(
$type
==
$Mail::SpamAssassin::Conf::TYPE_BODY_TESTS
||
$type
==
$Mail::SpamAssassin::Conf::TYPE_FULL_TESTS
||
$type
==
$Mail::SpamAssassin::Conf::TYPE_RAWBODY_TESTS
||
$type
==
$Mail::SpamAssassin::Conf::TYPE_URI_TESTS
)
{
return
unless
$self
->is_delimited_regexp_valid(
$name
,
$text
);
}
if
(
$type
==
$Mail::SpamAssassin::Conf::TYPE_HEAD_TESTS
)
{
my
(
$pat
) = (
$text
=~ /^\s*\S+\s*(?:\=|\!)\~\s*(\S.*?\S)\s*$/);
$pat
=~ s/\s+\[
if
-unset:\s+(.+)\]\s*$//;
return
unless
$self
->is_delimited_regexp_valid(
$name
,
$pat
);
}
elsif
(
$type
==
$Mail::SpamAssassin::Conf::TYPE_META_TESTS
)
{
return
unless
$self
->is_meta_valid(
$name
,
$text
);
}
$conf
->{tests}->{
$name
} =
$text
;
$conf
->{test_types}->{
$name
} =
$type
;
$conf
->{tflags}->{
$name
} ||=
''
;
$conf
->{priority}->{
$name
} ||= 0;
$conf
->{source_file}->{
$name
} =
$self
->{currentfile};
if
(
$self
->{scoresonly}) {
$conf
->{user_rules_to_compile}->{
$type
} = 1;
$conf
->{user_defined_rules}->{
$name
} = 1;
}
}
sub
add_regression_test {
my
(
$self
,
$name
,
$ok_or_fail
,
$string
) =
@_
;
my
$conf
=
$self
->{conf};
if
(
$conf
->{regression_tests}->{
$name
}) {
push
@{
$conf
->{regression_tests}->{
$name
}}, [
$ok_or_fail
,
$string
];
}
else
{
$conf
->{regression_tests}->{
$name
} = [ [
$ok_or_fail
,
$string
] ];
}
}
sub
is_meta_valid {
my
(
$self
,
$name
,
$rule
) =
@_
;
my
$meta
=
''
;
my
$lexer
= ARITH_EXPRESSION_LEXER;
my
@tokens
= (
$rule
=~ m/
$lexer
/g);
if
(
length
(
$name
) == 1) {
print
"$name $_\n "
for
@tokens
;
}
foreach
my
$token
(
@tokens
) {
if
(
$token
=~ /^(?:\W+|\d+)$/) {
$meta
.=
"$token "
;
}
else
{
$meta
.=
"0 "
;
}
}
my
$evalstr
=
'my $x = '
.
$meta
.
'; 1;'
;
if
(
eval
$evalstr
) {
return
1;
}
if
($@) {
my
$err
= $@;
$err
=~ s/\s+(?:at|near)\b.*//s;
$err
=~ s/Illegal division by zero/division by zero possible/i;
warn
"config: invalid expression for rule $name: \"$rule\": $err\n"
;
$self
->{conf}->{errors}++;
return
0;
}
}
sub
is_delimited_regexp_valid {
my
(
$self
,
$name
,
$re
) =
@_
;
unless
(
$re
=~ /^\s
*m
?(\W).*(?:\1|>|}|\)|\])[a-z]*\s*$/) {
warn
"config: invalid regexp for rule $name: $re: missing or invalid delimiters\n"
;
$self
->{conf}->{errors}++;
return
0;
}
return
$self
->is_regexp_valid(
$name
,
$re
);
}
sub
is_regexp_valid {
my
(
$self
,
$name
,
$re
) =
@_
;
my
$origre
=
$re
;
my
$safere
=
$re
;
my
$mods
=
''
;
if
(
$re
=~ s/^m{//) {
$re
=~ s/}([a-z]*)$//;
$mods
= $1;
}
elsif
(
$re
=~ s/^m\(//) {
$re
=~ s/\)([a-z]*)$//;
$mods
= $1;
}
elsif
(
$re
=~ s/^m<//) {
$re
=~ s/>([a-z]*)$//;
$mods
= $1;
}
elsif
(
$re
=~ s/^m(\W)//) {
$re
=~ s/\Q$1\E([a-z]*)$//;
$mods
= $1;
}
elsif
(
$re
=~ s/^\/(.*)\/([a-z]*)$/$1/) {
$mods
= $2;
}
else
{
$safere
=
"m#"
.
$re
.
"#"
;
}
if
(
$mods
) {
$re
=
"(?"
.
$mods
.
")"
.
$re
;
}
if
(
eval
{ (
""
=~ m
return
1;
}
my
$err
= $@;
$err
=~ s/ at .*? line \d.*$//;
warn
"config: invalid regexp for rule $name: $origre: $err\n"
;
$self
->{conf}->{errors}++;
return
0;
}
sub
add_to_addrlist {
my
(
$self
,
$singlelist
,
@addrs
) =
@_
;
my
$conf
=
$self
->{conf};
foreach
my
$addr
(
@addrs
) {
$addr
=
lc
$addr
;
my
$re
=
$addr
;
$re
=~ s/[\000\\\(]/_/gs;
$re
=~ s/([^\*\?_a-zA-Z0-9])/\\$1/g;
$re
=~
tr
/?/./;
$re
=~ s/\*+/\.\*/g;
$conf
->{
$singlelist
}->{
$addr
} =
"^${re}\$"
;
}
}
sub
add_to_addrlist_rcvd {
my
(
$self
,
$listname
,
$addr
,
$domain
) =
@_
;
my
$conf
=
$self
->{conf};
$addr
=
lc
$addr
;
if
(
$conf
->{
$listname
}->{
$addr
}) {
push
@{
$conf
->{
$listname
}->{
$addr
}{domain}},
$domain
;
}
else
{
my
$re
=
$addr
;
$re
=~ s/[\000\\\(]/_/gs;
$re
=~ s/([^\*\?_a-zA-Z0-9])/\\$1/g;
$re
=~
tr
/?/./;
$re
=~ s/\*+/\.\*/g;
$conf
->{
$listname
}->{
$addr
}{re} =
"^${re}\$"
;
$conf
->{
$listname
}->{
$addr
}{domain} = [
$domain
];
}
}
sub
remove_from_addrlist {
my
(
$self
,
$singlelist
,
@addrs
) =
@_
;
my
$conf
=
$self
->{conf};
foreach
my
$addr
(
@addrs
) {
delete
(
$conf
->{
$singlelist
}->{
$addr
});
}
}
sub
remove_from_addrlist_rcvd {
my
(
$self
,
$listname
,
@addrs
) =
@_
;
my
$conf
=
$self
->{conf};
foreach
my
$addr
(
@addrs
) {
delete
(
$conf
->{
$listname
}->{
$addr
});
}
}
sub
fix_path_relative_to_current_file {
my
(
$self
,
$path
) =
@_
;
if
(!File::Spec->file_name_is_absolute (
$path
)) {
my
(
$vol
,
$dirs
,
$file
) = File::Spec->splitpath (
$self
->{currentfile});
$path
= File::Spec->catpath (
$vol
,
$dirs
,
$path
);
dbg(
"plugin: fixed relative path: $path"
);
}
return
$path
;
}
1;