File Coverage

blib/lib/Mail/SpamAssassin/Plugin/Check.pm

Criterion	Covered	Total	%
statement	961	1249	76.9
branch	196	460	42.6
condition	44	110	40.0
subroutine	95	100	95.0
pod	3	32	9.3
total	1299	1951	66.5

=head1 NAME

Mail::SpamAssassin::Plugin::Check - primary message check functionality

=head1 SYNOPSIS

loadplugin Mail::SpamAssassin::Plugin::Check

=head1 DESCRIPTION

This plugin provides the primary message check functionality.

=cut


use strict;
use warnings;
use re 'taint';

use Time::HiRes qw(time);

use Mail::SpamAssassin::Plugin;
use Mail::SpamAssassin::Logger;
use Mail::SpamAssassin::Util qw(untaint_var);
use Mail::SpamAssassin::Timeout;
use Mail::SpamAssassin::Constants qw(:sa);

our @ISA = qw(Mail::SpamAssassin::Plugin);

my $ARITH_EXPRESSION_LEXER = ARITH_EXPRESSION_LEXER;
my $META_RULES_MATCHING_RE = META_RULES_MATCHING_RE;

# methods defined by the compiled ruleset; deleted in finish_tests()
our @TEMPORARY_METHODS;

# constructor
  my $class = shift;
  my $mailsaobject = shift;

  $class = ref($class) || $class;
  my $self = $class->SUPER::new($mailsaobject);
  bless ($self, $class);

  return $self;
}

###########################################################################

  my ($self, $args) = @_;

  my $pms = $args->{permsgstatus};

  my $suppl_attrib = $pms->{msg}->{suppl_attrib};
  if (ref $suppl_attrib && ref $suppl_attrib->{rule_hits}) {
    my @caller_rule_hits = @{$suppl_attrib->{rule_hits}};
    dbg("check: adding caller rule hits, %d rules", scalar(@caller_rule_hits));
    for my $caller_rule_hit (@caller_rule_hits) {
      next if ref $caller_rule_hit ne 'HASH';
      my($rulename, $area, $score, $defscore, $value,
         $ruletype, $tflags, $description) =
        @$caller_rule_hit{qw(rule area score defscore value
                             ruletype tflags descr)};
      $pms->got_hit($rulename, $area,
                    !defined $score ? () : (score => $score),
                    !defined $defscore ? () : (defscore => $defscore),
                    !defined $value ? () : (value => $value),
                    !defined $tflags ? () : (tflags => $tflags),
                    !defined $description ? () : (description => $description),
                    ruletype => $ruletype);
    }
  }

  # bug 4353:
  # Do this before the RBL tests are kicked off.  The metadata parsing
  # will figure out the (un)trusted relays and such, which are used in the
  # rbl calls.
  $pms->extract_message_metadata();

  # Here, we launch all the DNS RBL queries and let them run while we
  # inspect the message
  $self->run_rbl_eval_tests($pms);
  my $needs_dnsbl_harvest_p = 1; # harvest needs to be run

  my $decoded = $pms->get_decoded_stripped_body_text_array();
  my $bodytext = $pms->get_decoded_body_text_array();
  my $fulltext = $pms->{msg}->get_pristine();
  my $master_deadline = $pms->{master_deadline};
  dbg("check: check_main, time limit in %.3f s",
      $master_deadline - time)  if $master_deadline;

  my @uris = $pms->get_uri_list();

  foreach my $priority (sort { $a <=> $b } keys %{$pms->{conf}->{priorities}}) {
    # no need to run if there are no priorities at this level.  This can
    # happen in Conf.pm when we switch a rule from one priority to another
    next unless ($pms->{conf}->{priorities}->{$priority} > 0);

    if ($pms->{deadline_exceeded}) {
      last;
    } elsif ($master_deadline && time > $master_deadline) {
      info("check: exceeded time limit, skipping further tests");
      $pms->{deadline_exceeded} = 1;
      last;
    } elsif ($self->{main}->call_plugins("have_shortcircuited",
                                         { permsgstatus => $pms })) {
      # if shortcircuiting is hit, we skip all other priorities...
      last;
    }

    my $timer = $self->{main}->time_method("tests_pri_".$priority);
    dbg("check: running tests for priority: $priority");

    # only harvest the dnsbl queries once priority HARVEST_DNSBL_PRIORITY
    # has been reached and then only run once
    #
    # TODO: is this block still needed here? is HARVEST_DNSBL_PRIORITY used?
    #
    if ($priority >= HARVEST_DNSBL_PRIORITY
        && $needs_dnsbl_harvest_p
        && !$self->{main}->call_plugins("have_shortcircuited",
                                        { permsgstatus => $pms }))
    {
      # harvest the DNS results
      $pms->harvest_dnsbl_queries();
      $needs_dnsbl_harvest_p = 0;

      # finish the DNS results
      $pms->rbl_finish();
      $self->{main}->call_plugins("check_post_dnsbl", { permsgstatus => $pms });
      $pms->{resolver}->finish_socket() if $pms->{resolver};
    }

    $pms->harvest_completed_queries();
    # allow other, plugin-defined rule types to be called here
    $self->{main}->call_plugins ("check_rules_at_priority",
        { permsgstatus => $pms, priority => $priority, checkobj => $self });

    # do head tests
    $self->do_head_tests($pms, $priority);
    $pms->harvest_completed_queries();
    last if $pms->{deadline_exceeded};

    $self->do_head_eval_tests($pms, $priority);
    $pms->harvest_completed_queries();
    last if $pms->{deadline_exceeded};

    $self->do_body_tests($pms, $priority, $decoded);
    $pms->harvest_completed_queries();
    last if $pms->{deadline_exceeded};

    $self->do_uri_tests($pms, $priority, @uris);
    $pms->harvest_completed_queries();
    last if $pms->{deadline_exceeded};

    $self->do_body_eval_tests($pms, $priority, $decoded);
    $pms->harvest_completed_queries();
    last if $pms->{deadline_exceeded};

    $self->do_rawbody_tests($pms, $priority, $bodytext);
    $pms->harvest_completed_queries();
    last if $pms->{deadline_exceeded};

    $self->do_rawbody_eval_tests($pms, $priority, $bodytext);
    $pms->harvest_completed_queries();
    last if $pms->{deadline_exceeded};

    $self->do_full_tests($pms, $priority, \$fulltext);
    $pms->harvest_completed_queries();
    last if $pms->{deadline_exceeded};

    $self->do_full_eval_tests($pms, $priority, \$fulltext);
    $pms->harvest_completed_queries();
    last if $pms->{deadline_exceeded};

    $self->do_meta_tests($pms, $priority);
    $pms->harvest_completed_queries();
    last if $pms->{deadline_exceeded};

    # we may need to call this more often than once through the loop, but
    # it needs to be done at least once, either at the beginning or the end.
    $self->{main}->call_plugins ("check_tick", { permsgstatus => $pms });
    $pms->harvest_completed_queries();
    last if $pms->{deadline_exceeded};
  }

  # sanity check, it is possible that no rules >= HARVEST_DNSBL_PRIORITY ran so the harvest
  # may not have run yet.  Check, and if so, go ahead and harvest here.
  if ($needs_dnsbl_harvest_p) {
    if (!$self->{main}->call_plugins("have_shortcircuited",
                                        { permsgstatus => $pms }))
    {
      # harvest the DNS results
      $pms->harvest_dnsbl_queries();
    }

    # finish the DNS results
    $pms->rbl_finish();
    $self->{main}->call_plugins ("check_post_dnsbl", { permsgstatus => $pms });
    $pms->{resolver}->finish_socket() if $pms->{resolver};
  }

  if ($pms->{deadline_exceeded}) {
    $pms->got_hit('TIME_LIMIT_EXCEEDED', '', defscore => 0.001,
                  description => 'Exceeded time limit / deadline');
  }

  # finished running rules
  delete $pms->{current_rule_name};
  undef $decoded;
  undef $bodytext;
  undef $fulltext;

  if ($pms->{deadline_exceeded}) {
  # dbg("check: exceeded time limit, skipping auto-learning");
  } elsif ($master_deadline && time > $master_deadline) {
    info("check: exceeded time limit, skipping auto-learning");
    $pms->{deadline_exceeded} = 1;
  } else {
    # auto-learning
    $pms->learn();
    $self->{main}->call_plugins ("check_post_learn", { permsgstatus => $pms });
  }

  # track user_rules recompilations; each scanned message is 1 tick on this counter
  if ($self->{done_user_rules}) {
    my $counters = $pms->{conf}->{want_rebuild_for_type};
    foreach my $type (keys %{$self->{done_user_rules}}) {
      if ($counters->{$type} > 0) {
        $counters->{$type}--;
      }
      dbg("rules: user rules done; ticking want_rebuild counter for type $type to ".
                    $counters->{$type});
    }
  }

  return 1;
}

  my ($self, $params) = @_;

  foreach my $method (@TEMPORARY_METHODS) {
    undef &{$method};
  }
  @TEMPORARY_METHODS = ();      # clear for next time
}

