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 / BayesStore / DBM.pm next >
Text File  |  2006-11-29  |  59KB  |  1,921 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. package Mail::SpamAssassin::BayesStore::DBM;
  19.  
  20. use strict;
  21. use warnings;
  22. use bytes;
  23. use Fcntl;
  24.  
  25. use Mail::SpamAssassin;
  26. use Mail::SpamAssassin::Util;
  27. use Mail::SpamAssassin::BayesStore;
  28. use Mail::SpamAssassin::Logger;
  29. use Digest::SHA1 qw(sha1);
  30. use File::Basename;
  31. use File::Spec;
  32. use File::Path;
  33.  
  34. use constant MAGIC_RE    => qr/^\015\001\007\011\003/;
  35.  
  36. use vars qw{
  37.   @ISA
  38.   @DBNAMES
  39.   $NSPAM_MAGIC_TOKEN $NHAM_MAGIC_TOKEN $LAST_EXPIRE_MAGIC_TOKEN $LAST_JOURNAL_SYNC_MAGIC_TOKEN
  40.   $NTOKENS_MAGIC_TOKEN $OLDEST_TOKEN_AGE_MAGIC_TOKEN $LAST_EXPIRE_REDUCE_MAGIC_TOKEN
  41.   $RUNNING_EXPIRE_MAGIC_TOKEN $DB_VERSION_MAGIC_TOKEN $LAST_ATIME_DELTA_MAGIC_TOKEN
  42.   $NEWEST_TOKEN_AGE_MAGIC_TOKEN
  43. };
  44.  
  45. @ISA = qw( Mail::SpamAssassin::BayesStore );
  46.  
  47. # db layout (quoting Matt):
  48. #
  49. # > need five db files though to make it real fast:
  50. # [probs] 1. ngood and nbad (two entries, so could be a flat file rather 
  51. # than a db file).    (now 2 entries in db_toks)
  52. # [toks]  2. good token -> number seen
  53. # [toks]  3. bad token -> number seen (both are packed into 1 entry in 1 db)
  54. # [probs]  4. Consolidated good token -> probability
  55. # [probs]  5. Consolidated bad token -> probability
  56. # > As you add new mails, you update the entry in 2 or 3, then regenerate
  57. # > the entry for that token in 4 or 5.
  58. # > Then as you test a new mail, you just need to pull the probability
  59. # > direct from 4 and 5, and generate the overall probability. A simple and
  60. # > very fast operation. 
  61. #
  62. # jm: we use probs as overall probability. <0.5 = ham, >0.5 = spam
  63. #
  64. # update: probs is no longer maintained as a db, to keep on-disk and in-core
  65. # usage down.
  66. #
  67. # also, added a new one to support forgetting, auto-learning, and
  68. # auto-forgetting for refiled mails:
  69. # [seen]  6. a list of Message-IDs of messages already learnt from. values
  70. # are 's' for learnt-as-spam, 'h' for learnt-as-ham.
  71. #
  72. # and another, called [scancount] to model the scan-count for expiry.
  73. # This is not a database.  Instead it increases by one byte for each
  74. # message scanned (note: scanned, not learned).
  75.  
  76. @DBNAMES = qw(toks seen);
  77.  
  78. # These are the magic tokens we use to track stuff in the DB.
  79. # The format is '^M^A^G^I^C' followed by any string you want.
  80. # None of the control chars will be in a real token.
  81. $DB_VERSION_MAGIC_TOKEN        = "\015\001\007\011\003DBVERSION";
  82. $LAST_ATIME_DELTA_MAGIC_TOKEN    = "\015\001\007\011\003LASTATIMEDELTA";
  83. $LAST_EXPIRE_MAGIC_TOKEN    = "\015\001\007\011\003LASTEXPIRE";
  84. $LAST_EXPIRE_REDUCE_MAGIC_TOKEN    = "\015\001\007\011\003LASTEXPIREREDUCE";
  85. $LAST_JOURNAL_SYNC_MAGIC_TOKEN    = "\015\001\007\011\003LASTJOURNALSYNC";
  86. $NEWEST_TOKEN_AGE_MAGIC_TOKEN    = "\015\001\007\011\003NEWESTAGE";
  87. $NHAM_MAGIC_TOKEN        = "\015\001\007\011\003NHAM";
  88. $NSPAM_MAGIC_TOKEN        = "\015\001\007\011\003NSPAM";
  89. $NTOKENS_MAGIC_TOKEN        = "\015\001\007\011\003NTOKENS";
  90. $OLDEST_TOKEN_AGE_MAGIC_TOKEN    = "\015\001\007\011\003OLDESTAGE";
  91. $RUNNING_EXPIRE_MAGIC_TOKEN    = "\015\001\007\011\003RUNNINGEXPIRE";
  92.  
  93. sub HAS_DBM_MODULE {
  94.   my ($self) = @_;
  95.   if (exists($self->{has_dbm_module})) {
  96.     return $self->{has_dbm_module};
  97.   }
  98.   $self->{has_dbm_module} = eval { require DB_File; };
  99. }
  100.  
  101. sub DBM_MODULE {
  102.   return "DB_File";
  103. }
  104.  
  105. # Possible file extensions used by the kinds of database files DB_File
  106. # might create.  We need these so we can create a new file and rename
  107. # it into place.
  108. sub DB_EXTENSIONS {
  109.   return ('', '.db');
  110. }
  111.  
  112. ###########################################################################
  113.  
  114. sub new {
  115.   my $class = shift;
  116.   $class = ref($class) || $class;
  117.  
  118.   my $self = $class->SUPER::new(@_);
  119.  
  120.   $self->{supported_db_version} = 3;
  121.  
  122.   $self->{already_tied} = 0;
  123.   $self->{is_locked} = 0;
  124.   $self->{string_to_journal} = '';
  125.  
  126.   $self;
  127. }
  128.  
  129. ###########################################################################
  130.  
  131. sub tie_db_readonly {
  132.   my ($self) = @_;
  133.  
  134.   if (!$self->HAS_DBM_MODULE) {
  135.     dbg("bayes: " . $self->DBM_MODULE . " module not installed, cannot use bayes");
  136.     return 0;
  137.   }
  138.  
  139.   # return if we've already tied to the db's, using the same mode
  140.   # (locked/unlocked) as before.
  141.   return 1 if ($self->{already_tied} && $self->{is_locked} == 0);
  142.  
  143.   my $main = $self->{bayes}->{main};
  144.   if (!defined($main->{conf}->{bayes_path})) {
  145.     dbg("bayes: bayes_path not defined");
  146.     return 0;
  147.   }
  148.  
  149.   $self->read_db_configs();
  150.  
  151.   my $path = $main->sed_path($main->{conf}->{bayes_path});
  152.  
  153.   my $found = 0;
  154.   for my $ext ($self->DB_EXTENSIONS) {
  155.     if (-f $path.'_toks'.$ext) {
  156.       $found = 1;
  157.       last;
  158.     }
  159.   }
  160.  
  161.   if (!$found) {
  162.     dbg("bayes: no dbs present, cannot tie DB R/O: ${path}_toks");
  163.     return 0;
  164.   }
  165.  
  166.   foreach my $dbname (@DBNAMES) {
  167.     my $name = $path.'_'.$dbname;
  168.     my $db_var = 'db_'.$dbname;
  169.     dbg("bayes: tie-ing to DB file R/O $name");
  170.  
  171.     # untie %{$self->{$db_var}} if (tied %{$self->{$db_var}});
  172.     if (!tie %{$self->{$db_var}},$self->DBM_MODULE, $name, O_RDONLY,
  173.          (oct($main->{conf}->{bayes_file_mode}) & 0666))
  174.     {
  175.       # bug 2975: it's acceptable for the db_seen to not be present,
  176.       # to allow it to be recycled.  if that's the case, just create
  177.       # a new, empty one. we don't need to lock it, since we won't
  178.       # be writing to it; let the R/W api deal with that case.
  179.  
  180.       if ($dbname eq 'seen') {
  181.         tie %{$self->{$db_var}},$self->DBM_MODULE, $name, O_RDWR|O_CREAT,
  182.                     (oct($main->{conf}->{bayes_file_mode}) & 0666)
  183.           or goto failed_to_tie;
  184.       }
  185.       else {
  186.         goto failed_to_tie;
  187.       }
  188.     }
  189.   }
  190.  
  191.   $self->{db_version} = ($self->get_storage_variables())[6];
  192.   dbg("bayes: found bayes db version ".$self->{db_version});
  193.  
  194.   # If the DB version is one we don't understand, abort!
  195.   if ($self->_check_db_version() != 0) {
  196.     warn("bayes: bayes db version ".$self->{db_version}." is not able to be used, aborting!");
  197.     $self->untie_db();
  198.     return 0;
  199.   }
  200.  
  201.   $self->{already_tied} = 1;
  202.   return 1;
  203.  
  204. failed_to_tie:
  205.   warn "bayes: cannot open bayes databases ${path}_* R/O: tie failed: $!\n";
  206.   foreach my $dbname (@DBNAMES) {
  207.     my $db_var = 'db_'.$dbname;
  208.     next unless exists $self->{$db_var};
  209.     dbg("bayes: untie-ing DB file $dbname");
  210.     untie %{$self->{$db_var}};
  211.   }
  212.  
  213.   return 0;
  214. }
  215.  
  216. # tie() to the databases, read-write and locked.  Any callers of
  217. # this should ensure they call untie_db() afterwards!
  218. #
  219. sub tie_db_writable {
  220.   my ($self) = @_;
  221.  
  222.   if (!$self->HAS_DBM_MODULE) {
  223.     dbg("bayes: " . $self->DBM_MODULE . " module not installed, cannot use bayes");
  224.     return 0;
  225.   }
  226.  
  227.   # Useful shortcut ...
  228.   my $main = $self->{bayes}->{main};
  229.  
  230.   # if we've already tied the db's using the same mode
  231.   # (locked/unlocked) as we want now, freshen the lock and return.
  232.   if ($self->{already_tied} && $self->{is_locked} == 1) {
  233.     $main->{locker}->refresh_lock($self->{locked_file});
  234.     return 1;
  235.   }
  236.  
  237.   if (!defined($main->{conf}->{bayes_path})) {
  238.     dbg("bayes: bayes_path not defined");
  239.     return 0;
  240.   }
  241.  
  242.   $self->read_db_configs();
  243.  
  244.   my $path = $main->sed_path($main->{conf}->{bayes_path});
  245.  
  246.   my $found = 0;
  247.   for my $ext ($self->DB_EXTENSIONS) {
  248.     if (-f $path.'_toks'.$ext) {
  249.       $found = 1;
  250.       last;
  251.     }
  252.   }
  253.  
  254.   my $parentdir = dirname($path);
  255.   if (!-d $parentdir) {
  256.     # run in an eval(); if mkpath has no perms, it calls die()
  257.     eval {
  258.       mkpath($parentdir, 0, (oct($main->{conf}->{bayes_file_mode}) & 0777));
  259.     };
  260.   }
  261.  
  262.   my $tout;
  263.   if ($main->{learn_wait_for_lock}) {
  264.     $tout = 300;       # TODO: Dan to write better lock code
  265.   } else {
  266.     $tout = 10;
  267.   }
  268.   if ($main->{locker}->safe_lock($path, $tout, $main->{conf}->{bayes_file_mode}))
  269.   {
  270.     $self->{locked_file} = $path;
  271.     $self->{is_locked} = 1;
  272.   } else {
  273.     warn "bayes: cannot open bayes databases ${path}_* R/W: lock failed: $!\n";
  274.     return 0;
  275.   }
  276.  
  277.   my $umask = umask 0;
  278.   foreach my $dbname (@DBNAMES) {
  279.     my $name = $path.'_'.$dbname;
  280.     my $db_var = 'db_'.$dbname;
  281.     dbg("bayes: tie-ing to DB file R/W $name");
  282.     tie %{$self->{$db_var}},$self->DBM_MODULE,$name, O_RDWR|O_CREAT,
  283.          (oct($main->{conf}->{bayes_file_mode}) & 0666)
  284.        or goto failed_to_tie;
  285.   }
  286.   umask $umask;
  287.  
  288.   # set our cache to what version DB we're using
  289.   $self->{db_version} = ($self->get_storage_variables())[6];
  290.   # don't bother printing this if the db was not found since it is bogus anyway
  291.   dbg("bayes: found bayes db version ".$self->{db_version}) if ($found);
  292.  
  293.   # figure out if we can read the current DB and if we need to do a
  294.   # DB version update and do it if necessary if either has a problem,
  295.   # fail immediately
  296.   #
  297.   if ($found && !$self->_upgrade_db()) {
  298.     $self->untie_db();
  299.     return 0;
  300.   }
  301.   elsif (!$found) { # new DB, make sure we know that ...
  302.     $self->{db_version} = $self->{db_toks}->{$DB_VERSION_MAGIC_TOKEN} = $self->DB_VERSION;
  303.     $self->{db_toks}->{$NTOKENS_MAGIC_TOKEN} = 0; # no tokens in the db ...
  304.     dbg("bayes: new db, set db version ".$self->{db_version}." and 0 tokens");
  305.   }
  306.  
  307.   $self->{already_tied} = 1;
  308.   return 1;
  309.  
  310. failed_to_tie:
  311.   my $err = $!;
  312.   umask $umask;
  313.  
  314.   foreach my $dbname (@DBNAMES) {
  315.     my $db_var = 'db_'.$dbname;
  316.     next unless exists $self->{$db_var};
  317.     dbg("bayes: untie-ing DB file $dbname");
  318.     untie %{$self->{$db_var}};
  319.   }       
  320.  
  321.   if ($self->{is_locked}) {
  322.     $self->{bayes}->{main}->{locker}->safe_unlock($self->{locked_file});
  323.     $self->{is_locked} = 0;
  324.   }
  325.   warn "bayes: cannot open bayes databases ${path}_* R/W: tie failed: $err\n";
  326.   return 0;
  327. }
  328.  
  329. # Do we understand how to deal with this DB version?
  330. sub _check_db_version {
  331.   my ($self) = @_;
  332.  
  333.   # return -1 if older, 0 if current, 1 if newer
  334.   return $self->{db_version} <=> $self->DB_VERSION;
  335. }
  336.  
  337. # Check to see if we need to upgrade the DB, and do so if necessary
  338. sub _upgrade_db {
  339.   my ($self) = @_;
  340.  
  341.   my $verschk = $self->_check_db_version();
  342.   my $res = 0; # used later on for tie() checks
  343.   my $umask; # used later for umask modifications
  344.  
  345.   # If the DB is the latest version, no problem.
  346.   return 1 if ($verschk == 0);
  347.  
  348.   # If the DB is a newer version that we know what to do with ... abort!
  349.   if ($verschk == 1) {
  350.     warn("bayes: bayes db version ".$self->{db_version}." is newer than we understand, aborting!");
  351.     return 0;
  352.   }
  353.  
  354.   # If the current DB version is lower than the new version, upgrade!
  355.   # Do conversions in order so we can go 1 -> 3, make sure to update
  356.   #   $self->{db_version} along the way
  357.  
  358.   dbg("bayes: detected bayes db format ".$self->{db_version}.", upgrading");
  359.  
  360.   # since DB_File will not shrink a database (!!), we need to *create*
  361.   # a new one instead.
  362.   my $main = $self->{bayes}->{main};
  363.   my $path = $main->sed_path($main->{conf}->{bayes_path});
  364.   my $name = $path.'_toks';
  365.  
  366.   # older version's journal files are likely not in the same format as the new ones, so remove it.
  367.   my $jpath = $self->_get_journal_filename();
  368.   if (-f $jpath) {
  369.     dbg("bayes: old journal file found, removing");
  370.     warn "bayes: couldn't remove $jpath: $!" if (!unlink $jpath);
  371.   }
  372.  
  373.   if ($self->{db_version} < 2) {
  374.     dbg("bayes: upgrading database format from v".$self->{db_version}." to v2");
  375.     $self->set_running_expire_tok();
  376.  
  377.     my ($DB_NSPAM_MAGIC_TOKEN, $DB_NHAM_MAGIC_TOKEN, $DB_NTOKENS_MAGIC_TOKEN);
  378.     my ($DB_OLDEST_TOKEN_AGE_MAGIC_TOKEN, $DB_LAST_EXPIRE_MAGIC_TOKEN);
  379.  
  380.     # Magic tokens for version 0, defined as '**[A-Z]+'
  381.     if ($self->{db_version} == 0) {
  382.       $DB_NSPAM_MAGIC_TOKEN            = '**NSPAM';
  383.       $DB_NHAM_MAGIC_TOKEN            = '**NHAM';
  384.       $DB_NTOKENS_MAGIC_TOKEN            = '**NTOKENS';
  385.       #$DB_OLDEST_TOKEN_AGE_MAGIC_TOKEN        = '**OLDESTAGE';
  386.       #$DB_LAST_EXPIRE_MAGIC_TOKEN        = '**LASTEXPIRE';
  387.       #$DB_SCANCOUNT_BASE_MAGIC_TOKEN        = '**SCANBASE';
  388.       #$DB_RUNNING_EXPIRE_MAGIC_TOKEN        = '**RUNNINGEXPIRE';
  389.     }
  390.     else {
  391.       $DB_NSPAM_MAGIC_TOKEN            = "\015\001\007\011\003NSPAM";
  392.       $DB_NHAM_MAGIC_TOKEN            = "\015\001\007\011\003NHAM";
  393.       $DB_NTOKENS_MAGIC_TOKEN            = "\015\001\007\011\003NTOKENS";
  394.       #$DB_OLDEST_TOKEN_AGE_MAGIC_TOKEN        = "\015\001\007\011\003OLDESTAGE";
  395.       #$DB_LAST_EXPIRE_MAGIC_TOKEN        = "\015\001\007\011\003LASTEXPIRE";
  396.       #$DB_SCANCOUNT_BASE_MAGIC_TOKEN        = "\015\001\007\011\003SCANBASE";
  397.       #$DB_RUNNING_EXPIRE_MAGIC_TOKEN        = "\015\001\007\011\003RUNNINGEXPIRE";
  398.     }
  399.  
  400.     # remember when we started ...
  401.     my $started = time;
  402.     my $newatime = $started;
  403.  
  404.     # use O_EXCL to avoid races (bonus paranoia, since we should be locked
  405.     # anyway)
  406.     my %new_toks;
  407.     $umask = umask 0;
  408.     $res = tie %new_toks, $self->DBM_MODULE, "${name}.new", O_RDWR|O_CREAT|O_EXCL,
  409.           (oct($main->{conf}->{bayes_file_mode}) & 0666);
  410.     umask $umask;
  411.     return 0 unless $res;
  412.     undef $res;
  413.  
  414.     # add the magic tokens to the new db.
  415.     $new_toks{$NSPAM_MAGIC_TOKEN} = $self->{db_toks}->{$DB_NSPAM_MAGIC_TOKEN};
  416.     $new_toks{$NHAM_MAGIC_TOKEN} = $self->{db_toks}->{$DB_NHAM_MAGIC_TOKEN};
  417.     $new_toks{$NTOKENS_MAGIC_TOKEN} = $self->{db_toks}->{$DB_NTOKENS_MAGIC_TOKEN};
  418.     $new_toks{$DB_VERSION_MAGIC_TOKEN} = 2; # we're now a DB version 2 file
  419.     $new_toks{$OLDEST_TOKEN_AGE_MAGIC_TOKEN} = $newatime;
  420.     $new_toks{$LAST_EXPIRE_MAGIC_TOKEN} = $newatime;
  421.     $new_toks{$NEWEST_TOKEN_AGE_MAGIC_TOKEN} = $newatime;
  422.     $new_toks{$LAST_JOURNAL_SYNC_MAGIC_TOKEN} = $newatime;
  423.     $new_toks{$LAST_ATIME_DELTA_MAGIC_TOKEN} = 0;
  424.     $new_toks{$LAST_EXPIRE_REDUCE_MAGIC_TOKEN} = 0;
  425.  
  426.     # deal with the data tokens
  427.     my ($tok, $packed);
  428.     my $count = 0;
  429.     while (($tok, $packed) = each %{$self->{db_toks}}) {
  430.       next if ($tok =~ /^(?:\*\*[A-Z]+$|\015\001\007\011\003)/); # skip magic tokens
  431.  
  432.       my ($ts, $th, $atime) = $self->tok_unpack($packed);
  433.       $new_toks{$tok} = $self->tok_pack($ts, $th, $newatime);
  434.  
  435.       # Refresh the lock every so often...
  436.       if (($count++ % 1000) == 0) {
  437.         $self->set_running_expire_tok();
  438.       }
  439.     }
  440.  
  441.  
  442.     # now untie so we can do renames
  443.     untie %{$self->{db_toks}};
  444.     untie %new_toks;
  445.  
  446.     # This is the critical phase (moving files around), so don't allow
  447.     # it to be interrupted.
  448.     local $SIG{'INT'} = 'IGNORE';
  449.     local $SIG{'TERM'} = 'IGNORE';
  450.     local $SIG{'HUP'} = 'IGNORE' if (!Mail::SpamAssassin::Util::am_running_on_windows());
  451.  
  452.     # older versions used scancount, so kill the stupid little file ...
  453.     my $msgc = $path.'_msgcount';
  454.     if (-f $msgc) {
  455.       dbg("bayes: old msgcount file found, removing");
  456.       if (!unlink $msgc) {
  457.         warn "bayes: couldn't remove $msgc: $!";
  458.       }
  459.     }
  460.  
  461.     # now rename in the new one.  Try several extensions
  462.     for my $ext ($self->DB_EXTENSIONS) {
  463.       my $newf = $name.'.new'.$ext;
  464.       my $oldf = $name.$ext;
  465.       next unless (-f $newf);
  466.       if (!rename ($newf, $oldf)) {
  467.         warn "bayes: rename $newf to $oldf failed: $!\n";
  468.         return 0;
  469.       }
  470.     }
  471.  
  472.     # re-tie to the new db in read-write mode ...
  473.     $umask = umask 0;
  474.     $res = tie %{$self->{db_toks}},$self->DBM_MODULE, $name, O_RDWR|O_CREAT,
  475.      (oct($main->{conf}->{bayes_file_mode}) & 0666);
  476.     umask $umask;
  477.     return 0 unless $res;
  478.     undef $res;
  479.  
  480.     dbg("bayes: upgraded database format from v".$self->{db_version}." to v2 in ".(time - $started)." seconds");
  481.     $self->{db_version} = 2; # need this for other functions which check
  482.   }
  483.  
  484.   # Version 3 of the database converts all existing tokens to SHA1 hashes
  485.   if ($self->{db_version} == 2) {
  486.     dbg("bayes: upgrading database format from v".$self->{db_version}." to v3");
  487.     $self->set_running_expire_tok();
  488.  
  489.     my $DB_NSPAM_MAGIC_TOKEN          = "\015\001\007\011\003NSPAM";
  490.     my $DB_NHAM_MAGIC_TOKEN          = "\015\001\007\011\003NHAM";
  491.     my $DB_NTOKENS_MAGIC_TOKEN          = "\015\001\007\011\003NTOKENS";
  492.     my $DB_OLDEST_TOKEN_AGE_MAGIC_TOKEN      = "\015\001\007\011\003OLDESTAGE";
  493.     my $DB_LAST_EXPIRE_MAGIC_TOKEN      = "\015\001\007\011\003LASTEXPIRE";
  494.     my $DB_NEWEST_TOKEN_AGE_MAGIC_TOKEN      = "\015\001\007\011\003NEWESTAGE";
  495.     my $DB_LAST_JOURNAL_SYNC_MAGIC_TOKEN  = "\015\001\007\011\003LASTJOURNALSYNC";
  496.     my $DB_LAST_ATIME_DELTA_MAGIC_TOKEN      = "\015\001\007\011\003LASTATIMEDELTA";
  497.     my $DB_LAST_EXPIRE_REDUCE_MAGIC_TOKEN = "\015\001\007\011\003LASTEXPIREREDUCE";
  498.  
  499.     # remember when we started ...
  500.     my $started = time;
  501.  
  502.     # use O_EXCL to avoid races (bonus paranoia, since we should be locked
  503.     # anyway)
  504.     my %new_toks;
  505.     $umask = umask 0;
  506.     $res = tie %new_toks, $self->DBM_MODULE, "${name}.new", O_RDWR|O_CREAT|O_EXCL,
  507.           (oct($main->{conf}->{bayes_file_mode}) & 0666);
  508.     umask $umask;
  509.     return 0 unless $res;
  510.     undef $res;
  511.  
  512.     # add the magic tokens to the new db.
  513.     $new_toks{$NSPAM_MAGIC_TOKEN} = $self->{db_toks}->{$DB_NSPAM_MAGIC_TOKEN};
  514.     $new_toks{$NHAM_MAGIC_TOKEN} = $self->{db_toks}->{$DB_NHAM_MAGIC_TOKEN};
  515.     $new_toks{$NTOKENS_MAGIC_TOKEN} = $self->{db_toks}->{$DB_NTOKENS_MAGIC_TOKEN};
  516.     $new_toks{$DB_VERSION_MAGIC_TOKEN} = 3; # we're now a DB version 3 file
  517.     $new_toks{$OLDEST_TOKEN_AGE_MAGIC_TOKEN} = $self->{db_toks}->{$DB_OLDEST_TOKEN_AGE_MAGIC_TOKEN};
  518.     $new_toks{$LAST_EXPIRE_MAGIC_TOKEN} = $self->{db_toks}->{$DB_LAST_EXPIRE_MAGIC_TOKEN};
  519.     $new_toks{$NEWEST_TOKEN_AGE_MAGIC_TOKEN} = $self->{db_toks}->{$DB_NEWEST_TOKEN_AGE_MAGIC_TOKEN};
  520.     $new_toks{$LAST_JOURNAL_SYNC_MAGIC_TOKEN} = $self->{db_toks}->{$DB_LAST_JOURNAL_SYNC_MAGIC_TOKEN};
  521.     $new_toks{$LAST_ATIME_DELTA_MAGIC_TOKEN} = $self->{db_toks}->{$DB_LAST_ATIME_DELTA_MAGIC_TOKEN};
  522.     $new_toks{$LAST_EXPIRE_REDUCE_MAGIC_TOKEN} =$self->{db_toks}->{$DB_LAST_EXPIRE_REDUCE_MAGIC_TOKEN};
  523.  
  524.     # deal with the data tokens
  525.     my $count = 0;
  526.     while (my ($tok, $packed) = each %{$self->{db_toks}}) {
  527.       next if ($tok =~ /^\015\001\007\011\003/); # skip magic tokens
  528.       my $tok_hash = substr(sha1($tok), -5);
  529.       $new_toks{$tok_hash} = $packed;
  530.  
  531.       # Refresh the lock every so often...
  532.       if (($count++ % 1000) == 0) {
  533.         $self->set_running_expire_tok();
  534.       }
  535.     }
  536.  
  537.     # now untie so we can do renames
  538.     untie %{$self->{db_toks}};
  539.     untie %new_toks;
  540.  
  541.     # This is the critical phase (moving files around), so don't allow
  542.     # it to be interrupted.
  543.     local $SIG{'INT'} = 'IGNORE';
  544.     local $SIG{'TERM'} = 'IGNORE';
  545.     local $SIG{'HUP'} = 'IGNORE' if (!Mail::SpamAssassin::Util::am_running_on_windows());
  546.  
  547.     # now rename in the new one.  Try several extensions
  548.     for my $ext ($self->DB_EXTENSIONS) {
  549.       my $newf = $name.'.new'.$ext;
  550.       my $oldf = $name.$ext;
  551.       next unless (-f $newf);
  552.       if (!rename($newf, $oldf)) {
  553.         warn "bayes: rename $newf to $oldf failed: $!\n";
  554.         return 0;
  555.       }
  556.     }
  557.  
  558.     # re-tie to the new db in read-write mode ...
  559.     $umask = umask 0;
  560.     $res = tie %{$self->{db_toks}},$self->DBM_MODULE, $name, O_RDWR|O_CREAT,
  561.      (oct ($main->{conf}->{bayes_file_mode}) & 0666);
  562.     umask $umask;
  563.     return 0 unless $res;
  564.     undef $res;
  565.  
  566.     dbg("bayes: upgraded database format from v".$self->{db_version}." to v3 in ".(time - $started)." seconds");
  567.  
  568.     $self->{db_version} = 3; # need this for other functions which check
  569.   }
  570.  
  571.   # if ($self->{db_version} == 3) {
  572.   #   ...
  573.   #   $self->{db_version} = 4; # need this for other functions which check
  574.   # }
  575.   # ... and so on.
  576.  
  577.   return 1;
  578. }
  579.  
  580. ###########################################################################
  581.  
  582. sub untie_db {
  583.   my $self = shift;
  584.  
  585.   return if (!$self->{already_tied});
  586.  
  587.   dbg("bayes: untie-ing");
  588.  
  589.   foreach my $dbname (@DBNAMES) {
  590.     my $db_var = 'db_'.$dbname;
  591.  
  592.     if (exists $self->{$db_var}) {
  593.       dbg("bayes: untie-ing $db_var");
  594.       untie %{$self->{$db_var}};
  595.       delete $self->{$db_var};
  596.     }
  597.   }
  598.  
  599.   if ($self->{is_locked}) {
  600.     dbg("bayes: files locked, now unlocking lock");
  601.     $self->{bayes}->{main}->{locker}->safe_unlock ($self->{locked_file});
  602.     $self->{is_locked} = 0;
  603.   }
  604.  
  605.   $self->{already_tied} = 0;
  606.   $self->{db_version} = undef;
  607. }
  608.  
  609. ###########################################################################
  610.  
  611. sub calculate_expire_delta {
  612.   my ($self, $newest_atime, $start, $max_expire_mult) = @_;
  613.  
  614.   my %delta = (); # use a hash since an array is going to be very sparse
  615.  
  616.   # do the first pass, figure out atime delta
  617.   my ($tok, $packed);
  618.   while (($tok, $packed) = each %{$self->{db_toks}}) {
  619.     next if ($tok =~ MAGIC_RE); # skip magic tokens
  620.     
  621.     my ($ts, $th, $atime) = $self->tok_unpack ($packed);
  622.  
  623.     # Go through from $start * 1 to $start * 512, mark how many tokens
  624.     # we would expire
  625.     my $token_age = $newest_atime - $atime;
  626.     for (my $i = 1; $i <= $max_expire_mult; $i<<=1) {
  627.       if ($token_age >= $start * $i) {
  628.         $delta{$i}++;
  629.       }
  630.       else {
  631.         # If the token age is less than the expire delta, it'll be
  632.         # less for all upcoming checks too, so abort early.
  633.         last;
  634.       }
  635.     }
  636.   }
  637.   return %delta;
  638. }
  639.  
  640. ###########################################################################
  641.  
  642. sub token_expiration {
  643.   my ($self, $opts, $newdelta, @vars) = @_;
  644.  
  645.   my $deleted = 0;
  646.   my $kept = 0;
  647.   my $num_hapaxes = 0;
  648.   my $num_lowfreq = 0;
  649.  
  650.   # since DB_File will not shrink a database (!!), we need to *create*
  651.   # a new one instead.
  652.   my $main = $self->{bayes}->{main};
  653.   my $path = $main->sed_path($main->{conf}->{bayes_path});
  654.  
  655.   # use a temporary PID-based suffix just in case another one was
  656.   # created previously by an interrupted expire
  657.   my $tmpsuffix = "expire$$";
  658.   my $tmpdbname = $path.'_toks.'.$tmpsuffix;
  659.  
  660.   # clean out any leftover db copies from previous runs
  661.   for my $ext ($self->DB_EXTENSIONS) { unlink ($tmpdbname.$ext); }
  662.  
  663.   # use O_EXCL to avoid races (bonus paranoia, since we should be locked
  664.   # anyway)
  665.   my %new_toks;
  666.   my $umask = umask 0;
  667.   tie %new_toks, $self->DBM_MODULE, $tmpdbname, O_RDWR|O_CREAT|O_EXCL,
  668.               (oct ($main->{conf}->{bayes_file_mode}) & 0666);
  669.   umask $umask;
  670.   my $oldest;
  671.  
  672.   my $showdots = $opts->{showdots};
  673.   if ($showdots) { print STDERR "\n"; }
  674.  
  675.   # We've chosen a new atime delta if we've gotten here, so record it
  676.   # for posterity.
  677.   $new_toks{$LAST_ATIME_DELTA_MAGIC_TOKEN} = $newdelta;
  678.  
  679.   # Figure out how old is too old...
  680.   my $too_old = $vars[10] - $newdelta; # tooold = newest - delta
  681.  
  682.   # Go ahead and do the move to new db/expire run now ...
  683.   my ($tok, $packed);
  684.   while (($tok, $packed) = each %{$self->{db_toks}}) {
  685.     next if ($tok =~ MAGIC_RE); # skip magic tokens
  686.  
  687.     my ($ts, $th, $atime) = $self->tok_unpack ($packed);
  688.  
  689.     if ($atime < $too_old) {
  690.       $deleted++;
  691.     }
  692.     else {
  693.       # if token atime > newest, reset to newest ...
  694.       if ($atime > $vars[10]) {
  695.         $atime = $vars[10];
  696.       }
  697.  
  698.       $new_toks{$tok} = $self->tok_pack ($ts, $th, $atime); $kept++;
  699.       if (!defined($oldest) || $atime < $oldest) { $oldest = $atime; }
  700.       if ($ts + $th == 1) {
  701.     $num_hapaxes++;
  702.       } elsif ($ts < 8 && $th < 8) {
  703.     $num_lowfreq++;
  704.       }
  705.     }
  706.  
  707.     if ((($kept + $deleted) % 1000) == 0) {
  708.       if ($showdots) { print STDERR "."; }
  709.       $self->set_running_expire_tok();
  710.     }
  711.   }
  712.  
  713.   # and add the magic tokens.  don't add the expire_running token.
  714.   $new_toks{$DB_VERSION_MAGIC_TOKEN} = $self->DB_VERSION;
  715.  
  716.   # We haven't changed messages of each type seen, so just copy over.
  717.   $new_toks{$NSPAM_MAGIC_TOKEN} = $vars[1];
  718.   $new_toks{$NHAM_MAGIC_TOKEN} = $vars[2];
  719.  
  720.   # We magically haven't removed the newest token, so just copy that value over.
  721.   $new_toks{$NEWEST_TOKEN_AGE_MAGIC_TOKEN} = $vars[10];
  722.  
  723.   # The rest of these have been modified, so replace as necessary.
  724.   $new_toks{$NTOKENS_MAGIC_TOKEN} = $kept;
  725.   $new_toks{$LAST_EXPIRE_MAGIC_TOKEN} = time();
  726.   $new_toks{$OLDEST_TOKEN_AGE_MAGIC_TOKEN} = $oldest;
  727.   $new_toks{$LAST_EXPIRE_REDUCE_MAGIC_TOKEN} = $deleted;
  728.  
  729.   # Sanity check: if we expired too many tokens, abort!
  730.   if ($kept < 100000) {
  731.     dbg("bayes: token expiration would expire too many tokens, aborting");
  732.     # set the magic tokens appropriately
  733.     # make sure the next expire run does a first pass
  734.     $self->{db_toks}->{$LAST_EXPIRE_MAGIC_TOKEN} = time();
  735.     $self->{db_toks}->{$LAST_EXPIRE_REDUCE_MAGIC_TOKEN} = 0;
  736.     $self->{db_toks}->{$LAST_ATIME_DELTA_MAGIC_TOKEN} = 0;
  737.  
  738.     # remove the new DB
  739.     untie %new_toks;
  740.     for my $ext ($self->DB_EXTENSIONS) { unlink ($tmpdbname.$ext); }
  741.  
  742.     # reset the results for the return
  743.     $kept = $vars[3];
  744.     $deleted = 0;
  745.     $num_hapaxes = 0;
  746.     $num_lowfreq = 0;
  747.   }
  748.   else {
  749.     # now untie so we can do renames
  750.     untie %{$self->{db_toks}};
  751.     untie %new_toks;
  752.  
  753.     # This is the critical phase (moving files around), so don't allow
  754.     # it to be interrupted.  Scope the signal changes.
  755.     {
  756.       local $SIG{'INT'} = 'IGNORE';
  757.       local $SIG{'TERM'} = 'IGNORE';
  758.       local $SIG{'HUP'} = 'IGNORE' if (!Mail::SpamAssassin::Util::am_running_on_windows());
  759.  
  760.       # now rename in the new one.  Try several extensions
  761.       for my $ext ($self->DB_EXTENSIONS) {
  762.         my $newf = $tmpdbname.$ext;
  763.         my $oldf = $path.'_toks'.$ext;
  764.         next unless (-f $newf);
  765.         if (!rename ($newf, $oldf)) {
  766.       warn "bayes: rename $newf to $oldf failed: $!\n";
  767.         }
  768.       }
  769.     }
  770.   }
  771.  
  772.   # Call untie_db() so we unlock correctly.
  773.   $self->untie_db();
  774.  
  775.   return ($kept, $deleted, $num_hapaxes, $num_lowfreq);
  776. }
  777.  
  778. ###########################################################################
  779.  
  780. # Is a sync due?
  781. sub sync_due {
  782.   my ($self) = @_;
  783.  
  784.   # don't bother doing old db versions
  785.   return 0 if ($self->{db_version} < $self->DB_VERSION);
  786.  
  787.   my $conf = $self->{bayes}->{main}->{conf};
  788.   return 0 if ($conf->{bayes_journal_max_size} == 0);
  789.  
  790.   my @vars = $self->get_storage_variables();
  791.   dbg("bayes: DB journal sync: last sync: ".$vars[7],'bayes','-1');
  792.  
  793.   ## Ok, should we do a sync?
  794.  
  795.   # Not if the journal file doesn't exist, it's not a file, or it's 0
  796.   # bytes long.
  797.   return 0 unless (stat($self->_get_journal_filename()) && -f _);
  798.  
  799.   # Yes if the file size is larger than the specified maximum size.
  800.   return 1 if (-s _ > $conf->{bayes_journal_max_size});
  801.  
  802.   # Yes there has been a sync before, and if it's been at least a day
  803.   # since that sync.
  804.   return 1 if (($vars[7] > 0) && (time - $vars[7] > 86400));
  805.  
  806.   # No, I guess not.
  807.   return 0;
  808. }
  809.  
  810. ###########################################################################
  811. # db_seen reading APIs
  812.  
  813. sub seen_get {
  814.   my ($self, $msgid) = @_;
  815.   $self->{db_seen}->{$msgid};
  816. }
  817.  
  818. sub seen_put {
  819.   my ($self, $msgid, $seen) = @_;
  820.  
  821.   if ($self->{bayes}->{main}->{learn_to_journal}) {
  822.     $self->defer_update ("m $seen $msgid");
  823.   }
  824.   else {
  825.     $self->_seen_put_direct($msgid, $seen);
  826.   }
  827. }
  828. sub _seen_put_direct {
  829.   my ($self, $msgid, $seen) = @_;
  830.   $self->{db_seen}->{$msgid} = $seen;
  831. }
  832.  
  833. sub seen_delete {
  834.   my ($self, $msgid) = @_;
  835.  
  836.   if ($self->{bayes}->{main}->{learn_to_journal}) {
  837.     $self->defer_update ("m f $msgid");
  838.   }
  839.   else {
  840.     $self->_seen_delete_direct($msgid);
  841.   }
  842. }
  843. sub _seen_delete_direct {
  844.   my ($self, $msgid) = @_;
  845.   delete $self->{db_seen}->{$msgid};
  846. }
  847.  
  848. ###########################################################################
  849. # db reading APIs
  850.  
  851. sub tok_get {
  852.   my ($self, $tok) = @_;
  853.   $self->tok_unpack ($self->{db_toks}->{$tok});
  854. }
  855.  
  856. sub tok_get_all {
  857.   my ($self, @tokens) = @_;
  858.  
  859.   my @tokensdata;
  860.   foreach my $token (@tokens) {
  861.     my ($tok_spam, $tok_ham, $atime) = $self->tok_unpack($self->{db_toks}->{$token});
  862.     push(@tokensdata, [$token, $tok_spam, $tok_ham, $atime]);
  863.   }
  864.   return \@tokensdata;
  865. }
  866.  
  867. # return the magic tokens in a specific order:
  868. # 0: scan count base
  869. # 1: number of spam
  870. # 2: number of ham
  871. # 3: number of tokens in db
  872. # 4: last expire atime
  873. # 5: oldest token in db atime
  874. # 6: db version value
  875. # 7: last journal sync
  876. # 8: last atime delta
  877. # 9: last expire reduction count
  878. # 10: newest token in db atime
  879. #
  880. sub get_storage_variables {
  881.   my ($self) = @_;
  882.   my @values;
  883.  
  884.   my $db_ver = $self->{db_toks}->{$DB_VERSION_MAGIC_TOKEN};
  885.  
  886.   if (!$db_ver || $db_ver =~ /\D/) { $db_ver = 0; }
  887.  
  888.   if ($db_ver >= 2) {
  889.     my $DB2_LAST_ATIME_DELTA_MAGIC_TOKEN    = "\015\001\007\011\003LASTATIMEDELTA";
  890.     my $DB2_LAST_EXPIRE_MAGIC_TOKEN        = "\015\001\007\011\003LASTEXPIRE";
  891.     my $DB2_LAST_EXPIRE_REDUCE_MAGIC_TOKEN    = "\015\001\007\011\003LASTEXPIREREDUCE";
  892.     my $DB2_LAST_JOURNAL_SYNC_MAGIC_TOKEN    = "\015\001\007\011\003LASTJOURNALSYNC";
  893.     my $DB2_NEWEST_TOKEN_AGE_MAGIC_TOKEN    = "\015\001\007\011\003NEWESTAGE";
  894.     my $DB2_NHAM_MAGIC_TOKEN            = "\015\001\007\011\003NHAM";
  895.     my $DB2_NSPAM_MAGIC_TOKEN            = "\015\001\007\011\003NSPAM";
  896.     my $DB2_NTOKENS_MAGIC_TOKEN            = "\015\001\007\011\003NTOKENS";
  897.     my $DB2_OLDEST_TOKEN_AGE_MAGIC_TOKEN    = "\015\001\007\011\003OLDESTAGE";
  898.     my $DB2_RUNNING_EXPIRE_MAGIC_TOKEN        = "\015\001\007\011\003RUNNINGEXPIRE";
  899.  
  900.     @values = (
  901.       0,
  902.       $self->{db_toks}->{$DB2_NSPAM_MAGIC_TOKEN},
  903.       $self->{db_toks}->{$DB2_NHAM_MAGIC_TOKEN},
  904.       $self->{db_toks}->{$DB2_NTOKENS_MAGIC_TOKEN},
  905.       $self->{db_toks}->{$DB2_LAST_EXPIRE_MAGIC_TOKEN},
  906.       $self->{db_toks}->{$DB2_OLDEST_TOKEN_AGE_MAGIC_TOKEN},
  907.       $db_ver,
  908.       $self->{db_toks}->{$DB2_LAST_JOURNAL_SYNC_MAGIC_TOKEN},
  909.       $self->{db_toks}->{$DB2_LAST_ATIME_DELTA_MAGIC_TOKEN},
  910.       $self->{db_toks}->{$DB2_LAST_EXPIRE_REDUCE_MAGIC_TOKEN},
  911.       $self->{db_toks}->{$DB2_NEWEST_TOKEN_AGE_MAGIC_TOKEN},
  912.     );
  913.   }
  914.   elsif ($db_ver == 0) {
  915.     my $DB0_NSPAM_MAGIC_TOKEN = '**NSPAM';
  916.     my $DB0_NHAM_MAGIC_TOKEN = '**NHAM';
  917.     my $DB0_OLDEST_TOKEN_AGE_MAGIC_TOKEN = '**OLDESTAGE';
  918.     my $DB0_LAST_EXPIRE_MAGIC_TOKEN = '**LASTEXPIRE';
  919.     my $DB0_NTOKENS_MAGIC_TOKEN = '**NTOKENS';
  920.     my $DB0_SCANCOUNT_BASE_MAGIC_TOKEN = '**SCANBASE';
  921.  
  922.     @values = (
  923.       $self->{db_toks}->{$DB0_SCANCOUNT_BASE_MAGIC_TOKEN},
  924.       $self->{db_toks}->{$DB0_NSPAM_MAGIC_TOKEN},
  925.       $self->{db_toks}->{$DB0_NHAM_MAGIC_TOKEN},
  926.       $self->{db_toks}->{$DB0_NTOKENS_MAGIC_TOKEN},
  927.       $self->{db_toks}->{$DB0_LAST_EXPIRE_MAGIC_TOKEN},
  928.       $self->{db_toks}->{$DB0_OLDEST_TOKEN_AGE_MAGIC_TOKEN},
  929.       0,
  930.       0,
  931.       0,
  932.       0,
  933.       0,
  934.     );
  935.   }
  936.   elsif ($db_ver == 1) {
  937.     my $DB1_NSPAM_MAGIC_TOKEN            = "\015\001\007\011\003NSPAM";
  938.     my $DB1_NHAM_MAGIC_TOKEN            = "\015\001\007\011\003NHAM";
  939.     my $DB1_OLDEST_TOKEN_AGE_MAGIC_TOKEN    = "\015\001\007\011\003OLDESTAGE";
  940.     my $DB1_LAST_EXPIRE_MAGIC_TOKEN        = "\015\001\007\011\003LASTEXPIRE";
  941.     my $DB1_NTOKENS_MAGIC_TOKEN            = "\015\001\007\011\003NTOKENS";
  942.     my $DB1_SCANCOUNT_BASE_MAGIC_TOKEN        = "\015\001\007\011\003SCANBASE";
  943.  
  944.     @values = (
  945.       $self->{db_toks}->{$DB1_SCANCOUNT_BASE_MAGIC_TOKEN},
  946.       $self->{db_toks}->{$DB1_NSPAM_MAGIC_TOKEN},
  947.       $self->{db_toks}->{$DB1_NHAM_MAGIC_TOKEN},
  948.       $self->{db_toks}->{$DB1_NTOKENS_MAGIC_TOKEN},
  949.       $self->{db_toks}->{$DB1_LAST_EXPIRE_MAGIC_TOKEN},
  950.       $self->{db_toks}->{$DB1_OLDEST_TOKEN_AGE_MAGIC_TOKEN},
  951.       1,
  952.       0,
  953.       0,
  954.       0,
  955.       0,
  956.     );
  957.   }
  958.  
  959.   foreach (@values) {
  960.     if (!$_ || $_ =~ /\D/) {
  961.       $_ = 0;
  962.     }
  963.   }
  964.  
  965.   return @values;
  966. }
  967.  
  968. sub dump_db_toks {
  969.   my ($self, $template, $regex, @vars) = @_;
  970.  
  971.   while (my ($tok, $tokvalue) = each %{$self->{db_toks}}) {
  972.     next if ($tok =~ MAGIC_RE); # skip magic tokens
  973.     next if (defined $regex && ($tok !~ /$regex/o));
  974.  
  975.     # We have the value already, so just unpack it.
  976.     my ($ts, $th, $atime) = $self->tok_unpack ($tokvalue);
  977.     
  978.     my $prob = $self->{bayes}->compute_prob_for_token($tok, $vars[1], $vars[2], $ts, $th);
  979.     $prob ||= 0.5;
  980.     
  981.     my $encoded_tok = unpack("H*",$tok);
  982.     printf $template,$prob,$ts,$th,$atime,$encoded_tok;
  983.   }
  984. }
  985.  
  986. sub set_last_expire {
  987.   my ($self, $time) = @_;
  988.   $self->{db_toks}->{$LAST_EXPIRE_MAGIC_TOKEN} = time();
  989. }
  990.  
  991. ## Don't bother using get_magic_tokens here.  This token should only
  992. ## ever exist when we're running expire, so we don't want to convert it if
  993. ## it's there and we're not expiring ...
  994. sub get_running_expire_tok {
  995.   my ($self) = @_;
  996.   my $running = $self->{db_toks}->{$RUNNING_EXPIRE_MAGIC_TOKEN};
  997.   if (!$running || $running =~ /\D/) { return undef; }
  998.   return $running;
  999. }
  1000.  
  1001. sub set_running_expire_tok {
  1002.   my ($self) = @_;
  1003.  
  1004.   # update the lock and and running expire magic token
  1005.   $self->{bayes}->{main}->{locker}->refresh_lock ($self->{locked_file});
  1006.   $self->{db_toks}->{$RUNNING_EXPIRE_MAGIC_TOKEN} = time();
  1007. }
  1008.  
  1009. sub remove_running_expire_tok {
  1010.   my ($self) = @_;
  1011.   delete $self->{db_toks}->{$RUNNING_EXPIRE_MAGIC_TOKEN};
  1012. }
  1013.  
  1014. ###########################################################################
  1015.  
  1016. # db abstraction: allow deferred writes, since we will be frequently
  1017. # writing while checking.
  1018.  
  1019. sub tok_count_change {
  1020.   my ($self, $ds, $dh, $tok, $atime) = @_;
  1021.  
  1022.   $atime = 0 unless defined $atime;
  1023.  
  1024.   if ($self->{bayes}->{main}->{learn_to_journal}) {
  1025.     # we can't store the SHA1 binary value in the journal to convert it
  1026.     # to a printable value that can be converted back later
  1027.     my $encoded_tok = unpack("H*",$tok);
  1028.     $self->defer_update ("c $ds $dh $atime $encoded_tok");
  1029.   } else {
  1030.     $self->tok_sync_counters ($ds, $dh, $atime, $tok);
  1031.   }
  1032. }
  1033.  
  1034. sub multi_tok_count_change {
  1035.   my ($self, $ds, $dh, $tokens, $atime) = @_;
  1036.  
  1037.   $atime = 0 unless defined $atime;
  1038.  
  1039.   foreach my $tok (keys %{$tokens}) {
  1040.     if ($self->{bayes}->{main}->{learn_to_journal}) {
  1041.       # we can't store the SHA1 binary value in the journal to convert it
  1042.       # to a printable value that can be converted back later
  1043.       my $encoded_tok = unpack("H*",$tok);
  1044.       $self->defer_update ("c $ds $dh $atime $encoded_tok");
  1045.     } else {
  1046.       $self->tok_sync_counters ($ds, $dh, $atime, $tok);
  1047.     }
  1048.   }
  1049. }
  1050.  
  1051. sub nspam_nham_get {
  1052.   my ($self) = @_;
  1053.   my @vars = $self->get_storage_variables();
  1054.   ($vars[1], $vars[2]);
  1055. }
  1056.  
  1057. sub nspam_nham_change {
  1058.   my ($self, $ds, $dh) = @_;
  1059.  
  1060.   if ($self->{bayes}->{main}->{learn_to_journal}) {
  1061.     $self->defer_update ("n $ds $dh");
  1062.   } else {
  1063.     $self->tok_sync_nspam_nham ($ds, $dh);
  1064.   }
  1065. }
  1066.  
  1067. sub tok_touch {
  1068.   my ($self, $tok, $atime) = @_;
  1069.   # we can't store the SHA1 binary value in the journal to convert it
  1070.   # to a printable value that can be converted back later
  1071.   my $encoded_tok = unpack("H*", $tok);
  1072.   $self->defer_update ("t $atime $encoded_tok");
  1073. }
  1074.  
  1075. sub tok_touch_all {
  1076.   my ($self, $tokens, $atime) = @_;
  1077.  
  1078.   foreach my $token (@{$tokens}) {
  1079.     # we can't store the SHA1 binary value in the journal to convert it
  1080.     # to a printable value that can be converted back later
  1081.     my $encoded_tok = unpack("H*", $token);
  1082.     $self->defer_update ("t $atime $encoded_tok");
  1083.   }
  1084. }
  1085.  
  1086. sub defer_update {
  1087.   my ($self, $str) = @_;
  1088.   $self->{string_to_journal} .= "$str\n";
  1089. }
  1090.  
  1091. ###########################################################################
  1092.  
  1093. sub cleanup {
  1094.   my ($self) = @_;
  1095.  
  1096.   my $nbytes = length ($self->{string_to_journal});
  1097.   return if ($nbytes == 0);
  1098.  
  1099.   my $path = $self->_get_journal_filename();
  1100.  
  1101.   # use append mode, write atomically, then close, so simultaneous updates are
  1102.   # not lost
  1103.   my $conf = $self->{bayes}->{main}->{conf};
  1104.  
  1105.   # set the umask to the inverse of what we want ...
  1106.   my $umask = umask(0777 - (oct ($conf->{bayes_file_mode}) & 0666));
  1107.  
  1108.   if (!open (OUT, ">>".$path)) {
  1109.     warn "bayes: cannot write to $path, bayes db update ignored: $!\n";
  1110.     umask $umask; # reset umask
  1111.     return;
  1112.   }
  1113.   umask $umask; # reset umask
  1114.  
  1115.   # do not use print() here, it will break up the buffer if it's >8192 bytes,
  1116.   # which could result in two sets of tokens getting mixed up and their
  1117.   # touches missed.
  1118.   my $write_failure = 0;
  1119.   my $original_point = tell OUT;
  1120.   my $len;
  1121.   do {
  1122.     $len = syswrite (OUT, $self->{string_to_journal}, $nbytes);
  1123.  
  1124.     # argh, write failure, give up
  1125.     if (!defined $len || $len < 0) {
  1126.       $len = 0 unless (defined $len);
  1127.       warn "bayes: write failed to Bayes journal $path ($len of $nbytes)!\n";
  1128.       last;
  1129.     }
  1130.  
  1131.     # This shouldn't happen, but could if the fs is full...
  1132.     if ($len != $nbytes) {
  1133.       warn "bayes: partial write to bayes journal $path ($len of $nbytes), recovering\n";
  1134.  
  1135.       # we want to be atomic, so revert the journal file back to where
  1136.       # we know it's "good".  if we can't truncate the journal, or we've
  1137.       # tried 5 times to do the write, abort!
  1138.       if (!truncate(OUT, $original_point) || ($write_failure++ > 4)) {
  1139.         warn "bayes: cannot write to bayes journal $path, aborting!\n";
  1140.     last;
  1141.       }
  1142.  
  1143.       # if the fs is full, let's give the system a break
  1144.       sleep 1;
  1145.     }
  1146.   } while ($len != $nbytes);
  1147.  
  1148.   if (!close OUT) {
  1149.     warn "bayes: cannot write to $path, bayes db update ignored\n";
  1150.   }
  1151.  
  1152.   $self->{string_to_journal} = '';
  1153. }
  1154.  
  1155. # Return a qr'd RE to match a token with the correct format's magic token
  1156. sub get_magic_re {
  1157.   my ($self) = @_;
  1158.  
  1159.   if (!defined $self->{db_version} || $self->{db_version} >= 1) {
  1160.     return MAGIC_RE;
  1161.   }
  1162.  
  1163.   # When in doubt, assume v0
  1164.   return qr/^\*\*[A-Z]+$/;
  1165. }
  1166.  
  1167. # provide a more generalized public insterface into the journal sync
  1168.  
  1169. sub sync {
  1170.   my ($self, $opts) = @_;
  1171.  
  1172.   return $self->_sync_journal($opts);
  1173. }
  1174.  
  1175. ###########################################################################
  1176. # And this method reads the journal and applies the changes in one
  1177. # (locked) transaction.
  1178.  
  1179. sub _sync_journal {
  1180.   my ($self, $opts) = @_;
  1181.   my $ret = 0;
  1182.  
  1183.   my $path = $self->_get_journal_filename();
  1184.  
  1185.   # if $path doesn't exist, or it's not a file, or is 0 bytes in length, return
  1186.   if (!stat($path) || !-f _ || -z _) {
  1187.     return 0;
  1188.   }
  1189.  
  1190.   eval {
  1191.     local $SIG{'__DIE__'};    # do not run user die() traps in here
  1192.     if ($self->tie_db_writable()) {
  1193.       $ret = $self->_sync_journal_trapped($opts, $path);
  1194.     }
  1195.   };
  1196.   my $err = $@;
  1197.  
  1198.   # ok, untie from write-mode if we can
  1199.   if (!$self->{bayes}->{main}->{learn_caller_will_untie}) {
  1200.     $self->untie_db();
  1201.   }
  1202.  
  1203.   # handle any errors that may have occurred
  1204.   if ($err) {
  1205.     warn "bayes: $err\n";
  1206.     return 0;
  1207.   }
  1208.  
  1209.   $ret;
  1210. }
  1211.  
  1212. sub _sync_journal_trapped {
  1213.   my ($self, $opts, $path) = @_;
  1214.  
  1215.   # Flag that we're doing work
  1216.   $self->set_running_expire_tok();
  1217.  
  1218.   my $started = time();
  1219.   my $count = 0;
  1220.   my $total_count = 0;
  1221.   my %tokens = ();
  1222.   my $showdots = $opts->{showdots};
  1223.   my $retirepath = $path.".old";
  1224.  
  1225.   # if $path doesn't exist, or it's not a file, or is 0 bytes in length,
  1226.   # return we have to check again since the file may have been removed
  1227.   # by a recent bayes db upgrade ...
  1228.   if (!stat($path) || !-f _ || -z _) {
  1229.     return 0;
  1230.   }
  1231.  
  1232.   if (!-r $path) { # will we be able to read the file?
  1233.     warn "bayes: bad permissions on journal, can't read: $path\n";
  1234.     return 0;
  1235.   }
  1236.  
  1237.   # This is the critical phase (moving files around), so don't allow
  1238.   # it to be interrupted.
  1239.   {
  1240.     local $SIG{'INT'} = 'IGNORE';
  1241.     local $SIG{'TERM'} = 'IGNORE';
  1242.     local $SIG{'HUP'} = 'IGNORE' if (!Mail::SpamAssassin::Util::am_running_on_windows());
  1243.  
  1244.     # retire the journal, so we can update the db files from it in peace.
  1245.     # TODO: use locking here
  1246.     if (!rename ($path, $retirepath)) {
  1247.       warn "bayes: failed rename $path to $retirepath\n";
  1248.       return 0;
  1249.     }
  1250.  
  1251.     # now read the retired journal
  1252.     if (!open (JOURNAL, "<$retirepath")) {
  1253.       warn "bayes: cannot open read $retirepath\n";
  1254.       return 0;
  1255.     }
  1256.  
  1257.  
  1258.     # Read the journal
  1259.     while (<JOURNAL>) {
  1260.       $total_count++;
  1261.  
  1262.       if (/^t (\d+) (.+)$/) { # Token timestamp update, cache resultant entries
  1263.     my $tok = pack("H*",$2);
  1264.     $tokens{$tok} = $1+0 if (!exists $tokens{$tok} || $1+0 > $tokens{$tok});
  1265.       } elsif (/^c (-?\d+) (-?\d+) (\d+) (.+)$/) { # Add/full token update
  1266.     my $tok = pack("H*",$4);
  1267.     $self->tok_sync_counters ($1+0, $2+0, $3+0, $tok);
  1268.     $count++;
  1269.       } elsif (/^n (-?\d+) (-?\d+)$/) { # update ham/spam count
  1270.     $self->tok_sync_nspam_nham ($1+0, $2+0);
  1271.     $count++;
  1272.       } elsif (/^m ([hsf]) (.+)$/) { # update msgid seen database
  1273.     if ($1 eq "f") {
  1274.       $self->_seen_delete_direct($2);
  1275.     }
  1276.     else {
  1277.       $self->_seen_put_direct($2,$1);
  1278.     }
  1279.     $count++;
  1280.       } else {
  1281.     warn "bayes: gibberish entry found in journal: $_";
  1282.       }
  1283.     }
  1284.     close JOURNAL;
  1285.  
  1286.     # Now that we've determined what tokens we need to update and their
  1287.     # final values, update the DB.  Should be much smaller than the full
  1288.     # journal entries.
  1289.     while (my ($k,$v) = each %tokens) {
  1290.       $self->tok_touch_token ($v, $k);
  1291.  
  1292.       if ((++$count % 1000) == 0) {
  1293.     if ($showdots) { print STDERR "."; }
  1294.     $self->set_running_expire_tok();
  1295.       }
  1296.     }
  1297.  
  1298.     if ($showdots) { print STDERR "\n"; }
  1299.  
  1300.     # we're all done, so unlink the old journal file
  1301.     unlink ($retirepath) || warn "bayes: can't unlink $retirepath: $!\n";
  1302.  
  1303.     $self->{db_toks}->{$LAST_JOURNAL_SYNC_MAGIC_TOKEN} = $started;
  1304.  
  1305.     my $done = time();
  1306.     my $msg = ("bayes: synced databases from journal in " .
  1307.            ($done - $started) .
  1308.            " seconds: $count unique entries ($total_count total entries)");
  1309.  
  1310.     if ($opts->{verbose}) {
  1311.       print $msg,"\n";
  1312.     } else {
  1313.       dbg($msg);
  1314.     }
  1315.   }
  1316.  
  1317.   # else, that's the lot, we're synced.  return
  1318.   return 1;
  1319. }
  1320.  
  1321. sub tok_touch_token {
  1322.   my ($self, $atime, $tok) = @_;
  1323.   my ($ts, $th, $oldatime) = $self->tok_get ($tok);
  1324.  
  1325.   # If the new atime is < the old atime, ignore the update
  1326.   # We figure that we'll never want to lower a token atime, so abort if
  1327.   # we try.  (journal out of sync, etc.)
  1328.   return if ($oldatime >= $atime);
  1329.  
  1330.   $self->tok_put ($tok, $ts, $th, $atime);
  1331. }
  1332.  
  1333. sub tok_sync_counters {
  1334.   my ($self, $ds, $dh, $atime, $tok) = @_;
  1335.   my ($ts, $th, $oldatime) = $self->tok_get ($tok);
  1336.   $ts += $ds; if ($ts < 0) { $ts = 0; }
  1337.   $th += $dh; if ($th < 0) { $th = 0; }
  1338.  
  1339.   # Don't roll the atime of tokens backwards ...
  1340.   $atime = $oldatime if ($oldatime > $atime);
  1341.  
  1342.   $self->tok_put ($tok, $ts, $th, $atime);
  1343. }
  1344.  
  1345. sub tok_put {
  1346.   my ($self, $tok, $ts, $th, $atime) = @_;
  1347.   $ts ||= 0;
  1348.   $th ||= 0;
  1349.  
  1350.   # Ignore magic tokens, the don't go in this way ...
  1351.   return if ($tok =~ MAGIC_RE);
  1352.  
  1353.   # use defined() rather than exists(); the latter is not supported
  1354.   # by NDBM_File, believe it or not.  Using defined() did not
  1355.   # indicate any noticeable speed hit in my testing. (Mar 31 2003 jm)
  1356.   my $exists_already = defined $self->{db_toks}->{$tok};
  1357.  
  1358.   if ($ts == 0 && $th == 0) {
  1359.     return if (!$exists_already); # If the token doesn't exist, just return
  1360.     $self->{db_toks}->{$NTOKENS_MAGIC_TOKEN}--;
  1361.     delete $self->{db_toks}->{$tok};
  1362.   } else {
  1363.     if (!$exists_already) { # If the token doesn't exist, raise the token count
  1364.       $self->{db_toks}->{$NTOKENS_MAGIC_TOKEN}++;
  1365.     }
  1366.  
  1367.     $self->{db_toks}->{$tok} = $self->tok_pack ($ts, $th, $atime);
  1368.  
  1369.     my $newmagic = $self->{db_toks}->{$NEWEST_TOKEN_AGE_MAGIC_TOKEN};
  1370.     if (!defined ($newmagic) || $atime > $newmagic) {
  1371.       $self->{db_toks}->{$NEWEST_TOKEN_AGE_MAGIC_TOKEN} = $atime;
  1372.     }
  1373.  
  1374.     # Make sure to check for either !defined or "" ...  Apparently
  1375.     # sometimes the DB module doesn't return the value correctly. :(
  1376.     my $oldmagic = $self->{db_toks}->{$OLDEST_TOKEN_AGE_MAGIC_TOKEN};
  1377.     if (!defined ($oldmagic) || $oldmagic eq "" || $atime < $oldmagic) {
  1378.       $self->{db_toks}->{$OLDEST_TOKEN_AGE_MAGIC_TOKEN} = $atime;
  1379.     }
  1380.   }
  1381. }
  1382.  
  1383. sub tok_sync_nspam_nham {
  1384.   my ($self, $ds, $dh) = @_;
  1385.   my ($ns, $nh) = ($self->get_storage_variables())[1,2];
  1386.   if ($ds) { $ns += $ds; } if ($ns < 0) { $ns = 0; }
  1387.   if ($dh) { $nh += $dh; } if ($nh < 0) { $nh = 0; }
  1388.   $self->{db_toks}->{$NSPAM_MAGIC_TOKEN} = $ns;
  1389.   $self->{db_toks}->{$NHAM_MAGIC_TOKEN} = $nh;
  1390. }
  1391.  
  1392. ###########################################################################
  1393.  
  1394. sub _get_journal_filename {
  1395.   my ($self) = @_;
  1396.  
  1397.   my $main = $self->{bayes}->{main};
  1398.   return $main->sed_path($main->{conf}->{bayes_path}."_journal");
  1399. }
  1400.  
  1401. ###########################################################################
  1402.  
  1403. # this is called directly from sa-learn(1).
  1404. sub perform_upgrade {
  1405.   my ($self, $opts) = @_;
  1406.   my $ret = 0;
  1407.  
  1408.   eval {
  1409.     local $SIG{'__DIE__'};    # do not run user die() traps in here
  1410.  
  1411.     use File::Basename;
  1412.     use File::Copy;
  1413.  
  1414.     # bayes directory
  1415.     my $main = $self->{bayes}->{main};
  1416.     my $path = $main->sed_path($main->{conf}->{bayes_path});
  1417.     my $dir = dirname($path);
  1418.  
  1419.     # make temporary copy since old dbm and new dbm may have same name
  1420.     opendir(DIR, $dir) || die "bayes: can't opendir $dir: $!";
  1421.     my @files = grep { /^bayes_(?:seen|toks)(?:\.\w+)?$/ } readdir(DIR);
  1422.     closedir(DIR);
  1423.     if (@files < 2 || !grep(/bayes_seen/,@files) || !grep(/bayes_toks/,@files))
  1424.     {
  1425.       die "bayes: unable to find bayes_toks and bayes_seen, stopping\n";
  1426.     }
  1427.     # untaint @files (already safe after grep)
  1428.     @files = map { /(.*)/, $1 } @files;
  1429.       
  1430.     for (@files) {
  1431.       my $src = "$dir/$_";
  1432.       my $dst = "$dir/old_$_";
  1433.       copy($src, $dst) || die "bayes: can't copy $src to $dst: $!\n";
  1434.     }
  1435.  
  1436.     # delete previous to make way for import
  1437.     for (@files) { unlink("$dir/$_"); }
  1438.  
  1439.     # import
  1440.     if ($self->tie_db_writable()) {
  1441.       $ret += $self->upgrade_old_dbm_files_trapped("$dir/old_bayes_seen",
  1442.                            $self->{db_seen});
  1443.       $ret += $self->upgrade_old_dbm_files_trapped("$dir/old_bayes_toks",
  1444.                            $self->{db_toks});
  1445.     }
  1446.  
  1447.     if ($ret == 2) {
  1448.       print "import successful, original files saved with \"old\" prefix\n";
  1449.     }
  1450.     else {
  1451.       print "import failed, original files saved with \"old\" prefix\n";
  1452.     }
  1453.   };
  1454.   my $err = $@;
  1455.  
  1456.   $self->untie_db();
  1457.  
  1458.   # if we died, untie the dbm files
  1459.   if ($err) {
  1460.     warn "bayes: perform_upgrade: $err\n";
  1461.     return 0;
  1462.   }
  1463.   $ret;
  1464. }
  1465.  
  1466. sub upgrade_old_dbm_files_trapped {
  1467.   my ($self, $filename, $output) = @_;
  1468.  
  1469.   my $count;
  1470.   my %in;
  1471.  
  1472.   print "upgrading to " . $self->DBM_MODULE . ", please be patient: $filename\n";
  1473.  
  1474.   # try each type of file until we find one with > 0 entries
  1475.   for my $dbm ('DB_File', 'GDBM_File', 'NDBM_File', 'SDBM_File') {
  1476.     $count = 0;
  1477.     # wrap in eval so it doesn't run in general use.  This accesses db
  1478.     # modules directly.
  1479.     # Note: (bug 2390), the 'use' needs to be on the same line as the eval
  1480.     # for RPM dependency checks to work properly.  It's lame, but...
  1481.     eval 'use ' . $dbm . ';
  1482.       tie %in, "' . $dbm . '", $filename, O_RDONLY, 0600;
  1483.       %{ $output } = %in;
  1484.       $count = scalar keys %{ $output };
  1485.       untie %in;
  1486.     ';
  1487.     if ($@) {
  1488.       print "$dbm: $dbm module not installed, nothing copied\n";
  1489.       dbg("bayes: error was: $@");
  1490.     }
  1491.     elsif ($count == 0) {
  1492.       print "$dbm: no database of that kind found, nothing copied\n";
  1493.     }
  1494.     else {
  1495.       print "$dbm: copied $count entries\n";
  1496.       return 1;
  1497.     }
  1498.   }
  1499.  
  1500.   return 0;
  1501. }
  1502.  
  1503. sub clear_database {
  1504.   my ($self) = @_;
  1505.  
  1506.   return 0 unless ($self->tie_db_writable());
  1507.  
  1508.   dbg("bayes: untie-ing in preparation for removal.");
  1509.  
  1510.   foreach my $dbname (@DBNAMES) {
  1511.     my $db_var = 'db_'.$dbname;
  1512.  
  1513.     if (exists $self->{$db_var}) {
  1514.       dbg("bayes: untie-ing $db_var");
  1515.       untie %{$self->{$db_var}};
  1516.       delete $self->{$db_var};
  1517.     }
  1518.   }
  1519.  
  1520.   my $path = $self->{bayes}->{main}->sed_path($self->{bayes}->{main}->{conf}->{bayes_path});
  1521.  
  1522.   foreach my $dbname (@DBNAMES, 'journal') {
  1523.     foreach my $ext ($self->DB_EXTENSIONS) {
  1524.       my $name = $path.'_'.$dbname.$ext;
  1525.       my $ret = unlink $name;
  1526.       dbg("bayes: clear_database: " . ($ret ? 'removed' : 'tried to remove') . " $name");
  1527.     }
  1528.   }
  1529.  
  1530.   # the journal file needs to be done separately since it has no extension
  1531.   foreach my $dbname ('journal') {
  1532.     my $name = $path.'_'.$dbname;
  1533.     my $ret = unlink $name;
  1534.     dbg("bayes: clear_database: " . ($ret ? 'removed' : 'tried to remove') . " $name");
  1535.   }
  1536.  
  1537.   $self->untie_db();
  1538.  
  1539.   return 1;
  1540. }
  1541.  
  1542. sub backup_database {
  1543.   my ($self) = @_;
  1544.  
  1545.   # we tie writable because we want the upgrade code to kick in if needed
  1546.   return 0 unless ($self->tie_db_writable());
  1547.  
  1548.   my @vars = $self->get_storage_variables();
  1549.  
  1550.   print "v\t$vars[6]\tdb_version # this must be the first line!!!\n";
  1551.   print "v\t$vars[1]\tnum_spam\n";
  1552.   print "v\t$vars[2]\tnum_nonspam\n";
  1553.  
  1554.   while (my ($tok, $packed) = each %{$self->{db_toks}}) {
  1555.     next if ($tok =~ MAGIC_RE); # skip magic tokens
  1556.  
  1557.     my ($ts, $th, $atime) = $self->tok_unpack($packed);
  1558.     my $encoded_token = unpack("H*",$tok);
  1559.     print "t\t$ts\t$th\t$atime\t$encoded_token\n";
  1560.   }
  1561.  
  1562.   while (my ($msgid, $flag) = each %{$self->{db_seen}}) {
  1563.     print "s\t$flag\t$msgid\n";
  1564.   }
  1565.  
  1566.   $self->untie_db();
  1567.  
  1568.   return 1;
  1569. }
  1570.  
  1571. sub restore_database {
  1572.   my ($self, $filename, $showdots) = @_;
  1573.  
  1574.   if (!open(DUMPFILE, '<', $filename)) {
  1575.     dbg("bayes: unable to open backup file $filename: $!");
  1576.     return 0;
  1577.   }
  1578.    
  1579.   if (!$self->tie_db_writable()) {
  1580.     dbg("bayes: failed to tie db writable");
  1581.     return 0;
  1582.   }
  1583.  
  1584.   my $main = $self->{bayes}->{main};
  1585.   my $path = $main->sed_path($main->{conf}->{bayes_path});
  1586.  
  1587.   # use a temporary PID-based suffix just in case another one was
  1588.   # created previously by an interrupted expire
  1589.   my $tmpsuffix = "convert$$";
  1590.   my $tmptoksdbname = $path.'_toks.'.$tmpsuffix;
  1591.   my $tmpseendbname = $path.'_seen.'.$tmpsuffix;
  1592.   my $toksdbname = $path.'_toks';
  1593.   my $seendbname = $path.'_seen';
  1594.  
  1595.   my %new_toks;
  1596.   my %new_seen;
  1597.   my $umask = umask 0;
  1598.   unless (tie %new_toks, $self->DBM_MODULE, $tmptoksdbname, O_RDWR|O_CREAT|O_EXCL,
  1599.       (oct ($main->{conf}->{bayes_file_mode}) & 0666)) {
  1600.     dbg("bayes: failed to tie temp toks db: $!");
  1601.     $self->untie_db();
  1602.     umask $umask;
  1603.     return 0;
  1604.   }
  1605.   unless (tie %new_seen, $self->DBM_MODULE, $tmpseendbname, O_RDWR|O_CREAT|O_EXCL,
  1606.       (oct ($main->{conf}->{bayes_file_mode}) & 0666)) {
  1607.     dbg("bayes: failed to tie temp seen db: $!");
  1608.     untie %new_toks;
  1609.     $self->_unlink_file($tmptoksdbname);
  1610.     $self->untie_db();
  1611.     umask $umask;
  1612.     return 0;
  1613.   }
  1614.   umask $umask;
  1615.  
  1616.   my $line_count = 0;
  1617.   my $db_version;
  1618.   my $token_count = 0;
  1619.   my $num_spam;
  1620.   my $num_ham;
  1621.   my $error_p = 0;
  1622.   my $newest_token_age = 0;
  1623.   # Kinda wierd I know, but we need a nice big value and we know there will be
  1624.   # no tokens > time() since we reset atime if > time(), so use that with a
  1625.   # little buffer just in case.
  1626.   my $oldest_token_age = time() + 100000;
  1627.  
  1628.   my $line = <DUMPFILE>;
  1629.   $line_count++;
  1630.  
  1631.   # We require the database version line to be the first in the file so we can
  1632.   # figure out how to properly deal with the file.  If it is not the first
  1633.   # line then fail
  1634.   if ($line =~ m/^v\s+(\d+)\s+db_version/) {
  1635.     $db_version = $1;
  1636.   }
  1637.   else {
  1638.     dbg("bayes: database version must be the first line in the backup file, correct and re-run");
  1639.     untie %new_toks;
  1640.     untie %new_seen;
  1641.     $self->_unlink_file($tmptoksdbname);
  1642.     $self->_unlink_file($tmpseendbname);
  1643.     $self->untie_db();
  1644.     return 0;
  1645.   }
  1646.  
  1647.   unless ($db_version == 2 || $db_version == 3) {
  1648.     warn("bayes: database version $db_version is unsupported, must be version 2 or 3");
  1649.     untie %new_toks;
  1650.     untie %new_seen;
  1651.     $self->_unlink_file($tmptoksdbname);
  1652.     $self->_unlink_file($tmpseendbname);
  1653.     $self->untie_db();
  1654.     return 0;
  1655.   }
  1656.  
  1657.   while (my $line = <DUMPFILE>) {
  1658.     chomp($line);
  1659.     $line_count++;
  1660.  
  1661.     if ($line_count % 1000 == 0) {
  1662.       print STDERR "." if ($showdots);
  1663.     }
  1664.  
  1665.     if ($line =~ /^v\s+/) { # variable line
  1666.       my @parsed_line = split(/\s+/, $line, 3);
  1667.       my $value = $parsed_line[1] + 0;
  1668.       if ($parsed_line[2] eq 'num_spam') {
  1669.     $num_spam = $value;
  1670.       }
  1671.       elsif ($parsed_line[2] eq 'num_nonspam') {
  1672.     $num_ham = $value;
  1673.       }
  1674.       else {
  1675.     dbg("bayes: restore_database: skipping unknown line: $line");
  1676.       }
  1677.     }
  1678.     elsif ($line =~ /^t\s+/) { # token line
  1679.       my @parsed_line = split(/\s+/, $line, 5);
  1680.       my $spam_count = $parsed_line[1] + 0;
  1681.       my $ham_count = $parsed_line[2] + 0;
  1682.       my $atime = $parsed_line[3] + 0;
  1683.       my $token = $parsed_line[4];
  1684.  
  1685.       my $token_warn_p = 0;
  1686.       my @warnings;
  1687.  
  1688.       if ($spam_count < 0) {
  1689.     $spam_count = 0;
  1690.     push(@warnings, 'spam count < 0, resetting');
  1691.     $token_warn_p = 1;
  1692.       }
  1693.       if ($ham_count < 0) {
  1694.     $ham_count = 0;
  1695.     push(@warnings, 'ham count < 0, resetting');
  1696.     $token_warn_p = 1;
  1697.       }
  1698.  
  1699.       if ($spam_count == 0 && $ham_count == 0) {
  1700.     dbg("bayes: token has zero spam and ham count, skipping");
  1701.     next;
  1702.       }
  1703.  
  1704.       if ($atime > time()) {
  1705.     $atime = time();
  1706.     push(@warnings, 'atime > current time, resetting');
  1707.     $token_warn_p = 1;
  1708.       }
  1709.  
  1710.       if ($token_warn_p) {
  1711.     dbg("bayes: token ($token) has the following warnings:\n".join("\n",@warnings));
  1712.       }
  1713.  
  1714.       # database versions < 3 did not encode their token values
  1715.       if ($db_version < 3) {
  1716.     $token = substr(sha1($token), -5);
  1717.       }
  1718.       else {
  1719.     # turn unpacked binary token back into binary value
  1720.     $token = pack("H*",$token);
  1721.       }
  1722.  
  1723.       $new_toks{$token} = $self->tok_pack($spam_count, $ham_count, $atime);
  1724.       if ($atime < $oldest_token_age) {
  1725.     $oldest_token_age = $atime;
  1726.       }
  1727.       if ($atime > $newest_token_age) {
  1728.     $newest_token_age = $atime;
  1729.       }
  1730.       $token_count++;
  1731.     }
  1732.     elsif ($line =~ /^s\s+/) { # seen line
  1733.       my @parsed_line = split(/\s+/, $line, 3);
  1734.       my $flag = $parsed_line[1];
  1735.       my $msgid = $parsed_line[2];
  1736.  
  1737.       unless ($flag eq 'h' || $flag eq 's') {
  1738.     dbg("bayes: unknown seen flag ($flag) for line: $line, skipping");
  1739.     next;
  1740.       }
  1741.  
  1742.       unless ($msgid) {
  1743.     dbg("bayes: blank msgid for line: $line, skipping");
  1744.     next;
  1745.       }
  1746.  
  1747.       $new_seen{$msgid} = $flag;
  1748.     }
  1749.     else {
  1750.       dbg("bayes: skipping unknown line: $line");
  1751.       next;
  1752.     }
  1753.   }
  1754.   close(DUMPFILE);
  1755.  
  1756.   print STDERR "\n" if ($showdots);
  1757.  
  1758.   unless (defined($num_spam)) {
  1759.     dbg("bayes: unable to find num spam, please check file");
  1760.     $error_p = 1;
  1761.   }
  1762.  
  1763.   unless (defined($num_ham)) {
  1764.     dbg("bayes: unable to find num ham, please check file");
  1765.     $error_p = 1;
  1766.   }
  1767.  
  1768.   if ($error_p) {
  1769.     dbg("bayes: error(s) while attempting to load $filename, correct and re-run");
  1770.  
  1771.     untie %new_toks;
  1772.     untie %new_seen;
  1773.     $self->_unlink_file($tmptoksdbname);
  1774.     $self->_unlink_file($tmpseendbname);
  1775.     $self->untie_db();
  1776.     return 0;
  1777.   }
  1778.  
  1779.   # set the calculated magic tokens
  1780.   $new_toks{$DB_VERSION_MAGIC_TOKEN} = $self->DB_VERSION();
  1781.   $new_toks{$NTOKENS_MAGIC_TOKEN} = $token_count;
  1782.   $new_toks{$NSPAM_MAGIC_TOKEN} = $num_spam;
  1783.   $new_toks{$NHAM_MAGIC_TOKEN} = $num_ham;
  1784.   $new_toks{$NEWEST_TOKEN_AGE_MAGIC_TOKEN} = $newest_token_age;
  1785.   $new_toks{$OLDEST_TOKEN_AGE_MAGIC_TOKEN} = $oldest_token_age;
  1786.  
  1787.   # go ahead and zero out these, chances are good that they are bogus anyway.
  1788.   $new_toks{$LAST_EXPIRE_MAGIC_TOKEN} = 0;
  1789.   $new_toks{$LAST_JOURNAL_SYNC_MAGIC_TOKEN} = 0;
  1790.   $new_toks{$LAST_ATIME_DELTA_MAGIC_TOKEN} = 0;
  1791.   $new_toks{$LAST_EXPIRE_REDUCE_MAGIC_TOKEN} = 0;
  1792.  
  1793.   local $SIG{'INT'} = 'IGNORE';
  1794.   local $SIG{'TERM'} = 'IGNORE';
  1795.   local $SIG{'HUP'} = 'IGNORE' if (!Mail::SpamAssassin::Util::am_running_on_windows());
  1796.  
  1797.   untie %new_toks;
  1798.   untie %new_seen;
  1799.   $self->untie_db();
  1800.  
  1801.   # Here is where something can go horribly wrong and screw up the bayes
  1802.   # database files.  If we are able to copy one and not the other then it
  1803.   # will leave the database in an inconsistent state.  Since this is an
  1804.   # edge case, and they're trying to replace the DB anyway we should be ok.
  1805.   unless ($self->_rename_file($tmptoksdbname, $toksdbname)) {
  1806.     dbg("bayes: error while renaming $tmptoksdbname to $toksdbname: $!");
  1807.     return 0;
  1808.   }
  1809.   unless ($self->_rename_file($tmpseendbname, $seendbname)) {
  1810.     dbg("bayes: error while renaming $tmpseendbname to $seendbname: $!");
  1811.     dbg("bayes: database now in inconsistent state");
  1812.     return 0;
  1813.   }
  1814.  
  1815.   dbg("bayes: parsed $line_count lines");
  1816.   dbg("bayes: created database with $token_count tokens based on $num_spam spam messages and $num_ham ham messages");
  1817.  
  1818.   return 1;
  1819. }
  1820.  
  1821. ###########################################################################
  1822.  
  1823. # token marshalling format for db_toks.
  1824.  
  1825. # Since we may have many entries with few hits, especially thousands of hapaxes
  1826. # (1-occurrence entries), use a flexible entry format, instead of simply "2
  1827. # packed ints", to keep the memory and disk space usage down.  In my
  1828. # 18k-message test corpus, only 8.9% have >= 8 hits in either counter, so we
  1829. # can use a 1-byte representation for the other 91% of low-hitting entries
  1830. # and save masses of space.
  1831.  
  1832. # This looks like: XXSSSHHH (XX = format bits, SSS = 3 spam-count bits, HHH = 3
  1833. # ham-count bits).  If XX in the first byte is 11, it's packed as this 1-byte
  1834. # representation; otherwise, if XX in the first byte is 00, it's packed as
  1835. # "CLL", ie. 1 byte and 2 32-bit "longs" in perl pack format.
  1836.  
  1837. # Savings: roughly halves size of toks db, at the cost of a ~10% slowdown.
  1838.  
  1839. use constant FORMAT_FLAG    => 0xc0;    # 11000000
  1840. use constant ONE_BYTE_FORMAT    => 0xc0;    # 11000000
  1841. use constant TWO_LONGS_FORMAT    => 0x00;    # 00000000
  1842.  
  1843. use constant ONE_BYTE_SSS_BITS    => 0x38;    # 00111000
  1844. use constant ONE_BYTE_HHH_BITS    => 0x07;    # 00000111
  1845.  
  1846. sub tok_unpack {
  1847.   my ($self, $value) = @_;
  1848.   $value ||= 0;
  1849.  
  1850.   my ($packed, $atime);
  1851.   if ($self->{db_version} >= 1) {
  1852.     ($packed, $atime) = unpack("CV", $value);
  1853.   }
  1854.   elsif ($self->{db_version} == 0) {
  1855.     ($packed, $atime) = unpack("CS", $value);
  1856.   }
  1857.  
  1858.   if (($packed & FORMAT_FLAG) == ONE_BYTE_FORMAT) {
  1859.     return (($packed & ONE_BYTE_SSS_BITS) >> 3,
  1860.         $packed & ONE_BYTE_HHH_BITS,
  1861.         $atime || 0);
  1862.   }
  1863.   elsif (($packed & FORMAT_FLAG) == TWO_LONGS_FORMAT) {
  1864.     my ($packed, $ts, $th, $atime);
  1865.     if ($self->{db_version} >= 1) {
  1866.       ($packed, $ts, $th, $atime) = unpack("CVVV", $value);
  1867.     }
  1868.     elsif ($self->{db_version} == 0) {
  1869.       ($packed, $ts, $th, $atime) = unpack("CLLS", $value);
  1870.     }
  1871.     return ($ts || 0, $th || 0, $atime || 0);
  1872.   }
  1873.   # other formats would go here...
  1874.   else {
  1875.     warn "bayes: unknown packing format for bayes db, please re-learn: $packed";
  1876.     return (0, 0, 0);
  1877.   }
  1878. }
  1879.  
  1880. sub tok_pack {
  1881.   my ($self, $ts, $th, $atime) = @_;
  1882.   $ts ||= 0; $th ||= 0; $atime ||= 0;
  1883.   if ($ts < 8 && $th < 8) {
  1884.     return pack ("CV", ONE_BYTE_FORMAT | ($ts << 3) | $th, $atime);
  1885.   } else {
  1886.     return pack ("CVVV", TWO_LONGS_FORMAT, $ts, $th, $atime);
  1887.   }
  1888. }
  1889.  
  1890. ###########################################################################
  1891.  
  1892. sub db_readable {
  1893.   my ($self) = @_;
  1894.   return $self->{already_tied};
  1895. }
  1896.  
  1897. sub db_writable {
  1898.   my ($self) = @_;
  1899.   return $self->{already_tied} && $self->{is_locked};
  1900. }
  1901.  
  1902. ###########################################################################
  1903.  
  1904. sub _unlink_file {
  1905.   my ($self, $filename) = @_;
  1906.  
  1907.   unlink $filename;
  1908. }
  1909.  
  1910. sub _rename_file {
  1911.   my ($self, $sourcefilename, $targetfilename) = @_;
  1912.  
  1913.   return 0 unless (rename($sourcefilename, $targetfilename));
  1914.  
  1915.   return 1;
  1916. }
  1917.  
  1918. sub sa_die { Mail::SpamAssassin::sa_die(@_); }
  1919.  
  1920. 1;
  1921.