in lib/Mail/SpamAssassin/Plugin/Check.pm [512:824]
sub begin_evalstr_chunk {
my ($self, $pms) = @_;
my $n = 0;
if ($self->{evalstr_chunk_methodnames}) {
$n = scalar(@{$self->{evalstr_chunk_methodnames}});
}
my $chunk_methodname = sprintf("%s_%d", $self->{evalstr_methodname}, $n+1);
# dbg("rules: begin_evalstr_chunk %s", $chunk_methodname);
undef &{$chunk_methodname};
my $package_name = __PACKAGE__;
my $evalstr = <<"EOT";
package $package_name;
sub $chunk_methodname {
my \$self = shift;
my \$hits = 0;
my \%captures;
EOT
$evalstr .= ' '.$_ for @{$self->{evalstr_chunk_prefix}};
$self->{evalstr} = $evalstr;
$self->{evalstr_l} = length($evalstr);
$self->{evalstr_chunk_current_methodname} = $chunk_methodname;
}
sub end_evalstr_chunk {
my ($self, $pms) = @_;
# dbg("rules: end_evalstr_chunk");
my $evalstr = "}; 1;\n";
$self->{evalstr} .= $evalstr;
$self->{evalstr_l} += length($evalstr);
}
sub flush_evalstr {
my ($self, $pms, $caller_name) = @_;
my $chunk_methodname = $self->{evalstr_chunk_current_methodname};
$self->end_evalstr_chunk($pms);
dbg("rules: flush_evalstr (%s) compiling %d chars of %s",
$caller_name, $self->{evalstr_l}, $chunk_methodname);
# dbg("rules: eval code(2): %s", $self->{evalstr});
my $eval_result;
{ my $timer = $self->{main}->time_method('compile_gen');
$eval_result = eval($self->{evalstr});
}
if (!$eval_result) {
my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
warn "rules: failed to compile $chunk_methodname, skipping:\n".
"\t($eval_stat)\n";
$pms->{rule_errors}++;
} else {
push(@{$self->{evalstr_chunk_methodnames}}, $chunk_methodname);
}
$self->{evalstr} = ''; $self->{evalstr_l} = 0;
$self->begin_evalstr_chunk($pms);
}
sub push_evalstr_prefix {
my ($self, $pms, $str) = @_;
$self->add_evalstr_corked($pms, $str); # must not flush!
push(@{$self->{evalstr_chunk_prefix}}, $str);
# dbg("rules: push_evalstr_prefix (%d) - <%s>",
# scalar(@{$self->{evalstr_chunk_prefix}}), $str);
}
sub pop_evalstr_prefix {
my ($self) = @_;
pop(@{$self->{evalstr_chunk_prefix}});
# dbg("rules: pop_evalstr_prefix (%d)",
# scalar(@{$self->{evalstr_chunk_prefix}}));
}
sub add_evalstr {
my ($self, $pms, $str) = @_;
if (defined $str && $str ne '') {
my $new_code_l = length($str);
# dbg("rules: add_evalstr %d - <%s>", $new_code_l, $str);
$self->{evalstr} .= $str;
$self->{evalstr_l} += $new_code_l;
if ($self->{evalstr_l} > 60000) {
$self->flush_evalstr($pms, 'add_evalstr');
}
}
}
# similar to add_evalstr, but avoids flushing on size
sub add_evalstr_corked {
my ($self, $pms, $str) = @_;
if (defined $str) {
my $new_code_l = length($str);
$self->{evalstr} .= $str;
$self->{evalstr_l} += $new_code_l;
}
}
sub add_evalstr2 {
my ($self, $str) = @_;
$self->{evalstr2} .= $str;
}
sub add_temporary_method {
my ($self, $methodname, $methodbody) = @_;
$self->add_evalstr2(' sub '.$methodname.' { '.$methodbody.' } '."\n");
push (@TEMPORARY_METHODS, $methodname);
}
###########################################################################
sub do_head_tests {
my ($self, $pms, $priority) = @_;
# hash to hold the rules, "header\tdefault value" => rulename
my %ordered;
my %testcode; # tuples: [op_type, op, arg]
# op_type: 1=infix, 0:prefix/function
# op: operator, e.g. '=~', '!~', or a function like 'defined'
# arg: additional argument like a regexp for a patt matching op
$self->run_generic_tests ($pms, $priority,
consttype => $Mail::SpamAssassin::Conf::TYPE_HEAD_TESTS,
type => 'head',
testhash => $pms->{conf}->{head_tests},
args => [ ],
loop_body => sub
{
my ($self, $pms, $conf, $rulename, $pat, %opts) = @_;
push @{$ordered{
$conf->{test_opt_header}->{$rulename} .
(!exists $conf->{test_opt_unset}->{$rulename} ? '' : "\t$rulename")
}}, $rulename;
return if ($opts{doing_user_rules} &&
!$self->is_user_rule_sub($rulename.'_head_test'));
my ($op, $op_infix);
if (exists $conf->{test_opt_exists}->{$rulename}) {
$op_infix = 0;
$op = exists $conf->{test_opt_neg}->{$rulename} ? '!defined' : 'defined';
}
else {
$op_infix = 1;
$op = exists $conf->{test_opt_neg}->{$rulename} ? '!~' : '=~';
}
$testcode{$rulename} = [$op_infix, $op, $pat];
},
pre_loop_body => sub
{
my ($self, $pms, $conf, %opts) = @_;
$self->push_evalstr_prefix($pms, '
no warnings q(uninitialized);
my $hval; my @harr;
');
},
post_loop_body => sub
{
my ($self, $pms, $conf, %opts) = @_;
# setup the function to run the rules
while(my($k,$v) = each %ordered) {
my($hdrname, $def) = split(/\t/, $k, 2);
# get() might already include newlines, join accordingly (Bug 8121)
$self->push_evalstr_prefix($pms, '
if (scalar(@harr = $self->get(q{'.$hdrname.'}))) {
$hval = join($harr[0] =~ /\n\z/ ? "" : "\n", @harr);
} else {
$hval = '.(!defined($def) ? 'undef' :'$self->{conf}->{test_opt_unset}->{q{'.$def.'}}').'
}
');
foreach my $rulename (@{$v}) {
my $tc_ref = $testcode{$rulename};
my ($op_infix, $op, $pat);
($op_infix, $op, $pat) = @$tc_ref if defined $tc_ref;
my $posline = '';
my $ifwhile = 'if';
my $matchg = '';
my $whlast = '';
my $matching_string_unavailable = 0;
my $expr;
if (!$op_infix) { # function or its negation
$expr = $op . '($hval)';
$matching_string_unavailable = 1;
}
else { # infix operator
if (($conf->{tflags}->{$rulename}||'') =~ /\bmultiple\b/) {
$posline = 'pos $hval = 0; $hits = 0;';
$ifwhile = 'while';
$matchg = 'g';
if ($conf->{tflags}->{$rulename} =~ /\bmaxhits=(\d+)\b/) {
$whlast = 'last if ++$hits >= '.untaint_var($1).';';
}
}
$expr = '$hval '.$op.' /$test_qr/'.$matchg.'op';
}
# Make sure rule is marked ready for meta rules
$self->add_evalstr($pms, '
if ($scoresptr->{q{'.$rulename.'}}) {
'.($op_infix ? '$test_qr = $qrptr->{q{'.$rulename.'}};' : '').'
'.($op_infix ? $self->capture_rules_replace($conf, $rulename) : '').'
'.($would_log_rules_all ?
'dbg("rules-all: running header rule %s", q{'.$rulename.'});' : '').'
$self->rule_ready(q{'.$rulename.'}, 1);
'.$posline.'
'.$self->hash_line_for_rule($pms, $rulename).'
'.$ifwhile.' ('.$expr.') {
'.($op_infix ? $self->capture_plugin_code() : '').'
$self->got_hit(q{'.$rulename.'}, "", ruletype => "header");
'.$self->hit_rule_plugin_code($pms, $rulename, "header", "",
$matching_string_unavailable).'
'.$whlast.'
}
'.$self->ran_rule_plugin_code($rulename, "header").'
'.($op_infix ? "}\n" : '').'
}
');
}
$self->pop_evalstr_prefix();
}
}
);
}
###########################################################################
sub do_body_tests {
my ($self, $pms, $priority, $textary) = @_;
my $loopid = 0;
$self->run_generic_tests ($pms, $priority,
consttype => $Mail::SpamAssassin::Conf::TYPE_BODY_TESTS,
type => 'body',
testhash => $pms->{conf}->{body_tests},
args => [ @$textary ],
loop_body => sub
{
my ($self, $pms, $conf, $rulename, $pat, %opts) = @_;
my $sub = '';
if ($would_log_rules_all) {
$sub .= '
dbg("rules-all: running body rule %s", q{'.$rulename.'});
';
}
my $nosubject = ($conf->{tflags}->{$rulename}||'') =~ /\bnosubject\b/;
if ($nosubject) {
$sub .= '
my $nosubj = 1;
';
}
if (($conf->{tflags}->{$rulename}||'') =~ /\bmultiple\b/)
{
# support multiple matches
$loopid++;
my ($max) = $conf->{tflags}->{$rulename} =~ /\bmaxhits=(\d+)\b/;
$max = untaint_var($max);
$sub .= '
$hits = 0;
body_'.$loopid.': foreach my $l (@_) {
';
if ($nosubject) {
$sub .= '
if ($nosubj) { $nosubj = 0; next; }
';
}
$sub .= '
pos $l = 0;
'.$self->hash_line_for_rule($pms, $rulename).'
while ($l =~ /$test_qr/gop) {
'.$self->capture_plugin_code().'
$self->got_hit(q{'.$rulename.'}, "BODY: ", ruletype => "body");
'. $self->hit_rule_plugin_code($pms, $rulename, "body", "") . '
'. ($max? 'last body_'.$loopid.' if ++$hits >= '.$max.';' : '') .'
}
}
';
}
else {
# omitting the "pos" call, "body_loopid" label, use of while()
# instead of if() etc., shaves off 8 perl OPs.
$sub .= '
foreach my $l (@_) {
';
if ($nosubject) {
$sub .= '
if ($nosubj) { $nosubj = 0; next; }
';
}
$sub .= '
'.$self->hash_line_for_rule($pms, $rulename).'
if ($l =~ /$test_qr/op) {
'.$self->capture_plugin_code().'
$self->got_hit(q{'.$rulename.'}, "BODY: ", ruletype => "body");
'. $self->hit_rule_plugin_code($pms, $rulename, "body", "last") .'
}
}
';
}
# Make sure rule is marked ready for meta rules
$self->add_evalstr($pms, '
if ($scoresptr->{q{'.$rulename.'}}) {
$test_qr = $qrptr->{q{'.$rulename.'}};
'.$self->capture_rules_replace($conf, $rulename).'
$self->rule_ready(q{'.$rulename.'}, 1);
'.$sub.'
'.$self->ran_rule_plugin_code($rulename, "body").'
}
}
');
return if ($opts{doing_user_rules} &&
!$self->is_user_rule_sub($rulename.'_body_test'));
}
);
}