###########################################################################

  my ($self, $pms) = @_;
  my ($rulename, $pat, @args);

  # XXX - possible speed up, moving this check out of the subroutine into Check->new()
  if ($self->{main}->{local_tests_only}) {
    dbg("rules: local tests only, ignoring RBL eval");
    return 0;
  }

  while (my ($rulename, $test) = each %{$pms->{conf}->{rbl_evals}}) {
    my $score = $pms->{conf}->{scores}->{$rulename};
    next unless $score;

    %{$pms->{test_log_msgs}} = ();        # clear test state

    my $function = $test->[0];
    if (!exists $pms->{conf}->{eval_plugins}->{$function}) {
      warn("rules: unknown eval '$function' for $rulename, ignoring RBL eval\n");
      return 0;
    }

    my $result;
    eval {
      $result = $pms->$function($rulename, @{$test->[1]});  1;
    } or do {
      my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
      die "rules: $eval_stat\n"  if $eval_stat =~ /__alarm__ignore__/;
      warn "rules: failed to run $rulename RBL test, skipping:\n".
           "\t($eval_stat)\n";
      $pms->{rule_errors}++;
      next;
    };
  }
}

###########################################################################

  my ($self, $pms, $priority, %opts) = @_;

  my $master_deadline = $pms->{master_deadline};
  if ($pms->{deadline_exceeded}) {
    return;
  } elsif ($master_deadline && time > $master_deadline) {
    info("check: (run_generic) exceeded time limit, skipping further tests");
    $pms->{deadline_exceeded} = 1;
    return;
  } elsif ($self->{main}->call_plugins("have_shortcircuited",
                                        { permsgstatus => $pms })) {
    return;
  }

  my $ruletype = $opts{type};
  dbg("rules: running $ruletype tests; score so far=".$pms->{score});
  %{$pms->{test_log_msgs}} = ();        # clear test state

  my $conf = $pms->{conf};
  my $doing_user_rules = $conf->{want_rebuild_for_type}->{$opts{consttype}};
  if ($doing_user_rules) { $self->{done_user_rules}->{$opts{consttype}}++; }

  # clean up priority value so it can be used in a subroutine name
  my $clean_priority;
  ($clean_priority = $priority) =~ s/-/neg/;
  my $package_name = __PACKAGE__;
  my $methodname = $package_name."::_".$ruletype."_tests_".$clean_priority;

  if (!defined &{$methodname} || $doing_user_rules) {

    # use %nopts for named parameter-passing; it's more friendly
    # to future-proof subclassing, since new parameters can be added without
    # breaking third-party subclassed implementations of this plugin.
    my %nopts = (
      ruletype => $ruletype,
      doing_user_rules => $doing_user_rules,
      priority => $priority,
      clean_priority => $clean_priority
    );

    # build up the eval string...
    $self->{evalstr_methodname} = $methodname;
    $self->{evalstr_chunk_current_methodname} = undef;
    $self->{evalstr_chunk_methodnames} = [];
    $self->{evalstr_chunk_prefix} = []; # stack (array) of source code sections
    $self->{evalstr} = ''; $self->{evalstr_l} = 0;
    $self->{evalstr2} = '';
    $self->begin_evalstr_chunk($pms);

    $self->push_evalstr_prefix($pms, '
                # start_rules_plugin_code '.$ruletype.' '.$priority.'
                my $scoresptr = $self->{conf}->{scores};
                my $qrptr = $self->{conf}->{test_qrs};
        ');
    if (defined $opts{pre_loop_body}) {
      $opts{pre_loop_body}->($self, $pms, $conf, %nopts);
    }
    $self->add_evalstr($pms,
                       $self->start_rules_plugin_code($ruletype, $priority) );
    while (my($rulename, $test) = each %{$opts{testhash}->{$priority}}) {
      $opts{loop_body}->($self, $pms, $conf, $rulename, $test, %nopts);
    }
    if (defined $opts{post_loop_body}) {
      $opts{post_loop_body}->($self, $pms, $conf, %nopts);
    }

   # dbg("rules: generated matching code:\n".$self->{evalstr});

    $self->flush_evalstr($pms, 'run_generic_tests');
    $self->free_ruleset_source($pms, $ruletype, $priority);

    # clear out a previous version of this method
    undef &{$methodname};

    # generate the loop that goes through each line...
    my $evalstr = <<"EOT";
  {
    package $package_name;

    $self->{evalstr2}

    sub $methodname {
EOT

    for my $chunk_methodname (@{$self->{evalstr_chunk_methodnames}}) {
      $evalstr .= "      $chunk_methodname(\@_);\n";
    }

    $evalstr .= <<"EOT";
    }

    1;
  }
EOT

    delete $self->{evalstr};   # free up some RAM before we eval()
    delete $self->{evalstr2};
    delete $self->{evalstr_methodname};
    delete $self->{evalstr_chunk_current_methodname};
    delete $self->{evalstr_chunk_methodnames};
    delete $self->{evalstr_chunk_prefix};

    dbg("rules: run_generic_tests - compiling eval code: %s, priority %s",
        $ruletype, $priority);
  # dbg("rules: eval code to compile: %s", $evalstr);
    my $eval_result;
    { my $timer = $self->{main}->time_method('compile_gen');
      $eval_result = eval($evalstr);
    }
    if (!$eval_result) {
      my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
      warn "rules: failed to compile $ruletype tests, skipping:\n".
           "\t($eval_stat)\n";
      $pms->{rule_errors}++;
      return;
    }
    dbg("rules: compiled $ruletype tests");
  }

#run_compiled_method:
# dbg("rules: run_generic_tests - calling %s", $methodname);
  my $t = Mail::SpamAssassin::Timeout->new({ deadline => $master_deadline });
  my $err = $t->run(sub {
    no strict "refs";
    $methodname->($pms, @{$opts{args}});
  });
  if ($t->timed_out() && $master_deadline && time > $master_deadline) {
    info("check: exceeded time limit in $methodname, skipping further tests");
    $pms->{deadline_exceeded} = 1;
  }
}

  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;
