home *** CD-ROM | disk | FTP | other *** search
/ ftp.f-secure.com / 2014.06.ftp.f-secure.com.tar / ftp.f-secure.com / support / hotfix / fsis / IS-SpamControl.fsfix / iufssc / lib / Mail / SpamAssassin / Bayes.pm < prev    next >
Text File  |  2006-11-29  |  44KB  |  1,418 lines
  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::Bayes - determine spammishness using a Bayesian classifier
  21.  
  22. =head1 DESCRIPTION
  23.  
  24. This is a Bayesian-like form of probability-analysis classification, using an
  25. algorithm based on the one detailed in Paul Graham's I<A Plan For Spam> paper
  26. at:
  27.  
  28.   http://www.paulgraham.com/spam.html
  29.  
  30. It also incorporates some other aspects taken from Graham Robinson's webpage
  31. on the subject at:
  32.  
  33.   http://radio.weblogs.com/0101454/stories/2002/09/16/spamDetection.html
  34.  
  35. And the chi-square probability combiner as described here:
  36.  
  37.   http://www.linuxjournal.com/print.php?sid=6467
  38.  
  39. The results are incorporated into SpamAssassin as the BAYES_* rules.
  40.  
  41. =head1 METHODS
  42.  
  43. =over 4
  44.  
  45. =cut
  46.  
  47. package Mail::SpamAssassin::Bayes;
  48.  
  49. use strict;
  50. use warnings;
  51. use bytes;
  52.  
  53. use Mail::SpamAssassin;
  54. use Mail::SpamAssassin::PerMsgStatus;
  55. use Mail::SpamAssassin::Logger;
  56.  
  57. # pick ONLY ONE of these combining implementations.
  58. use Mail::SpamAssassin::Bayes::CombineChi;
  59. # use Mail::SpamAssassin::Bayes::CombineNaiveBayes;
  60.  
  61. use Digest::SHA1 qw(sha1 sha1_hex);
  62.  
  63. use vars qw{
  64.   @ISA
  65.   $IGNORED_HDRS
  66.   $MARK_PRESENCE_ONLY_HDRS
  67.   %HEADER_NAME_COMPRESSION
  68.   $OPPORTUNISTIC_LOCK_VALID
  69. };
  70.  
  71. @ISA = qw();
  72.  
  73. # Which headers should we scan for tokens?  Don't use all of them, as it's easy
  74. # to pick up spurious clues from some.  What we now do is use all of them
  75. # *less* these well-known headers; that way we can pick up spammers' tracking
  76. # headers (which are obviously not well-known in advance!).
  77.  
  78. # Received is handled specially
  79. $IGNORED_HDRS = qr{(?: (?:X-)?Sender    # misc noise
  80.   |Delivered-To |Delivery-Date
  81.   |(?:X-)?Envelope-To
  82.   |X-MIME-Auto[Cc]onverted |X-Converted-To-Plain-Text
  83.  
  84.   |Subject      # not worth a tiny gain vs. to db size increase
  85.  
  86.   # Date: can provide invalid cues if your spam corpus is
  87.   # older/newer than ham
  88.   |Date
  89.  
  90.   # List headers: ignore. a spamfiltering mailing list will
  91.   # become a nonspam sign.
  92.   |X-List|(?:X-)?Mailing-List
  93.   |(?:X-)?List-(?:Archive|Help|Id|Owner|Post|Subscribe
  94.     |Unsubscribe|Host|Id|Manager|Admin|Comment
  95.     |Name|Url)
  96.   |X-Unsub(?:scribe)?
  97.   |X-Mailman-Version |X-Been[Tt]here |X-Loop
  98.   |Mail-Followup-To
  99.   |X-eGroups-(?:Return|From)
  100.   |X-MDMailing-List
  101.   |X-XEmacs-List
  102.  
  103.   # gatewayed through mailing list (thanks to Allen Smith)
  104.   |(?:X-)?Resent-(?:From|To|Date)
  105.   |(?:X-)?Original-(?:From|To|Date)
  106.  
  107.   # Spamfilter/virus-scanner headers: too easy to chain from
  108.   # these
  109.   |X-MailScanner(?:-SpamCheck)?
  110.   |X-Spam(?:-(?:Status|Level|Flag|Report|Hits|Score|Checker-Version))?
  111.   |X-Antispam |X-RBL-Warning |X-Mailscanner
  112.   |X-MDaemon-Deliver-To |X-Virus-Scanned
  113.   |X-Mass-Check-Id
  114.   |X-Pyzor |X-DCC-\S{2,25}-Metrics
  115.   |X-Filtered-B[Yy] |X-Scanned-By |X-Scanner
  116.   |X-AP-Spam-(?:Score|Status) |X-RIPE-Spam-Status
  117.   |X-SpamCop-[^:]+
  118.   |X-SMTPD |(?:X-)?Spam-Apparently-To
  119.   |SPAM |X-Perlmx-Spam
  120.   |X-Bogosity
  121.  
  122.   # some noisy Outlook headers that add no good clues:
  123.   |Content-Class |Thread-(?:Index|Topic)
  124.   |X-Original[Aa]rrival[Tt]ime
  125.  
  126.   # Annotations from IMAP, POP, and MH:
  127.   |(?:X-)?Status |X-Flags |Replied |Forwarded
  128.   |Lines |Content-Length
  129.   |X-UIDL? |X-IMAPbase
  130.  
  131.   # Annotations from Bugzilla
  132.   |X-Bugzilla-[^:]+
  133.  
  134.   # Annotations from VM: (thanks to Allen Smith)
  135.   |X-VM-(?:Bookmark|(?:POP|IMAP)-Retrieved|Labels|Last-Modified
  136.     |Summary-Format|VHeader|v\d-Data|Message-Order)
  137.  
  138.   # Annotations from Gnus:
  139.   | X-Gnus-Mail-Source
  140.   | Xref
  141.  
  142. )}x;
  143.  
  144. # Note only the presence of these headers, in order to reduce the
  145. # hapaxen they generate.
  146. $MARK_PRESENCE_ONLY_HDRS = qr{(?: X-Face
  147.   |X-(?:Gnu-?PG|PGP|GPG)(?:-Key)?-Fingerprint
  148. )}ix;
  149.  
  150. # tweaks tested as of Nov 18 2002 by jm: see SpamAssassin-devel list archives
  151. # for results.  The winners are now the default settings.
  152. use constant IGNORE_TITLE_CASE => 1;
  153. use constant TOKENIZE_LONG_8BIT_SEQS_AS_TUPLES => 1;
  154. use constant TOKENIZE_LONG_TOKENS_AS_SKIPS => 1;
  155.  
  156. # tweaks of May 12 2003, see SpamAssassin-devel archives again.
  157. use constant PRE_CHEW_ADDR_HEADERS => 1;
  158. use constant CHEW_BODY_URIS => 1;
  159. use constant CHEW_BODY_MAILADDRS => 1;
  160. use constant HDRS_TOKENIZE_LONG_TOKENS_AS_SKIPS => 1;
  161. use constant BODY_TOKENIZE_LONG_TOKENS_AS_SKIPS => 1;
  162. use constant URIS_TOKENIZE_LONG_TOKENS_AS_SKIPS => 0;
  163. use constant IGNORE_MSGID_TOKENS => 0;
  164.  
  165. # tweaks of 12 March 2004, see bug 2129.
  166. use constant DECOMPOSE_BODY_TOKENS => 1;
  167. use constant MAP_HEADERS_MID => 1;
  168. use constant MAP_HEADERS_FROMTOCC => 1;
  169. use constant MAP_HEADERS_USERAGENT => 1;
  170.  
  171. # tweaks, see http://issues.apache.org/SpamAssassin/show_bug.cgi?id=3173#c26
  172. use constant ADD_INVIZ_TOKENS_I_PREFIX => 1;
  173. use constant ADD_INVIZ_TOKENS_NO_PREFIX => 0;
  174.  
  175. # We store header-mined tokens in the db with a "HHeaderName:val" format.
  176. # some headers may contain lots of gibberish tokens, so allow a little basic
  177. # compression by mapping the header name at least here.  these are the headers
  178. # which appear with the most frequency in my db.  note: this doesn't have to
  179. # be 2-way (ie. LHSes that map to the same RHS are not a problem), but mixing
  180. # tokens from multiple different headers may impact accuracy, so might as well
  181. # avoid this if possible. These are the top ones from my corpus, BTW (jm).
  182. %HEADER_NAME_COMPRESSION = (
  183.   'Message-Id'        => '*m',
  184.   'Message-ID'        => '*M',
  185.   'Received'        => '*r',
  186.   'User-Agent'        => '*u',
  187.   'References'        => '*f',
  188.   'In-Reply-To'        => '*i',
  189.   'From'        => '*F',
  190.   'Reply-To'        => '*R',
  191.   'Return-Path'        => '*p',
  192.   'Return-path'        => '*rp',
  193.   'X-Mailer'        => '*x',
  194.   'X-Authentication-Warning' => '*a',
  195.   'Organization'    => '*o',
  196.   'Organisation'        => '*o',
  197.   'Content-Type'    => '*c',
  198.   'X-Spam-Relays-Trusted' => '*RT',
  199.   'X-Spam-Relays-Untrusted' => '*RU',
  200. );
  201.  
  202. # How many seconds should the opportunistic_expire lock be valid?
  203. $OPPORTUNISTIC_LOCK_VALID = 300;
  204.  
  205. # Should we use the Robinson f(w) equation from
  206. # http://radio.weblogs.com/0101454/stories/2002/09/16/spamDetection.html ?
  207. # It gives better results, in that scores are more likely to distribute
  208. # into the <0.5 range for nonspam and >0.5 for spam.
  209. use constant USE_ROBINSON_FX_EQUATION_FOR_LOW_FREQS => 1;
  210.  
  211. # How many of the most significant tokens should we use for the p(w)
  212. # calculation?
  213. use constant N_SIGNIFICANT_TOKENS => 150;
  214.  
  215. # How many significant tokens are required for a classifier score to
  216. # be considered usable?
  217. #use constant REQUIRE_SIGNIFICANT_TOKENS_TO_SCORE => -1;
  218. use constant REQUIRE_SIGNIFICANT_TOKENS_TO_SCORE => 50;
  219.  
  220. # How long a token should we hold onto?  (note: German speakers typically
  221. # will require a longer token than English ones.)
  222. use constant MAX_TOKEN_LENGTH => 15;
  223.  
  224. ###########################################################################
  225.  
  226. sub new {
  227.   my $class = shift;
  228.   $class = ref($class) || $class;
  229.  
  230.   my ($main) = @_;
  231.   my $self = {
  232.     'main'              => $main,
  233.     'conf'        => $main->{conf},
  234.     'log_raw_counts'    => 0,
  235.     'use_ignores'       => 1,
  236.     'tz'        => Mail::SpamAssassin::Util::local_tz(),
  237.   };
  238.   bless ($self, $class);
  239.  
  240.   if ($self->{conf}->{bayes_store_module}) {
  241.     my $module = $self->{conf}->{bayes_store_module};
  242.     my $store;
  243.  
  244.     eval '
  245.       require '.$module.';
  246.       $store = '.$module.'->new($self);
  247.     ';
  248.     if ($@) { die $@; }
  249.     $self->{store} = $store;
  250.   }
  251.   else {
  252.     require Mail::SpamAssassin::BayesStore::DBM;
  253.     $self->{store} = Mail::SpamAssassin::BayesStore::DBM->new($self);
  254.   }
  255.  
  256.   $self;
  257. }
  258.  
  259. sub finish {
  260.   my $self = shift;
  261.   #if (!$self->{conf}->{use_bayes}) { return; }
  262.  
  263.   # if we're untying too much, uncomment this...
  264.   # use Carp qw(cluck); cluck "stack trace at untie";
  265.  
  266.   $self->{store}->untie_db();
  267.   delete $self->{store};
  268. }
  269.  
  270. sub sa_die { Mail::SpamAssassin::sa_die(@_); }
  271.  
  272. ###########################################################################
  273.  
  274. sub sanity_check_is_untied {
  275.   my $self = shift;
  276.   my $quiet = shift;
  277.  
  278.   # do a sanity check here.  Wierd things happen if we remain tied
  279.   # after compiling; for example, spamd will never see that the
  280.   # number of messages has reached the bayes-scanning threshold.
  281.   if ($self->{store}->db_readable()) {
  282.     warn "bayes: oops! still tied to bayes DBs, untying\n" unless $quiet;
  283.     $self->{store}->untie_db();
  284.   }
  285. }
  286.  
  287. ###########################################################################
  288.  
  289. # read configuration items to control bayes behaviour.  Called by
  290. # BayesStore::read_db_configs().
  291. sub read_db_configs {
  292.   my ($self) = @_;
  293.  
  294.   # use of hapaxes.  Set on bayes object, since it controls prob
  295.   # computation.
  296.   $self->{use_hapaxes} = $self->{conf}->{bayes_use_hapaxes};
  297. }
  298.  
  299. ###########################################################################
  300.  
  301. # The calling functions expect a uniq'ed array of tokens ...
  302. sub tokenize {
  303.   my ($self, $msg, $msgdata) = @_;
  304.  
  305.   # the body
  306.   my @tokens = map { $self->tokenize_line ($_, '', 1) }
  307.                                     @{$msgdata->{bayes_token_body}};
  308.  
  309.   # the URI list
  310.   push (@tokens, map { $self->tokenize_line ($_, '', 2) }
  311.                                     @{$msgdata->{bayes_token_uris}});
  312.  
  313.   # add invisible tokens
  314.   if (ADD_INVIZ_TOKENS_I_PREFIX) {
  315.     push (@tokens, map { $self->tokenize_line ($_, "I*:", 1) }
  316.                                     @{$msgdata->{bayes_token_inviz}});
  317.   }
  318.   if (ADD_INVIZ_TOKENS_NO_PREFIX) {
  319.     push (@tokens, map { $self->tokenize_line ($_, "", 1) }
  320.                                     @{$msgdata->{bayes_token_inviz}});
  321.   }
  322.  
  323.   # Tokenize the headers
  324.   my %hdrs = $self->tokenize_headers ($msg);
  325.   while( my($prefix, $value) = each %hdrs ) {
  326.     push(@tokens, $self->tokenize_line ($value, "H$prefix:", 0));
  327.   }
  328.  
  329.   # Go ahead and uniq the array, skip null tokens (can happen sometimes)
  330.   # generate an SHA1 hash and take the lower 40 bits as our token
  331.   my %tokens;
  332.   foreach my $token (@tokens) {
  333.     next unless length($token); # skip 0 length tokens
  334.     $tokens{substr(sha1($token), -5)} = $token;
  335.   }
  336.  
  337.   # return the keys == tokens ...
  338.   return \%tokens;
  339. }
  340.  
  341. sub tokenize_line {
  342.   my $self = $_[0];
  343.   my $tokprefix = $_[2];
  344.   my $region = $_[3];
  345.   local ($_) = $_[1];
  346.  
  347.   my @rettokens = ();
  348.  
  349.   # include quotes, .'s and -'s for URIs, and [$,]'s for Nigerian-scam strings,
  350.   # and ISO-8859-15 alphas.  Do not split on @'s; better results keeping it.
  351.   # Some useful tokens: "$31,000,000" "www.clock-speed.net" "f*ck" "Hits!"
  352.   tr/-A-Za-z0-9,\@\*\!_'"\$.\241-\377 / /cs;
  353.  
  354.   # DO split on "..." or "--" or "---"; common formatting error resulting in
  355.   # hapaxes.  Keep the separator itself as a token, though, as long ones can
  356.   # be good spamsigns.
  357.   s/(\w)(\.{3,6})(\w)/$1 $2 $3/gs;
  358.   s/(\w)(\-{2,6})(\w)/$1 $2 $3/gs;
  359.  
  360.   if (IGNORE_TITLE_CASE) {
  361.     if ($region == 1 || $region == 2) {
  362.       # lower-case Title Case at start of a full-stop-delimited line (as would
  363.       # be seen in a Western language).
  364.       s/(?:^|\.\s+)([A-Z])([^A-Z]+)(?:\s|$)/ ' '. (lc $1) . $2 . ' ' /ge;
  365.     }
  366.   }
  367.  
  368.   my $magic_re = $self->{store}->get_magic_re();
  369.  
  370.   foreach my $token (split) {
  371.     $token =~ s/^[-'"\.,]+//;        # trim non-alphanum chars at start or end
  372.     $token =~ s/[-'"\.,]+$//;        # so we don't get loads of '"foo' tokens
  373.  
  374.     # Skip false magic tokens
  375.     # TVD: we need to do a defined() check since SQL doesn't have magic
  376.     # tokens, so the SQL BayesStore returns undef.  I really want a way
  377.     # of optimizing that out, but I haven't come up with anything yet.
  378.     #
  379.     next if ( defined $magic_re && /$magic_re/ );
  380.  
  381.     # *do* keep 3-byte tokens; there's some solid signs in there
  382.     my $len = length($token);
  383.  
  384.     # but extend the stop-list. These are squarely in the gray
  385.     # area, and it just slows us down to record them.
  386.     next if $len < 3 ||
  387.        # SDBM workaround: Don't do tokens longer than 1000 characters
  388.        $len > 1000 ||
  389.     ($token =~ /^(?:a(?:nd|ny|ble|ll|re)|
  390.         m(?:uch|ost|ade|ore|ail|ake|ailing|any|ailto)|
  391.         t(?:his|he|ime|hrough|hat)|
  392.         w(?:hy|here|ork|orld|ith|ithout|eb)|
  393.         f(?:rom|or|ew)| e(?:ach|ven|mail)|
  394.         o(?:ne|ff|nly|wn|ut)| n(?:ow|ot|eed)|
  395.         s(?:uch|ame)| l(?:ook|ike|ong)|
  396.         y(?:ou|our|ou're)|
  397.         The|has|have|into|using|http|see|It's|it's|
  398.         number|just|both|come|years|right|know|already|
  399.         people|place|first|because|
  400.         And|give|year|information|can)$/x);
  401.  
  402.     # are we in the body?  If so, apply some body-specific breakouts
  403.     if ($region == 1 || $region == 2) {
  404.       if (CHEW_BODY_MAILADDRS && $token =~ /\S\@\S/i) {
  405.     push (@rettokens, $self->tokenize_mail_addrs ($token));
  406.       }
  407.       elsif (CHEW_BODY_URIS && $token =~ /\S\.[a-z]/i) {
  408.     push (@rettokens, "UD:".$token); # the full token
  409.     my $bit = $token; while ($bit =~ s/^[^\.]+\.(.+)$/$1/gs) {
  410.       push (@rettokens, "UD:".$1); # UD = URL domain
  411.     }
  412.       }
  413.     }
  414.  
  415.     # note: do not trim down overlong tokens if they contain '*'.  This is
  416.     # used as part of split tokens such as "HTo:D*net" indicating that 
  417.     # the domain ".net" appeared in the To header.
  418.     #
  419.     if ($len > MAX_TOKEN_LENGTH && $token !~ /\*/) {
  420.       if (TOKENIZE_LONG_8BIT_SEQS_AS_TUPLES && $token =~ /[\xa0-\xff]{2}/) {
  421.     # Matt sez: "Could be asian? Autrijus suggested doing character ngrams,
  422.     # but I'm doing tuples to keep the dbs small(er)."  Sounds like a plan
  423.     # to me! (jm)
  424.     while ($token =~ s/^(..?)//) {
  425.       push (@rettokens, "8:$1");
  426.     }
  427.     next;
  428.       }
  429.  
  430.       if (($region == 0 && HDRS_TOKENIZE_LONG_TOKENS_AS_SKIPS)
  431.             || ($region == 1 && BODY_TOKENIZE_LONG_TOKENS_AS_SKIPS)
  432.             || ($region == 2 && URIS_TOKENIZE_LONG_TOKENS_AS_SKIPS))
  433.       {
  434.     # if (TOKENIZE_LONG_TOKENS_AS_SKIPS)
  435.     # Spambayes trick via Matt: Just retain 7 chars.  Do not retain
  436.     # the length, it does not help; see my mail to -devel of Nov 20 2002.
  437.     # "sk:" stands for "skip".
  438.     $token = "sk:".substr($token, 0, 7);
  439.       }
  440.     }
  441.  
  442.     # decompose tokens?  do this after shortening long tokens
  443.     if ($region == 1 || $region == 2) {
  444.       if (DECOMPOSE_BODY_TOKENS) {
  445.         if ($token =~ /[^\w:\*]/) {
  446.           my $decompd = $token;                        # "Foo!"
  447.           $decompd =~ s/[^\w:\*]//gs;
  448.           push (@rettokens, $tokprefix.$decompd);      # "Foo"
  449.         }
  450.  
  451.         if ($token =~ /[A-Z]/) {
  452.           my $decompd = $token; $decompd = lc $decompd;
  453.           push (@rettokens, $tokprefix.$decompd);      # "foo!"
  454.  
  455.           if ($token =~ /[^\w:\*]/) {
  456.             $decompd =~ s/[^\w:\*]//gs;
  457.             push (@rettokens, $tokprefix.$decompd);    # "foo"
  458.           }
  459.         }
  460.       }
  461.     }
  462.  
  463.     push (@rettokens, $tokprefix.$token);
  464.   }
  465.  
  466.   return @rettokens;
  467. }
  468.  
  469. sub tokenize_headers {
  470.   my ($self, $msg) = @_;
  471.  
  472.   my %parsed = ();
  473.  
  474.   my %user_ignore;
  475.   $user_ignore{lc $_} = 1 for @{$self->{main}->{conf}->{bayes_ignore_headers}};
  476.  
  477.   # get headers in array context
  478.   my @hdrs;
  479.   my @rcvdlines;
  480.   for ($msg->get_all_headers()) {
  481.     # first, keep a copy of Received headers, so we can strip down to last 2
  482.     if (/^Received:/i) {
  483.       push(@rcvdlines, $_);
  484.       next;
  485.     }
  486.     # and now skip lines for headers we don't want (including all Received)
  487.     next if /^${IGNORED_HDRS}:/i;
  488.     next if IGNORE_MSGID_TOKENS && /^Message-ID:/i;
  489.     push(@hdrs, $_);
  490.   }
  491.   push(@hdrs, $msg->get_all_metadata());
  492.  
  493.   # and re-add the last 2 received lines: usually a good source of
  494.   # spamware tokens and HELO names.
  495.   if ($#rcvdlines >= 0) { push(@hdrs, $rcvdlines[$#rcvdlines]); }
  496.   if ($#rcvdlines >= 1) { push(@hdrs, $rcvdlines[$#rcvdlines-1]); }
  497.  
  498.   for (@hdrs) {
  499.     next unless /\S/;
  500.     my ($hdr, $val) = split(/:/, $_, 2);
  501.  
  502.     # remove user-specified headers here, after Received, in case they
  503.     # want to ignore that too
  504.     next if exists $user_ignore{lc $hdr};
  505.  
  506.     # Prep the header value
  507.     $val ||= '';
  508.     chomp($val);
  509.  
  510.     # special tokenization for some headers:
  511.     if ($hdr =~ /^(?:|X-|Resent-)Message-Id$/i) {
  512.       $val = $self->pre_chew_message_id ($val);
  513.     }
  514.     elsif (PRE_CHEW_ADDR_HEADERS && $hdr =~ /^(?:|X-|Resent-)
  515.     (?:Return-Path|From|To|Cc|Reply-To|Errors-To|Mail-Followup-To|Sender)$/ix)
  516.     {
  517.       $val = $self->pre_chew_addr_header ($val);
  518.     }
  519.     elsif ($hdr eq 'Received') {
  520.       $val = $self->pre_chew_received ($val);
  521.     }
  522.     elsif ($hdr eq 'Content-Type') {
  523.       $val = $self->pre_chew_content_type ($val);
  524.     }
  525.     elsif ($hdr eq 'MIME-Version') {
  526.       $val =~ s/1\.0//;        # totally innocuous
  527.     }
  528.     elsif ($hdr =~ /^${MARK_PRESENCE_ONLY_HDRS}$/i) {
  529.       $val = "1"; # just mark the presence, they create lots of hapaxen
  530.     }
  531.  
  532.     if (MAP_HEADERS_MID) {
  533.       if ($hdr =~ /^(?:In-Reply-To|References|Message-ID)$/i) {
  534.         $parsed{"*MI"} = $val;
  535.       }
  536.     }
  537.     if (MAP_HEADERS_FROMTOCC) {
  538.       if ($hdr =~ /^(?:From|To|Cc)$/i) {
  539.         $parsed{"*Ad"} = $val;
  540.       }
  541.     }
  542.     if (MAP_HEADERS_USERAGENT) {
  543.       if ($hdr =~ /^(?:X-Mailer|User-Agent)$/i) {
  544.         $parsed{"*UA"} = $val;
  545.       }
  546.     }
  547.  
  548.     # replace hdr name with "compressed" version if possible
  549.     if (defined $HEADER_NAME_COMPRESSION{$hdr}) {
  550.       $hdr = $HEADER_NAME_COMPRESSION{$hdr};
  551.     }
  552.  
  553.     if (exists $parsed{$hdr}) {
  554.       $parsed{$hdr} .= " ".$val;
  555.     } else {
  556.       $parsed{$hdr} = $val;
  557.     }
  558.     if (would_log('dbg', 'bayes') > 1) {
  559.       dbg("bayes: header tokens for $hdr = \"$parsed{$hdr}\"");
  560.     }
  561.   }
  562.  
  563.   return %parsed;
  564. }
  565.  
  566. sub pre_chew_content_type {
  567.   my ($self, $val) = @_;
  568.  
  569.   # hopefully this will retain good bits without too many hapaxen
  570.   if ($val =~ s/boundary=[\"\'](.*?)[\"\']/ /ig) {
  571.     my $boundary = $1;
  572.     $boundary =~ s/[a-fA-F0-9]/H/gs;
  573.     # break up blocks of separator chars so they become their own tokens
  574.     $boundary =~ s/([-_\.=]+)/ $1 /gs;
  575.     $val .= $boundary;
  576.   }
  577.  
  578.   # stop-list words for Content-Type header: these wind up totally gray
  579.   $val =~ s/\b(?:text|charset)\b//;
  580.  
  581.   $val;
  582. }
  583.  
  584. sub pre_chew_message_id {
  585.   my ($self, $val) = @_;
  586.   # we can (a) get rid of a lot of hapaxen and (b) increase the token
  587.   # specificity by pre-parsing some common formats.
  588.  
  589.   # Outlook Express format:
  590.   $val =~ s/<([0-9a-f]{4})[0-9a-f]{4}[0-9a-f]{4}\$
  591.            ([0-9a-f]{4})[0-9a-f]{4}\$
  592.            ([0-9a-f]{8})\@(\S+)>/ OEA$1 OEB$2 OEC$3 $4 /gx;
  593.  
  594.   # Exim:
  595.   $val =~ s/<[A-Za-z0-9]{7}-[A-Za-z0-9]{6}-0[A-Za-z0-9]\@//;
  596.  
  597.   # Sendmail:
  598.   $val =~ s/<20\d\d[01]\d[0123]\d[012]\d[012345]\d[012345]\d\.
  599.            [A-F0-9]{10,12}\@//gx;
  600.  
  601.   # try to split Message-ID segments on probable ID boundaries. Note that
  602.   # Outlook message-ids seem to contain a server identifier ID in the last
  603.   # 8 bytes before the @.  Make sure this becomes its own token, it's a
  604.   # great spam-sign for a learning system!  Be sure to split on ".".
  605.   $val =~ s/[^_A-Za-z0-9]/ /g;
  606.   $val;
  607. }
  608.  
  609. sub pre_chew_received {
  610.   my ($self, $val) = @_;
  611.  
  612.   # Thanks to Dan for these.  Trim out "useless" tokens; sendmail-ish IDs
  613.   # and valid-format RFC-822/2822 dates
  614.  
  615.   $val =~ s/\swith\sSMTP\sid\sg[\dA-Z]{10,12}\s/ /gs;  # Sendmail
  616.   $val =~ s/\swith\sESMTP\sid\s[\dA-F]{10,12}\s/ /gs;  # Sendmail
  617.   $val =~ s/\bid\s[a-zA-Z0-9]{7,20}\b/ /gs;    # Sendmail
  618.   $val =~ s/\bid\s[A-Za-z0-9]{7}-[A-Za-z0-9]{6}-0[A-Za-z0-9]/ /gs; # exim
  619.  
  620.   $val =~ s/(?:(?:Mon|Tue|Wed|Thu|Fri|Sat|Sun),\s)?
  621.            [0-3\s]?[0-9]\s
  622.            (?:Jan|Feb|Ma[ry]|Apr|Ju[nl]|Aug|Sep|Oct|Nov|Dec)\s
  623.            (?:19|20)?[0-9]{2}\s
  624.            [0-2][0-9](?:\:[0-5][0-9]){1,2}\s
  625.            (?:\s*\(|\)|\s*(?:[+-][0-9]{4})|\s*(?:UT|[A-Z]{2,3}T))*
  626.            //gx;
  627.  
  628.   # IPs: break down to nearest /24, to reduce hapaxes -- EXCEPT for
  629.   # IPs in the 10 and 192.168 ranges, they gets lots of significant tokens
  630.   # (on both sides)
  631.   # also make a dup with the full IP, as fodder for
  632.   # bayes_dump_to_trusted_networks: "H*r:ip*aaa.bbb.ccc.ddd"
  633.   $val =~ s{\b(\d{1,3}\.)(\d{1,3}\.)(\d{1,3})(\.\d{1,3})\b}{
  634.            if ($2 eq '10' || ($2 eq '192' && $3 eq '168')) {
  635.              $1.$2.$3.$4.
  636.         " ip*".$1.$2.$3.$4." ";
  637.            } else {
  638.              $1.$2.$3.
  639.         " ip*".$1.$2.$3.$4." ";
  640.            }
  641.          }gex;
  642.  
  643.   # trim these: they turn out as the most common tokens, but with a
  644.   # prob of about .5.  waste of space!
  645.   $val =~ s/\b(?:with|from|for|SMTP|ESMTP)\b/ /g;
  646.  
  647.   $val;
  648. }
  649.  
  650. sub pre_chew_addr_header {
  651.   my ($self, $val) = @_;
  652.   local ($_);
  653.  
  654.   my @addrs = $self->{main}->find_all_addrs_in_line ($val);
  655.   my @toks = ();
  656.   foreach (@addrs) {
  657.     push (@toks, $self->tokenize_mail_addrs ($_));
  658.   }
  659.   return join (' ', @toks);
  660. }
  661.  
  662. sub tokenize_mail_addrs {
  663.   my ($self, $addr) = @_;
  664.  
  665.   ($addr =~ /(.+)\@(.+)$/) or return ();
  666.   my @toks = ();
  667.   push(@toks, "U*".$1, "D*".$2);
  668.   $_ = $2; while (s/^[^\.]+\.(.+)$/$1/gs) { push(@toks, "D*".$1); }
  669.   return @toks;
  670. }
  671.  
  672. ###########################################################################
  673.  
  674. sub ignore_message {
  675.   my ($self,$PMS) = @_;
  676.  
  677.   return 0 unless $self->{use_ignores};
  678.  
  679.   my $ignore = $PMS->check_from_in_list('bayes_ignore_from')
  680.             || $PMS->check_to_in_list('bayes_ignore_to');
  681.  
  682.   dbg("bayes: not using bayes, bayes_ignore_from or _to rule") if $ignore;
  683.  
  684.   return $ignore;
  685. }
  686.  
  687. ###########################################################################
  688.  
  689. sub learn {
  690.   my ($self, $isspam, $msg, $id) = @_;
  691.  
  692.   if (!$self->{conf}->{use_bayes}) { return; }
  693.   if (!defined $msg) { return; }
  694.  
  695.   if( $self->{use_ignores} )  # Remove test when PerMsgStatus available.
  696.   {
  697.     # DMK, koppel@ece.lsu.edu:  Hoping that the ultimate fix to bug 2263 will
  698.     # make it unnecessary to construct a PerMsgStatus here.
  699.     my $PMS = new Mail::SpamAssassin::PerMsgStatus $self->{main}, $msg;
  700.     my $ignore = $self->ignore_message($PMS);
  701.     $PMS->finish();
  702.     return if $ignore;
  703.   }
  704.  
  705.   my $msgdata = $self->get_body_from_msg ($msg);
  706.   my $ret;
  707.  
  708.   eval {
  709.     local $SIG{'__DIE__'};    # do not run user die() traps in here
  710.  
  711.     my $ok;
  712.     if ($self->{main}->{learn_to_journal}) {
  713.       # If we're going to learn to journal, we'll try going r/o first...
  714.       # If that fails for some reason, let's try going r/w.  This happens
  715.       # if the DB doesn't exist yet.
  716.       $ok = $self->{store}->tie_db_readonly() || $self->{store}->tie_db_writable();
  717.     } else {
  718.       $ok = $self->{store}->tie_db_writable();
  719.     }
  720.  
  721.     if ($ok) {
  722.       $ret = $self->learn_trapped ($isspam, $msg, $msgdata, $id);
  723.  
  724.       if (!$self->{main}->{learn_caller_will_untie}) {
  725.         $self->{store}->untie_db();
  726.       }
  727.     }
  728.   };
  729.  
  730.   if ($@) {        # if we died, untie the dbs.
  731.     my $failure = $@;
  732.     $self->{store}->untie_db();
  733.     die "bayes: $failure";
  734.   }
  735.  
  736.   return $ret;
  737. }
  738.  
  739. # this function is trapped by the wrapper above
  740. sub learn_trapped {
  741.   my ($self, $isspam, $msg, $msgdata, $msgid) = @_;
  742.   my @msgid = ( $msgid );
  743.  
  744.   if (!defined $msgid) {
  745.     @msgid = $self->get_msgid($msg);
  746.   }
  747.  
  748.   foreach $msgid ( @msgid ) {
  749.     my $seen = $self->{store}->seen_get ($msgid);
  750.  
  751.     if (defined ($seen)) {
  752.       if (($seen eq 's' && $isspam) || ($seen eq 'h' && !$isspam)) {
  753.         dbg("bayes: $msgid already learnt correctly, not learning twice");
  754.         return 0;
  755.       } elsif ($seen !~ /^[hs]$/) {
  756.         warn("bayes: db_seen corrupt: value='$seen' for $msgid, ignored");
  757.       } else {
  758.         # bug 3704: If the message was already learned, don't try learning it again.
  759.         # this prevents, for instance, manually learning as spam, then autolearning
  760.         # as ham, or visa versa.
  761.         if ($self->{main}->{learn_no_relearn}) {
  762.       dbg("bayes: $msgid already learnt as opposite, not re-learning");
  763.       return 0;
  764.     }
  765.  
  766.         dbg("bayes: $msgid already learnt as opposite, forgetting first");
  767.  
  768.         # kluge so that forget() won't untie the db on us ...
  769.         my $orig = $self->{main}->{learn_caller_will_untie};
  770.         $self->{main}->{learn_caller_will_untie} = 1;
  771.  
  772.         my $fatal = !defined $self->forget ($msg);
  773.  
  774.         # reset the value post-forget() ...
  775.         $self->{main}->{learn_caller_will_untie} = $orig;
  776.     
  777.         # forget() gave us a fatal error, so propagate that up
  778.         if ($fatal) {
  779.           dbg("bayes: forget() returned a fatal error, so learn() will too");
  780.       return;
  781.         }
  782.       }
  783.  
  784.       # we're only going to have seen this once, so stop if it's been
  785.       # seen already
  786.       last;
  787.     }
  788.   }
  789.  
  790.   # Now that we're sure we haven't seen this message before ...
  791.   $msgid = $msgid[0];
  792.  
  793.   if ($isspam) {
  794.     $self->{store}->nspam_nham_change (1, 0);
  795.   } else {
  796.     $self->{store}->nspam_nham_change (0, 1);
  797.   }
  798.  
  799.   my $msgatime = $msg->receive_date();
  800.  
  801.   # If the message atime comes back as being more than 1 day in the
  802.   # future, something's messed up and we should revert to current time as
  803.   # a safety measure.
  804.   #
  805.   $msgatime = time if ( $msgatime - time > 86400 );
  806.  
  807.   my $tokens = $self->tokenize($msg, $msgdata);
  808.  
  809.   if ($isspam) {
  810.     $self->{store}->multi_tok_count_change(1, 0, $tokens, $msgatime);
  811.   } else {
  812.     $self->{store}->multi_tok_count_change(0, 1, $tokens, $msgatime);
  813.   }
  814.  
  815.   $self->{store}->seen_put ($msgid, ($isspam ? 's' : 'h'));
  816.   $self->{store}->cleanup();
  817.  
  818.   $self->{main}->call_plugins("bayes_learn", { toksref => $tokens,
  819.                            isspam => $isspam,
  820.                            msgid => $msgid,
  821.                            msgatime => $msgatime,
  822.                          });
  823.  
  824.   dbg("bayes: learned '$msgid', atime: $msgatime");
  825.  
  826.   1;
  827. }
  828.  
  829. ###########################################################################
  830.  
  831. sub forget {
  832.   my ($self, $msg, $id) = @_;
  833.  
  834.   if (!$self->{conf}->{use_bayes}) { return; }
  835.   if (!defined $msg) { return; }
  836.  
  837.   my $msgdata = $self->get_body_from_msg ($msg);
  838.   my $ret;
  839.  
  840.   # we still tie for writing here, since we write to the seen db
  841.   # synchronously
  842.   eval {
  843.     local $SIG{'__DIE__'};    # do not run user die() traps in here
  844.  
  845.     my $ok;
  846.     if ($self->{main}->{learn_to_journal}) {
  847.       # If we're going to learn to journal, we'll try going r/o first...
  848.       # If that fails for some reason, let's try going r/w.  This happens
  849.       # if the DB doesn't exist yet.
  850.       $ok = $self->{store}->tie_db_readonly() || $self->{store}->tie_db_writable();
  851.     } else {
  852.       $ok = $self->{store}->tie_db_writable();
  853.     }
  854.  
  855.     if ($ok) {
  856.       $ret = $self->forget_trapped ($msg, $msgdata, $id);
  857.  
  858.       if (!$self->{main}->{learn_caller_will_untie}) {
  859.         $self->{store}->untie_db();
  860.       }
  861.     }
  862.   };
  863.  
  864.   if ($@) {        # if we died, untie the dbs.
  865.     my $failure = $@;
  866.     $self->{store}->untie_db();
  867.     die "bayes: $failure";
  868.   }
  869.  
  870.   return $ret;
  871. }
  872.  
  873. # this function is trapped by the wrapper above
  874. sub forget_trapped {
  875.   my ($self, $msg, $msgdata, $msgid) = @_;
  876.   my @msgid = ( $msgid );
  877.   my $isspam;
  878.  
  879.   if (!defined $msgid) {
  880.     @msgid = $self->get_msgid($msg);
  881.   }
  882.  
  883.   while( $msgid = shift @msgid ) {
  884.     my $seen = $self->{store}->seen_get ($msgid);
  885.  
  886.     if (defined ($seen)) {
  887.       if ($seen eq 's') {
  888.         $isspam = 1;
  889.       } elsif ($seen eq 'h') {
  890.         $isspam = 0;
  891.       } else {
  892.         dbg("bayes: forget: msgid $msgid seen entry is neither ham nor spam, ignored");
  893.         return 0;
  894.       }
  895.  
  896.       # messages should only be learned once, so stop if we find a msgid
  897.       # which was seen before
  898.       last;
  899.     }
  900.     else {
  901.       dbg("bayes: forget: msgid $msgid not learnt, ignored");
  902.     }
  903.   }
  904.  
  905.   # This message wasn't learnt before, so return
  906.   if (!defined $isspam) {
  907.     dbg("bayes: forget: no msgid from this message has been learnt, skipping message");
  908.     return 0;
  909.   }
  910.   elsif ($isspam) {
  911.     $self->{store}->nspam_nham_change (-1, 0);
  912.   }
  913.   else {
  914.     $self->{store}->nspam_nham_change (0, -1);
  915.   }
  916.  
  917.   my $tokens = $self->tokenize($msg, $msgdata);
  918.  
  919.   if ($isspam) {
  920.     $self->{store}->multi_tok_count_change (-1, 0, $tokens);
  921.   } else {
  922.     $self->{store}->multi_tok_count_change (0, -1, $tokens);
  923.   }
  924.  
  925.   $self->{store}->seen_delete ($msgid);
  926.   $self->{store}->cleanup();
  927.  
  928.   $self->{main}->call_plugins("bayes_forget", { toksref => $tokens,
  929.                         isspam => $isspam,
  930.                         msgid => $msgid,
  931.                           });
  932.  
  933.   1;
  934. }
  935.  
  936. ###########################################################################
  937.  
  938. sub get_msgid {
  939.   my ($self, $msg) = @_;
  940.  
  941.   my @msgid = ();
  942.  
  943.   my $msgid = $msg->get_header("Message-Id");
  944.   if (defined $msgid && $msgid ne '' && $msgid !~ /^\s*<\s*(?:\@sa_generated)?>.*$/) {
  945.     # remove \r and < and > prefix/suffixes
  946.     chomp $msgid;
  947.     $msgid =~ s/^<//; $msgid =~ s/>.*$//g;
  948.     push(@msgid, $msgid);
  949.   }
  950.  
  951.   # Use sha1_hex(Date:, last received: and top N bytes of body)
  952.   # where N is MIN(1024 bytes, 1/2 of body length)
  953.   #
  954.   my $date = $msg->get_header("Date");
  955.   $date = "None" if (!defined $date || $date eq ''); # No Date?
  956.  
  957.   my @rcvd = $msg->get_header("Received");
  958.   my $rcvd = $rcvd[$#rcvd];
  959.   $rcvd = "None" if (!defined $rcvd || $rcvd eq ''); # No Received?
  960.  
  961.   # Make a copy since pristine_body is a reference ...
  962.   my $body = join('', $msg->get_pristine_body());
  963.   if (length($body) > 64) { # Small Body?
  964.     my $keep = ( length $body > 2048 ? 1024 : int(length($body) / 2) );
  965.     substr($body, $keep) = '';
  966.   }
  967.  
  968.   unshift(@msgid, sha1_hex($date."\000".$rcvd."\000".$body).'@sa_generated');
  969.  
  970.   return wantarray ? @msgid : $msgid[0];
  971. }
  972.  
  973. sub get_body_from_msg {
  974.   my ($self, $msg) = @_;
  975.  
  976.   if (!ref $msg) {
  977.     # I have no idea why this seems to happen. TODO
  978.     warn "bayes: msg not a ref: '$msg'";
  979.     return { };
  980.   }
  981.  
  982.   $msg->extract_message_metadata ($self->{main});
  983.   my $permsgstatus =
  984.         Mail::SpamAssassin::PerMsgStatus->new($self->{main}, $msg);
  985.   my $msgdata = $self->get_msgdata_from_permsgstatus ($permsgstatus);
  986.   $permsgstatus->finish();
  987.  
  988.   if (!defined $msgdata) {
  989.     # why?!
  990.     warn "bayes: failed to get body for ".scalar($self->get_msgid($self->{msg}))."\n";
  991.     return { };
  992.   }
  993.  
  994.   return $msgdata;
  995. }
  996.  
  997. sub get_msgdata_from_permsgstatus {
  998.   my ($self, $msg) = @_;
  999.  
  1000.   my $msgdata = { };
  1001.   $msgdata->{bayes_token_body} = $msg->{msg}->get_visible_rendered_body_text_array();
  1002.   $msgdata->{bayes_token_inviz} = $msg->{msg}->get_invisible_rendered_body_text_array();
  1003.   @{$msgdata->{bayes_token_uris}} = $msg->get_uri_list();
  1004.   return $msgdata;
  1005. }
  1006.  
  1007. ###########################################################################
  1008.  
  1009. sub sync {
  1010.   my ($self, $sync, $expire, $opts) = @_;
  1011.   if (!$self->{conf}->{use_bayes}) { return 0; }
  1012.  
  1013.   if ($sync) {
  1014.     dbg("bayes: bayes journal sync starting");
  1015.     $self->{store}->sync($opts);
  1016.     dbg("bayes: bayes journal sync completed");
  1017.   }
  1018.   if ($expire) {
  1019.     dbg("bayes: expiry starting");
  1020.     $self->{store}->expire_old_tokens($opts);
  1021.     dbg("bayes: expiry completed");
  1022.   }
  1023.  
  1024.   return 0;
  1025. }
  1026.  
  1027. ###########################################################################
  1028.  
  1029. # compute the probability that that token is spammish
  1030. sub compute_prob_for_token {
  1031.   my ($self, $token, $ns, $nn, $s, $n) = @_;
  1032.  
  1033.   # we allow the caller to give us the token information, just
  1034.   # to save a potentially expensive lookup
  1035.   if (!defined($s) || !defined($n)) {
  1036.     ($s, $n, undef) = $self->{store}->tok_get ($token);
  1037.   }
  1038.  
  1039.   return if ($s == 0 && $n == 0);
  1040.  
  1041.   if (!USE_ROBINSON_FX_EQUATION_FOR_LOW_FREQS) {
  1042.     return if ($s + $n < 10);      # ignore low-freq tokens
  1043.   }
  1044.  
  1045.   if (!$self->{use_hapaxes}) {
  1046.     return if ($s + $n < 2);
  1047.   }
  1048.  
  1049.   return if ( $ns == 0 || $nn == 0 );
  1050.  
  1051.   my $ratios = ($s / $ns);
  1052.   my $ration = ($n / $nn);
  1053.  
  1054.   my $prob;
  1055.  
  1056.   if ($ratios == 0 && $ration == 0) {
  1057.     warn "bayes: oops? ratios == ration == 0";
  1058.     return;
  1059.   } else {
  1060.     $prob = ($ratios) / ($ration + $ratios);
  1061.   }
  1062.  
  1063.   if (USE_ROBINSON_FX_EQUATION_FOR_LOW_FREQS) {
  1064.     # use Robinson's f(x) equation for low-n tokens, instead of just
  1065.     # ignoring them
  1066.     my $robn = $s+$n;
  1067.     $prob = ($Mail::SpamAssassin::Bayes::Combine::FW_S_DOT_X + ($robn * $prob))
  1068.                              /
  1069.             ($Mail::SpamAssassin::Bayes::Combine::FW_S_CONSTANT + $robn);
  1070.   }
  1071.  
  1072.   if ($self->{log_raw_counts}) {
  1073.     $self->{raw_counts} .= " s=$s,n=$n ";
  1074.   }
  1075.  
  1076.   return $prob;
  1077. }
  1078.  
  1079. ###########################################################################
  1080. # If a token is neither hammy nor spammy, return 0.
  1081. # For a spammy token, return the minimum number of additional ham messages
  1082. # it would have had to appear in to no longer be spammy.  Hammy tokens
  1083. # are handled similarly.  That's what the function does (at the time
  1084. # of this writing, 31 July 2003, 16:02:55 CDT).  It would be slightly
  1085. # more useful if it returned the number of /additional/ ham messages
  1086. # a spammy token would have to appear in to no longer be spammy but I
  1087. # fear that might require the solution to a cubic equation, and I
  1088. # just don't have the time for that now.
  1089.  
  1090. sub compute_declassification_distance {
  1091.   my ($self, $Ns, $Nn, $ns, $nn, $prob) = @_;
  1092.  
  1093.   return 0 if $ns == 0 && $nn == 0;
  1094.  
  1095.   if (!USE_ROBINSON_FX_EQUATION_FOR_LOW_FREQS) {return 0 if ($ns + $nn < 10);}
  1096.   if (!$self->{use_hapaxes}) {return 0 if ($ns + $nn < 2);}
  1097.  
  1098.   return 0 if $Ns == 0 || $Nn == 0;
  1099.   return 0 if abs( $prob - 0.5 ) <
  1100.                 $Mail::SpamAssassin::Bayes::Combine::MIN_PROB_STRENGTH;
  1101.  
  1102.   my ($Na,$na,$Nb,$nb) = $prob > 0.5 ? ($Nn,$nn,$Ns,$ns) : ($Ns,$ns,$Nn,$nn);
  1103.   my $p = 0.5 - $Mail::SpamAssassin::Bayes::Combine::MIN_PROB_STRENGTH;
  1104.  
  1105.   return int( 1.0 - 1e-6 + $nb * $Na * $p / ($Nb * ( 1 - $p )) ) - $na
  1106.     unless USE_ROBINSON_FX_EQUATION_FOR_LOW_FREQS;
  1107.  
  1108.   my $s = $Mail::SpamAssassin::Bayes::Combine::FW_S_CONSTANT;
  1109.   my $sx = $Mail::SpamAssassin::Bayes::Combine::FW_S_DOT_X;
  1110.   my $a = $Nb * ( 1 - $p );
  1111.   my $b = $Nb * ( $sx + $nb * ( 1 - $p ) - $p * $s ) - $p * $Na * $nb;
  1112.   my $c = $Na * $nb * ( $sx - $p * ( $s + $nb ) );
  1113.   my $discrim = $b * $b - 4 * $a * $c;
  1114.   my $disc_max_0 = $discrim < 0 ? 0 : $discrim;
  1115.   my $dd_exact = ( 1.0 - 1e-6 + ( -$b + sqrt( $disc_max_0 ) ) / ( 2*$a ) ) - $na;
  1116.  
  1117.   # This shouldn't be necessary.  Should not be < 1
  1118.   return $dd_exact < 1 ? 1 : int($dd_exact);
  1119. }
  1120.  
  1121.  
  1122. # Check to make sure we can tie() the DB, and we have enough entries to do a scan
  1123. # if we're told the caller will untie(), go ahead and leave the db tied.
  1124. sub is_scan_available {
  1125.   my $self = shift;
  1126.  
  1127.   return 0 unless $self->{conf}->{use_bayes};
  1128.   return 0 unless $self->{store}->tie_db_readonly();
  1129.  
  1130.   # We need the DB to stay tied, so if the journal sync occurs, don't untie!
  1131.   my $caller_untie = $self->{main}->{learn_caller_will_untie};
  1132.   $self->{main}->{learn_caller_will_untie} = 1;
  1133.  
  1134.   # Do a journal sync if necessary.  Do this before the nspam_nham_get()
  1135.   # call since the sync may cause an update in the number of messages
  1136.   # learnt.
  1137.   $self->opportunistic_calls(1);
  1138.  
  1139.   # Reset the variable appropriately
  1140.   $self->{main}->{learn_caller_will_untie} = $caller_untie;
  1141.  
  1142.   my ($ns, $nn) = $self->{store}->nspam_nham_get();
  1143.  
  1144.   if ($ns < $self->{conf}->{bayes_min_spam_num}) {
  1145.     dbg("bayes: not available for scanning, only $ns spam(s) in bayes DB < ".$self->{conf}->{bayes_min_spam_num});
  1146.     if (!$self->{main}->{learn_caller_will_untie}) {
  1147.       $self->{store}->untie_db();
  1148.     }
  1149.     return 0;
  1150.   }
  1151.   if ($nn < $self->{conf}->{bayes_min_ham_num}) {
  1152.     dbg("bayes: not available for scanning, only $nn ham(s) in bayes DB < ".$self->{conf}->{bayes_min_ham_num});
  1153.     if (!$self->{main}->{learn_caller_will_untie}) {
  1154.       $self->{store}->untie_db();
  1155.     }
  1156.     return 0;
  1157.   }
  1158.  
  1159.   return 1;
  1160. }
  1161.  
  1162. ###########################################################################
  1163. # Finally, the scoring function for testing mail.
  1164.  
  1165. sub scan {
  1166.   my ($self, $permsgstatus, $msg) = @_;
  1167.   my $score;
  1168.  
  1169.   # When we're doing a scan, we'll guarantee that we'll do the untie,
  1170.   # so override the global setting until we're done.
  1171.   my $caller_untie = $self->{main}->{learn_caller_will_untie};
  1172.   $self->{main}->{learn_caller_will_untie} = 1;
  1173.  
  1174.   goto skip if ($self->ignore_message($permsgstatus));
  1175.  
  1176.   goto skip unless $self->is_scan_available();
  1177.  
  1178.   my ($ns, $nn) = $self->{store}->nspam_nham_get();
  1179.  
  1180.   if ($self->{log_raw_counts}) {
  1181.     $self->{raw_counts} = " ns=$ns nn=$nn ";
  1182.   }
  1183.  
  1184.   dbg("bayes: corpus size: nspam = $ns, nham = $nn");
  1185.  
  1186.   my $msgdata = $self->get_msgdata_from_permsgstatus ($permsgstatus);
  1187.  
  1188.   my $msgtokens = $self->tokenize($msg, $msgdata);
  1189.  
  1190.   my $tokensdata = $self->{store}->tok_get_all(keys %{$msgtokens});
  1191.  
  1192.   my %pw;
  1193.  
  1194.   foreach my $tokendata (@{$tokensdata}) {
  1195.     my ($token, $tok_spam, $tok_ham, $atime) = @{$tokendata};
  1196.     my $prob = $self->compute_prob_for_token($token, $ns, $nn, $tok_spam, $tok_ham);
  1197.     if (defined($prob)) {
  1198.       $pw{$token}->{prob} = $prob;
  1199.       $pw{$token}->{spam_count} = $tok_spam;
  1200.       $pw{$token}->{ham_count} = $tok_ham;
  1201.       $pw{$token}->{atime} = $atime;
  1202.     }
  1203.   }
  1204.  
  1205.   # If none of the tokens were found in the DB, we're going to skip
  1206.   # this message...
  1207.   if (!keys %pw) {
  1208.     dbg("bayes: cannot use bayes on this message; none of the tokens were found in the database");
  1209.     goto skip;
  1210.   }
  1211.  
  1212.   my $tcount_total = keys %{$msgtokens};
  1213.   my $tcount_learned = keys %pw;
  1214.  
  1215.   # Figure out the message receive time (used as atime below)
  1216.   # If the message atime comes back as being in the future, something's
  1217.   # messed up and we should revert to current time as a safety measure.
  1218.   #
  1219.   my $msgatime = $msg->receive_date();
  1220.   my $now = time;
  1221.   $msgatime = $now if ( $msgatime > $now );
  1222.  
  1223.   # now take the $count most significant tokens and calculate probs using
  1224.   # Robinson's formula.
  1225.   my $count = N_SIGNIFICANT_TOKENS;
  1226.   my @sorted = ();
  1227.  
  1228.   my ($tcount_spammy,$tcount_hammy) = (0,0);
  1229.   my $tinfo_spammy = $permsgstatus->{bayes_token_info_spammy} = [];
  1230.   my $tinfo_hammy = $permsgstatus->{bayes_token_info_hammy} = [];
  1231.  
  1232.   my @touch_tokens;
  1233.  
  1234.   for (sort {
  1235.               abs($pw{$b}->{prob} - 0.5) <=> abs($pw{$a}->{prob} - 0.5)
  1236.             } keys %pw)
  1237.   {
  1238.     if ($count-- < 0) { last; }
  1239.     my $pw = $pw{$_}->{prob};
  1240.     next if (abs($pw - 0.5) < 
  1241.                 $Mail::SpamAssassin::Bayes::Combine::MIN_PROB_STRENGTH);
  1242.  
  1243.     # What's more expensive, scanning headers for HAMMYTOKENS and
  1244.     # SPAMMYTOKENS tags that aren't there or collecting data that
  1245.     # won't be used?  Just collecting the data is certainly simpler.
  1246.     #
  1247.     my $raw_token = $msgtokens->{$_} || "(unknown)";
  1248.     my $s = $pw{$_}->{spam_count};
  1249.     my $n = $pw{$_}->{ham_count};
  1250.     my $a = $pw{$_}->{atime};
  1251.     push @$tinfo_spammy, [$raw_token,$pw,$s,$n,$a] if $pw >= 0.5 && ++$tcount_spammy;
  1252.     push @$tinfo_hammy,  [$raw_token,$pw,$s,$n,$a] if $pw <  0.5 && ++$tcount_hammy;
  1253.  
  1254.     push (@sorted, $pw);
  1255.  
  1256.     # update the atime on this token, it proved useful
  1257.     push(@touch_tokens, $_);
  1258.  
  1259.     if (would_log('dbg', 'bayes') > 1) {
  1260.       dbg("bayes: token '$raw_token' => $pw");
  1261.     }
  1262.   }
  1263.  
  1264.   if (!@sorted || (REQUIRE_SIGNIFICANT_TOKENS_TO_SCORE > 0 && 
  1265.     $#sorted <= REQUIRE_SIGNIFICANT_TOKENS_TO_SCORE))
  1266.   {
  1267.     dbg("bayes: cannot use bayes on this message; not enough usable tokens found");
  1268.     goto skip;
  1269.   }
  1270.  
  1271.   $score = Mail::SpamAssassin::Bayes::Combine::combine($ns, $nn, \@sorted);
  1272.  
  1273.   # Couldn't come up with a probability?
  1274.   goto skip unless defined $score;
  1275.  
  1276.   dbg("bayes: score = $score");
  1277.  
  1278.   # no need to call tok_touch_all unless there were significant
  1279.   # tokens and a score was returned
  1280.   # we don't really care about the return value here
  1281.   $self->{store}->tok_touch_all(\@touch_tokens, $msgatime);
  1282.  
  1283.   $permsgstatus->{bayes_nspam} = $ns;
  1284.   $permsgstatus->{bayes_nham} = $nn;
  1285.  
  1286.   if ($self->{log_raw_counts}) {
  1287.     print "#Bayes-Raw-Counts: $self->{raw_counts}\n";
  1288.   }
  1289.  
  1290.   $self->{main}->call_plugins("bayes_scan", { toksref => $msgtokens,
  1291.                           probsref => \%pw,
  1292.                           score => $score,
  1293.                           msgatime => $msgatime,
  1294.                           significant_tokens => \@touch_tokens,
  1295.                         });
  1296.  
  1297. skip:
  1298.   if (!defined $score) {
  1299.     dbg("bayes: not scoring message, returning undef");
  1300.   }
  1301.  
  1302.   # Take any opportunistic actions we can take
  1303.   if ($self->{main}->{opportunistic_expire_check_only}) {
  1304.     # we're supposed to report on expiry only -- so do the
  1305.     # opportunistic_calls() run for the journal only.
  1306.     $self->opportunistic_calls(1);
  1307.     $permsgstatus->{bayes_expiry_due} = $self->{store}->expiry_due();
  1308.   }
  1309.   else {
  1310.     $self->opportunistic_calls();
  1311.   }
  1312.  
  1313.   # Do any cleanup we need to do
  1314.   $self->{store}->cleanup();
  1315.  
  1316.   # Reset the value accordingly
  1317.   $self->{main}->{learn_caller_will_untie} = $caller_untie;
  1318.  
  1319.   # If our caller won't untie the db, we need to do it.
  1320.   if (!$caller_untie) {
  1321.     $self->{store}->untie_db();
  1322.   }
  1323.  
  1324.   $permsgstatus->{tag_data}{BAYESTCHAMMY} = $tcount_hammy;
  1325.   $permsgstatus->{tag_data}{BAYESTCSPAMMY} = $tcount_spammy;
  1326.   $permsgstatus->{tag_data}{BAYESTCLEARNED} = $tcount_learned;
  1327.   $permsgstatus->{tag_data}{BAYESTC} = $tcount_total;
  1328.  
  1329.   return $score;
  1330. }
  1331.  
  1332. sub opportunistic_calls {
  1333.   my($self, $journal_only) = @_;
  1334.  
  1335.   # If we're not already tied, abort.
  1336.   if (!$self->{store}->db_readable()) {
  1337.     dbg("bayes: opportunistic call attempt failed, DB not readable");
  1338.     return;
  1339.   }
  1340.  
  1341.   # Is an expire or sync running?
  1342.   my $running_expire = $self->{store}->get_running_expire_tok();
  1343.   if ( defined $running_expire && $running_expire+$OPPORTUNISTIC_LOCK_VALID > time() ) {
  1344.     dbg("bayes: opportunistic call attempt skipped, found fresh running expire magic token");
  1345.     return;
  1346.   }
  1347.  
  1348.   # handle expiry and syncing
  1349.   if (!$journal_only && $self->{store}->expiry_due()) {
  1350.     dbg("bayes: opportunistic call found expiry due");
  1351.  
  1352.     # sync will bring the DB R/W as necessary, and the expire will remove
  1353.     # the running_expire token, may untie as well.
  1354.     $self->sync(1,1);
  1355.   }
  1356.   elsif ( $self->{store}->sync_due() ) {
  1357.     dbg("bayes: opportunistic call found journal sync due");
  1358.  
  1359.     # sync will bring the DB R/W as necessary, may untie as well
  1360.     $self->sync(1,0);
  1361.  
  1362.     # We can only remove the running_expire token if we're doing R/W
  1363.     if ($self->{store}->db_writable()) {
  1364.       $self->{store}->remove_running_expire_tok();
  1365.     }
  1366.   }
  1367.  
  1368.   return;
  1369. }
  1370.  
  1371. ###########################################################################
  1372.  
  1373. sub dump_bayes_db {
  1374.   my($self, $magic, $toks, $regex) = @_;
  1375.  
  1376.   # allow dump to occur even if use_bayes disables everything else ...
  1377.   #return 0 unless $self->{conf}->{use_bayes};
  1378.   return 0 unless $self->{store}->tie_db_readonly();
  1379.   
  1380.   my @vars = $self->{store}->get_storage_variables();
  1381.  
  1382.   my($sb,$ns,$nh,$nt,$le,$oa,$bv,$js,$ad,$er,$na) = @vars;
  1383.  
  1384.   my $template = '%3.3f %10u %10u %10u  %s'."\n";
  1385.  
  1386.   if ( $magic ) {
  1387.     printf ($template, 0.0, 0, $bv, 0, 'non-token data: bayes db version');
  1388.     printf ($template, 0.0, 0, $ns, 0, 'non-token data: nspam');
  1389.     printf ($template, 0.0, 0, $nh, 0, 'non-token data: nham');
  1390.     printf ($template, 0.0, 0, $nt, 0, 'non-token data: ntokens');
  1391.     printf ($template, 0.0, 0, $oa, 0, 'non-token data: oldest atime');
  1392.     printf ($template, 0.0, 0, $na, 0, 'non-token data: newest atime') if ( $bv >= 2 );
  1393.     printf ($template, 0.0, 0, $sb, 0, 'non-token data: current scan-count') if ( $bv < 2 );
  1394.     printf ($template, 0.0, 0, $js, 0, 'non-token data: last journal sync atime') if ( $bv >= 2 );
  1395.     printf ($template, 0.0, 0, $le, 0, 'non-token data: last expiry atime');
  1396.     if ( $bv >= 2 ) {
  1397.       printf ($template, 0.0, 0, $ad, 0, 'non-token data: last expire atime delta');
  1398.       printf ($template, 0.0, 0, $er, 0, 'non-token data: last expire reduction count');
  1399.     }
  1400.   }
  1401.  
  1402.   if ( $toks ) {
  1403.     # let the store sort out the db_toks
  1404.     $self->{store}->dump_db_toks($template, $regex, @vars);
  1405.   }
  1406.  
  1407.   if (!$self->{main}->{learn_caller_will_untie}) {
  1408.     $self->{store}->untie_db();
  1409.   }
  1410.   return 1;
  1411. }
  1412.  
  1413. 1;
  1414.  
  1415. =back
  1416.  
  1417. =cut
  1418.