EOT
  $evalstr .= '  '.$_  for @{$self->{evalstr_chunk_prefix}};
  $self->{evalstr} = $evalstr;
  $self->{evalstr_l} = length($evalstr);
  $self->{evalstr_chunk_current_methodname} = $chunk_methodname;
}

  my ($self, $pms) = @_;
# dbg("rules: end_evalstr_chunk");
  my $evalstr = "}; 1;\n";
  $self->{evalstr} .= $evalstr;
  $self->{evalstr_l} += length($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);
}

  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);
}

  my ($self) = @_;
  pop(@{$self->{evalstr_chunk_prefix}});
# dbg("rules: pop_evalstr_prefix (%d)",
#     scalar(@{$self->{evalstr_chunk_prefix}}));
}

  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
  my ($self, $pms, $str) = @_;
  if (defined $str) {
    my $new_code_l = length($str);
    $self->{evalstr} .= $str;
    $self->{evalstr_l} += $new_code_l;
  }
}

  my ($self, $str) = @_;
  $self->{evalstr2} .= $str;
}

  my ($self, $methodname, $methodbody) = @_;
  $self->add_evalstr2 (' sub '.$methodname.' { '.$methodbody.' } ');
  push (@TEMPORARY_METHODS, $methodname);
}

###########################################################################

# Returns all rulenames matching glob (FOO_*)
  my ($self, $ruleglob, $pms, $conf, $rulename) = @_;
  my $expanded;
  if (exists $pms->{ruleglob_cache}{$ruleglob}) {
    $expanded = $pms->{ruleglob_cache}{$ruleglob};
  } else {
    my $reglob = $ruleglob;
    $reglob =~ s/\?/./g;
    $reglob =~ s/\*/.*?/g;
    # Glob rules, but do not match ourselves..
    my @rules = grep {/^${reglob}$/ && $_ ne $rulename} keys %{$conf->{scores}};
    if (@rules) {
      $expanded = join('+', sort @rules);
    } else {
      $expanded = '0';
    }
  }
  my $logstr = $expanded eq '0' ? 'no matches' : $expanded;
  dbg("rules: meta $rulename rules_matching($ruleglob) expanded: $logstr");
  $pms->{ruleglob_cache}{$ruleglob} = $expanded;
  return " ($expanded) ";
};

  my ($self, $pms, $priority) = @_;
  my (%rule_deps, %meta, $rulename);

  $self->run_generic_tests ($pms, $priority,
    consttype => $Mail::SpamAssassin::Conf::TYPE_META_TESTS,
    type => 'meta',
    testhash => $pms->{conf}->{meta_tests},
    args => [ ],
    loop_body => sub
  {
    my ($self, $pms, $conf, $rulename, $rule, %opts) = @_;

    # Expand meta rules_matching() before lexing
    $rule =~ s/${META_RULES_MATCHING_RE}/$self->expand_ruleglob($1,$pms,$conf,$rulename)/ge;

    # Lex the rule into tokens using a rather simple RE method ...
    my @tokens = ($rule =~ /$ARITH_EXPRESSION_LEXER/og);

    # Set the rule blank to start
    $meta{$rulename} = "";

    # List dependencies that are meta tests in the same priority band
    $rule_deps{$rulename} = [ ];

    # Go through each token in the meta rule
    foreach my $token (@tokens) {

      # ... rulename?
      if ($token =~ IS_RULENAME) {
        # the " || 0" formulation is to avoid "use of uninitialized value"
        # warnings; this is better than adding a 0 to a hash for every
        # rule referred to in a meta...
        $meta{$rulename} .= "(\$h->{'$token'}||0) ";

        if (!exists $conf->{scores}->{$token}) {
          dbg("rules: meta test $rulename has undefined dependency '$token'");
        }
        elsif ($conf->{scores}->{$token} == 0) {
          # bug 5040: net rules in a non-net scoreset
          # there are some cases where this is expected; don't warn
          # in those cases.
          unless ((($conf->get_score_set()) & 1) == 0 &&
              ($conf->{tflags}->{$token}||'') =~ /\bnet\b/)
          {
            info("rules: meta test $rulename has dependency '$token' with a zero score");
          }
        }

        # If the token is another meta rule, add it as a dependency
        push (@{ $rule_deps{$rulename} }, $token)
          if (exists $conf->{meta_tests}->{$opts{priority}}->{$token});
      } else {
        # ... number or operator
        $meta{$rulename} .= "$token ";
      }
    }
  },
    pre_loop_body => sub
  {
    my ($self, $pms, $conf, %opts) = @_;
    $self->push_evalstr_prefix($pms, '
            my $r;
            my $h = $self->{tests_already_hit};
        ');
  },
    post_loop_body => sub
  {
    my ($self, $pms, $conf, %opts) = @_;

    # Sort by length of dependencies list.  It's more likely we'll get
    # the dependencies worked out this way.
    my @metas = sort { @{ $rule_deps{$a} } <=> @{ $rule_deps{$b} } }
                keys %{$conf->{meta_tests}->{$opts{priority}}};

    my $count;
    my $tflags = $conf->{tflags};

    # Now go ahead and setup the eval string
    do {
      $count = $#metas;
      my %metas = map { $_ => 1 } @metas; # keep a small cache for fast lookups

      # Go through each meta rule we haven't done yet
      for (my $i = 0 ; $i <= $#metas ; $i++) {

        # If we depend on meta rules that haven't run yet, skip it
        next if (grep( $metas{$_}, @{ $rule_deps{ $metas[$i] } }));

        # If we depend on network tests, call ensure_rules_are_complete()
        # to block until they are
        if (!defined $conf->{meta_dependencies}->{ $metas[$i] }) {
          warn "no meta_dependencies defined for $metas[$i]";
        }
        my $alldeps = join ' ', grep {
                ($tflags->{$_}||'') =~ /\bnet\b/
              } split (' ', $conf->{meta_dependencies}->{ $metas[$i] } );

        if ($alldeps ne '') {
          $self->add_evalstr($pms, '
                        $self->ensure_rules_are_complete(q{'.$metas[$i].'}, qw{'.$alldeps.'});
                    ');
        }

        # Add this meta rule to the eval line
        $self->add_evalstr($pms, '
                    $r = '.$meta{$metas[$i]}.';
                    if ($r) { $self->got_hit(q#'.$metas[$i].'#, "", ruletype => "meta", value => $r); }
                ');

        splice @metas, $i--, 1;    # remove this rule from our list
      }
    } while ($#metas != $count && $#metas > -1); # run until we can't go anymore

    # If there are any rules left, we can't solve the dependencies so complain
    my %metas = map { $_ => 1 } @metas; # keep a small cache for fast lookups
    foreach my $rulename_t (@metas) {
      $pms->{rule_errors}++; # flag to --lint that there was an error ...
      my $msg =
          "rules: excluding meta test $rulename_t, unsolved meta dependencies: " .
              join(", ", grep($metas{$_}, @{ $rule_deps{$rulename_t} }));
      if ($self->{main}->{lint_rules}) {
        warn $msg."\n";
      }
      else {
        info($msg);
      }
    }
  }
  );
}

###########################################################################

  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) = @_;
    my ($op, $op_infix);
    my $hdrname = $conf->{test_opt_header}->{$rulename};
    if (exists $conf->{test_opt_exists}->{$rulename}) {
      $op_infix = 0;
      if (exists $conf->{test_opt_neg}->{$rulename}) {
        $op = '!defined';
      } else {
        $op = 'defined';
      }
    }
    else {
      $op_infix = 1;
      $op = $conf->{test_opt_neg}->{$rulename} ? '!~' : '=~';
    }

    my $def = $conf->{test_opt_unset}->{$rulename};
    push(@{ $ordered{$hdrname . (!defined $def ? '' : "\t$rulename")} },
         $rulename);

    return if ($opts{doing_user_rules} &&
            !$self->is_user_rule_sub($rulename.'_head_test'));

    $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;
        ');
  },
    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);
      $self->push_evalstr_prefix($pms, '
                $hval = $self->get(q{'.$hdrname.'}, ' .
                           (!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).';';
              }
            }
            if ($matchg) {
              $expr = '$hval '.$op.' /$qrptr->{q{'.$rulename.'}}/go';
            } else {
              $expr = '$hval '.$op.' /$qrptr->{q{'.$rulename.'}}/o';
            }
          }

          $self->add_evalstr($pms, '
                    if ($scoresptr->{q{'.$rulename.'}}) {
                        '.$posline.'
                        '.$self->hash_line_for_rule($pms, $rulename).'
                        '.$ifwhile.' ('.$expr.') {
                            $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").'
                    }
                    ');
      }
      $self->pop_evalstr_prefix();
    }
  }
  );
}

###########################################################################

  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('dbg', 'rules-all') == 2) {
      $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) = ($pms->{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 =~ /$qrptr->{q{'.$rulename.'}}/go) {
                    $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 =~ /$qrptr->{q{'.$rulename.'}}/o) {
                    $self->got_hit(q{'.$rulename.'}, "BODY: ", ruletype => "body");
                    '. $self->hit_rule_plugin_code($pms, $rulename, "body", "last") .'
                }
            }
            ';
    }

    $self->add_evalstr($pms, '
            if ($scoresptr->{q{'.$rulename.'}}) {
                '.$sub.'
                '.$self->ran_rule_plugin_code($rulename, "body").'
            }
        ');

    return if ($opts{doing_user_rules} &&
            !$self->is_user_rule_sub($rulename.'_body_test'));
  }
  );
}

###########################################################################

  my ($self, $pms, $priority, @uris) = @_;
  my $loopid = 0;
  $self->run_generic_tests ($pms, $priority,
    consttype => $Mail::SpamAssassin::Conf::TYPE_URI_TESTS,
    type => 'uri',
    testhash => $pms->{conf}->{uri_tests},
    args => [ @uris ],
    loop_body => sub
  {
    my ($self, $pms, $conf, $rulename, $pat, %opts) = @_;
    my $sub = '';
    if (would_log('dbg', 'rules-all') == 2) {
      $sub .= '
            dbg("rules-all: running uri rule %s", q{'.$rulename.'});
            ';
    }
    if (($conf->{tflags}->{$rulename}||'') =~ /\bmultiple\b/) {
      $loopid++;
      my ($max) = ($pms->{conf}->{tflags}->{$rulename}||'') =~ /\bmaxhits=(\d+)\b/;
      $max = untaint_var($max);
      $sub .= '
            $hits = 0;
            uri_'.$loopid.': foreach my $l (@_) {
                pos $l = 0;
                '.$self->hash_line_for_rule($pms, $rulename).'
                while ($l =~ /$qrptr->{q{'.$rulename.'}}/go) {
                      $self->got_hit(q{'.$rulename.'}, "URI: ", ruletype => "uri");
                      '. $self->hit_rule_plugin_code($pms, $rulename, "uri", "") . '
                      '. ($max? 'last uri_'.$loopid.' if ++$hits >= '.$max.';' : '') .'
                }
            }
            ';
    } else {
      $sub .= '
            foreach my $l (@_) {
                '.$self->hash_line_for_rule($pms, $rulename).'
                if ($l =~ /$qrptr->{q{'.$rulename.'}}/o) {
                      $self->got_hit(q{'.$rulename.'}, "URI: ", ruletype => "uri");
                      '. $self->hit_rule_plugin_code($pms, $rulename, "uri", "last") .'
                }
            }
            ';
    }

    $self->add_evalstr($pms, '
            if ($scoresptr->{q{'.$rulename.'}}) {
                '.$sub.'
                '.$self->ran_rule_plugin_code($rulename, "uri").'
            }
        ');

    return if ($opts{doing_user_rules} &&
            !$self->is_user_rule_sub($rulename.'_uri_test'));
  }
  );
}

###########################################################################

  my ($self, $pms, $priority, $textary) = @_;
  my $loopid = 0;
  $self->run_generic_tests ($pms, $priority,
    consttype => $Mail::SpamAssassin::Conf::TYPE_RAWBODY_TESTS,
    type => 'rawbody',
    testhash => $pms->{conf}->{rawbody_tests},
    args => [ @$textary ],
    loop_body => sub
  {
    my ($self, $pms, $conf, $rulename, $pat, %opts) = @_;
    my $sub = '';
    if (would_log('dbg', 'rules-all') == 2) {
      $sub .= '
            dbg("rules-all: running rawbody rule %s", q{'.$rulename.'});
            ';
    }
    if (($pms->{conf}->{tflags}->{$rulename}||'') =~ /\bmultiple\b/)
    {
      # support multiple matches
      $loopid++;
      my ($max) = ($pms->{conf}->{tflags}->{$rulename}||'') =~ /\bmaxhits=(\d+)\b/;
      $max = untaint_var($max);
      $sub .= '
            $hits = 0;
            rawbody_'.$loopid.': foreach my $l (@_) {
                pos $l = 0;
                '.$self->hash_line_for_rule($pms, $rulename).'
                while ($l =~ /$qrptr->{q{'.$rulename.'}}/go) {
                      $self->got_hit(q{'.$rulename.'}, "RAW: ", ruletype => "rawbody");
                      '. $self->hit_rule_plugin_code($pms, $rulename, "rawbody", "") . '
                      '. ($max? 'last rawbody_'.$loopid.' if ++$hits >= '.$max.';' : '') .'
                }
            }
            ';
    }
    else {
      $sub .= '
            foreach my $l (@_) {
                '.$self->hash_line_for_rule($pms, $rulename).'
                if ($l =~ /$qrptr->{q{'.$rulename.'}}/o) {
                      $self->got_hit(q{'.$rulename.'}, "RAW: ", ruletype => "rawbody");
                      '. $self->hit_rule_plugin_code($pms, $rulename, "rawbody", "last") . '
                }
            }
            ';
    }

    $self->add_evalstr($pms, '
            if ($scoresptr->{q{'.$rulename.'}}) {
                '.$sub.'
                '.$self->ran_rule_plugin_code($rulename, "rawbody").'
            }
        ');

    return if ($opts{doing_user_rules} &&
            !$self->is_user_rule_sub($rulename.'_rawbody_test'));
  }
  );
}

###########################################################################

  my ($self, $pms, $priority, $fullmsgref) = @_;
  my $loopid = 0;
  $self->run_generic_tests ($pms, $priority,
    consttype => $Mail::SpamAssassin::Conf::TYPE_FULL_TESTS,
    type => 'full',
    testhash => $pms->{conf}->{full_tests},
    args => [ $fullmsgref ],
    pre_loop_body => sub
  {
    my ($self, $pms, $conf, %opts) = @_;
    $self->push_evalstr_prefix($pms, '
            my $fullmsgref = shift;
        ');
  },
                loop_body => sub
  {
    my ($self, $pms, $conf, $rulename, $pat, %opts) = @_;
    my ($max) = ($pms->{conf}->{tflags}->{$rulename}||'') =~ /\bmaxhits=(\d+)\b/;
    $max = untaint_var($max);
    $max ||= 0;
    $self->add_evalstr($pms, '
            if ($scoresptr->{q{'.$rulename.'}}) {
                pos $$fullmsgref = 0;
                '.$self->hash_line_for_rule($pms, $rulename).'
                dbg("rules-all: running full rule %s", q{'.$rulename.'});
                $hits = 0;
                while ($$fullmsgref =~ /$qrptr->{q{'.$rulename.'}}/g) {
                    $self->got_hit(q{'.$rulename.'}, "FULL: ", ruletype => "full");
                    '. $self->hit_rule_plugin_code($pms, $rulename, "full", "last") . '
                    last if ++$hits >= '.$max.';
                }
                pos $$fullmsgref = 0;
                '.$self->ran_rule_plugin_code($rulename, "full").'
            }
        ');
  }
  );
}

###########################################################################

  my ($self, $pms, $priority) = @_;
  return unless (defined($pms->{conf}->{head_evals}->{$priority}));
  dbg("rules: running head_eval tests; score so far=".$pms->{score});
  $self->run_eval_tests ($pms, $Mail::SpamAssassin::Conf::TYPE_HEAD_EVALS,
			 'head_evals', '', $priority);
}

  my ($self, $pms, $priority, $bodystring) = @_;
  return unless (defined($pms->{conf}->{body_evals}->{$priority}));
  dbg("rules: running body_eval tests; score so far=".$pms->{score});
  $self->run_eval_tests ($pms, $Mail::SpamAssassin::Conf::TYPE_BODY_EVALS,
			 'body_evals', 'BODY: ', $priority, $bodystring);
}

  my ($self, $pms, $priority, $bodystring) = @_;
  return unless (defined($pms->{conf}->{rawbody_evals}->{$priority}));
  dbg("rules: running rawbody_eval tests; score so far=".$pms->{score});
  $self->run_eval_tests ($pms, $Mail::SpamAssassin::Conf::TYPE_RAWBODY_EVALS,
			 'rawbody_evals', 'RAW: ', $priority, $bodystring);
}

  my ($self, $pms, $priority, $fullmsgref) = @_;
  return unless (defined($pms->{conf}->{full_evals}->{$priority}));
  dbg("rules: running full_eval tests; score so far=".$pms->{score});
  $self->run_eval_tests($pms, $Mail::SpamAssassin::Conf::TYPE_FULL_EVALS,
			'full_evals', '', $priority, $fullmsgref);
}

  my ($self, $pms, $testtype, $evalname, $prepend2desc, $priority, @extraevalargs) = @_;

  my $master_deadline = $pms->{master_deadline};
  if ($pms->{deadline_exceeded}) {
    return;
  } elsif ($master_deadline && time > $master_deadline) {
    info("check: (run_eval) exceeded time limit, skipping further tests");
    $pms->{deadline_exceeded} = 1;
    return;
  } elsif ($self->{main}->call_plugins("have_shortcircuited",
                                        { permsgstatus => $pms })) {
    return;
  }

  my $conf = $pms->{conf};
  my $doing_user_rules = $conf->{want_rebuild_for_type}->{$testtype};
  if ($doing_user_rules) { $self->{done_user_rules}->{$testtype}++; }

  # clean up priority value so it can be used in a subroutine name
  my $clean_priority;
  ($clean_priority = $priority) =~ s/-/neg/;
  my $scoreset = $conf->get_score_set();
  my $package_name = __PACKAGE__;

  my $methodname = '_eval_tests'.
    '_type'.$testtype .
      '_pri'.$clean_priority .
	'_set'.$scoreset;

  # Some of the rules are scoreset specific, so we need additional
  # subroutines to handle those
  if (defined &{"${package_name}::${methodname}"}
      && !$doing_user_rules)
  {
    my $method = "${package_name}::${methodname}";
    #dbg("rules: run_eval_tests - calling previously compiled %s", $method);
    my $t = Mail::SpamAssassin::Timeout->new({ deadline => $master_deadline });
    my $err = $t->run(sub {
      no strict "refs";
      &{$method}($pms,@extraevalargs);
    });
    if ($t->timed_out() && $master_deadline && time > $master_deadline) {
      info("check: exceeded time limit in $method, skipping further tests");
      $pms->{deadline_exceeded} = 1;
    }
    return;
  }

  # look these up once in advance to save repeated lookups in loop below
  my $evalhash = $conf->{$evalname}->{$priority};
  my $tflagsref = $conf->{tflags};
  my $scoresref = $conf->{scores};
  my $eval_pluginsref = $conf->{eval_plugins};
  my $have_start_rules = $self->{main}->have_plugin("start_rules");
  my $have_ran_rule = $self->{main}->have_plugin("ran_rule");

  # the buffer for the evaluated code
  my $evalstr = '';

  # conditionally include the dbg in the eval str
  my $dbgstr = '';
  if (would_log('dbg')) {
    $dbgstr = 'dbg("rules: ran eval rule $rulename ======> got hit ($result)");';
  }

  while (my ($rulename, $test) = each %{$evalhash}) {
    if ($tflagsref->{$rulename}) {
      # If the rule is a net rule, and we are in a non-net scoreset, skip it.
      if ($tflagsref->{$rulename} =~ /\bnet\b/) {
        next if (($scoreset & 1) == 0);
      }
      # If the rule is a bayes rule, and we are in a non-bayes scoreset, skip it.
      if ($tflagsref->{$rulename} =~ /\blearn\b/) {
        next if (($scoreset & 2) == 0);
      }
    }

    # skip if score zeroed
    next if !$scoresref->{$rulename};

    my $function = untaint_var($test->[0]); # was validated with \w+
    if (!$function) {
      warn "rules: error: no eval function defined for $rulename";
      next;
    }

    if (!exists $conf->{eval_plugins}->{$function}) {
      warn("rules: error: unknown eval '$function' for $rulename\n");
      next;
    }

    $evalstr .= '
        {
            $rulename = q#'.$rulename.'#;
            %{$self->{test_log_msgs}} = ();
';

    # only need to set current_rule_name for plugin evals
    if ($eval_pluginsref->{$function}) {
      # let plugins get the name of the rule that is currently being run,
      # and ensure their eval functions exist
      $evalstr .= '
            $self->{current_rule_name} = $rulename;
            $self->register_plugin_eval_glue(q#'.$function.'#);
';
    }

    # this stuff is quite slow, and totally superfluous if
    # no plugin is loaded for those hooks
    if ($have_start_rules) {
      # XXX - should we use helper function here?
      $evalstr .= '
                $self->{main}->call_plugins("start_rules", {
                                permsgstatus => $self,
                                ruletype => "eval",
                                priority => '.$priority.'
                            });

';
    }

    $evalstr .= '
            eval {
                $result = $self->'.$function.'(@extraevalargs, @{$testptr->{q#'.$rulename.'#}->[1]}); 1;
            } or do {
                $result = 0;
                die "rules: $@\n"  if $@ =~ /__alarm__ignore__/;
                $self->handle_eval_rule_errors($rulename);
            };
';

    if ($have_ran_rule) {
      # XXX - should we use helper function here?
      $evalstr .= '
                $self->{main}->call_plugins("ran_rule", {
                        permsgstatus => $self, ruletype => "eval", rulename => $rulename
                    });
';
    }

    $evalstr .= '
            if ($result) {
                $self->got_hit($rulename, $prepend2desc, ruletype => "eval", value => $result);
                '.$dbgstr.'
            }
        }
';
  }

  # don't free the eval ruleset here -- we need it in the compiled code!

  # nothing done in the loop, that means no rules
  return unless ($evalstr);

  $evalstr = <<"EOT";
{
  package $package_name;

  sub ${methodname} {
    my (\$self, \@extraevalargs) = \@_;

    my \$testptr = \$self->{conf}->{$evalname}->{$priority};
    my \$prepend2desc = q#$prepend2desc#;
    my \$rulename;
    my \$result;
    $evalstr
  }

  1;
}
EOT

  undef &{$methodname};

  dbg("rules: run_eval_tests - compiling eval code: %s, priority %s",
       $testtype, $priority);
# dbg("rules: eval code(3): %s", $evalstr);
  my $eval_result;
  { my $timer = $self->{main}->time_method('compile_eval');
    $eval_result = eval($evalstr);
  }
  if (!$eval_result) {
    my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    warn "rules: failed to compile eval tests, skipping some: $eval_stat\n";
    $self->{rule_errors}++;
  }
  else {
    my $method = "${package_name}::${methodname}";
    push (@TEMPORARY_METHODS, $methodname);
  # dbg("rules: run_eval_tests - calling the just compiled %s", $method);
    my $t = Mail::SpamAssassin::Timeout->new({ deadline => $master_deadline });
    my $err = $t->run(sub {
      no strict "refs";
      &{$method}($pms,@extraevalargs);
    });
    if ($t->timed_out() && $master_deadline && time > $master_deadline) {
      info("check: exceeded time limit in $method, skipping further tests");
      $pms->{deadline_exceeded} = 1;
    }
  }
}

###########################################################################
# Helper Functions

  my ($self, $pms, $rulename) = @_;
  # using tainted subr. argument may taint the whole expression, avoid
  my $u = untaint_var($pms->{conf}->{source_file}->{$rulename});
  return sprintf("\n#line 1 \"%s, rule %s,\"", $u, $rulename);
# return sprintf("\n#line 1 \"%s, rule %s,\"", $u, $rulename) .
#        "\ndbg(\"rules: will run %s\", q(".$rulename."));\n";
}

  my ($self, $subname) = @_;
  my $package_name = __PACKAGE__;
  return 0 if (eval 'defined &'.$package_name.'::'.$subname);
  1;
}

  my ($self, $ruletype, $pri) = @_;

  my $evalstr = '';
  if ($self->{main}->have_plugin("start_rules")) {
    $evalstr .= '

            $self->{main}->call_plugins ("start_rules", { permsgstatus => $self,
                                                                                                        ruletype => \''.$ruletype.'\',
                                                                                                        priority => '.$pri.' });

        ';
  }

  return $evalstr;
}

  my ($self, $pms, $rulename, $ruletype, $loop_break_directive,
      $matching_string_unavailable) = @_;

  # note: keep this in 'single quotes' to avoid the $ & performance hit,
  # unless specifically requested by the caller.   Also split the
  # two chars, just to be paranoid and ensure that a buggy perl interp
  # doesn't impose that hit anyway (just in case)
  my $match;
  if ($matching_string_unavailable) {
    $match = '"<YES>"'; # nothing better to report, $& is not set by this rule
  } else {
    # simple, but suffers from 'user data interpreted as a boolean', Bug 6360
    $match = '(defined $'.'& ? $'.'& : "negative match")';
  }

  my $debug_code = '';
  if (exists($pms->{should_log_rule_hits})) {
    $debug_code = '
                dbg("rules: ran '.$ruletype.' rule '.$rulename.' ======> got hit: \"" . '.
            $match.' . "\"");
        ';
  }

  my $save_hits_code = '';
  if ($pms->{save_pattern_hits}) {
    $save_hits_code = '
                $self->{pattern_hits}->{q{'.$rulename.'}} = '.$match.';
        ';
  }

  # if we're not running "tflags multiple", break out of the matching
  # loop this way
  my $multiple_code = '';
  if ($loop_break_directive &&
      ($pms->{conf}->{tflags}->{$rulename}||'') !~ /\bmultiple\b/) {
    $multiple_code = $loop_break_directive.';';
  }

  return $debug_code.$save_hits_code.$multiple_code;
}

  my ($self, $rulename, $ruletype) = @_;

  return '' unless $self->{main}->have_plugin("ran_rule");

  # The $self here looks odd, but since we are inserting this into eval'd code it
  # needs to be $self which in that case is actually the PerMsgStatus object
  return '
        $self->{main}->call_plugins ("ran_rule", { permsgstatus => $self, rulename => \''.$rulename.'\', ruletype => \''.$ruletype.'\' });
    ';
}

  my ($self, $pms, $type, $pri) = @_;

  # we can't do this, if we may need to recompile them again later
  return if $pms->{conf}->{allow_user_rules};

  # remove now-compiled rulesets
  if (exists $pms->{conf}->{$type.'_tests'}->{$pri}) {
    delete $pms->{conf}->{$type.'_tests'}->{$pri};
  }
}

###########################################################################

1;