cgit.sxemacs.org Git - gnus/blob - lisp/spam.el

   1 ;; TODO: spam scores, detection of spam in newsgroups, cross-server splitting, remote processing, training through files
   2
   3 ;;; spam.el --- Identifying spam
   4 ;; Copyright (C) 2002, 2003 Free Software Foundation, Inc.
   5
   6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   7 ;; Keywords: network
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Commentary:
  27
  28 ;;; This module addresses a few aspects of spam control under Gnus.  Page
  29 ;;; breaks are used for grouping declarations and documentation relating to
  30 ;;; each particular aspect.
  31
  32 ;;; The integration with Gnus is not yet complete.  See various `FIXME'
  33 ;;; comments, below, for supplementary explanations or discussions.
  34
  35 ;;; Several TODO items are marked as such
  36
  37 ;;; Code:
  38
  39 (eval-when-compile (require 'cl))
  40
  41 (require 'gnus-sum)
  42
  43 (require 'gnus-uu)                      ; because of key prefix issues
  44 ;;; for the definitions of group content classification and spam processors
  45 (require 'gnus)
  46 (require 'message)              ;for the message-fetch-field functions
  47
  48 ;; for nnimap-split-download-body-default
  49 (eval-when-compile (require 'nnimap))
  50
  51 ;; autoload executable-find
  52 (eval-and-compile
  53   ;; executable-find is not autoloaded in Emacs 20
  54   (autoload 'executable-find "executable"))
  55
  56 ;; autoload query-dig
  57 (eval-and-compile
  58   (autoload 'query-dig "dig"))
  59
  60 ;; autoload spam-report
  61 (eval-and-compile
  62   (autoload 'spam-report-gmane "spam-report"))
  63
  64 ;; autoload gnus-registry
  65 (eval-and-compile
  66   (autoload 'gnus-registry-store-extra-entry "gnus-registry")
  67   (autoload 'gnus-registry-fetch-extra "gnus-registry"))
  68
  69 ;; autoload query-dns
  70 (eval-and-compile
  71   (autoload 'query-dns "dns"))
  72
  73 ;;; Main parameters.
  74
  75 (defgroup spam nil
  76   "Spam configuration.")
  77
  78 (defcustom spam-directory "~/News/spam/"
  79   "Directory for spam whitelists and blacklists."
  80   :type 'directory
  81   :group 'spam)
  82
  83 (defcustom spam-move-spam-nonspam-groups-only t
  84   "Whether spam should be moved in non-spam groups only.
  85 When t, only ham and unclassified groups will have their spam moved
  86 to the spam-process-destination.  When nil, spam will also be moved from
  87 spam groups."
  88   :type 'boolean
  89   :group 'spam)
  90
  91 (defcustom spam-process-ham-in-nonham-groups nil
  92   "Whether ham should be processed in non-ham groups."
  93   :type 'boolean
  94   :group 'spam)
  95
  96 (defcustom spam-log-to-registry nil
  97   "Whether spam/ham processing should be logged in the registry."
  98   :type 'boolean
  99   :group 'spam)
 100
 101 (defcustom spam-process-ham-in-spam-groups nil
 102   "Whether ham should be processed in spam groups."
 103   :type 'boolean
 104   :group 'spam)
 105
 106 (defcustom spam-mark-only-unseen-as-spam t
 107   "Whether only unseen articles should be marked as spam in spam
 108 groups.  When nil, all unread articles in a spam group are marked as
 109 spam.  Set this if you want to leave an article unread in a spam group
 110 without losing it to the automatic spam-marking process."
 111   :type 'boolean
 112   :group 'spam)
 113
 114 (defcustom spam-mark-ham-unread-before-move-from-spam-group nil
 115   "Whether ham should be marked unread before it's moved out of a spam
 116 group according to ham-process-destination.  This variable is an
 117 official entry in the international Longest Variable Name
 118 Competition."
 119   :type 'boolean
 120   :group 'spam)
 121
 122 (defcustom spam-disable-spam-split-during-ham-respool nil
 123   "Whether spam-split should be ignored while resplitting ham in
 124 a process destination.  This is useful to prevent ham from ending
 125 up in the same spam group after the resplit.  Don't set this to t
 126 if you have spam-split as the last rule in your split
 127 configuration."
 128   :type 'boolean
 129   :group 'spam)
 130
 131 (defcustom spam-whitelist (expand-file-name "whitelist" spam-directory)
 132   "The location of the whitelist.
 133 The file format is one regular expression per line.
 134 The regular expression is matched against the address."
 135   :type 'file
 136   :group 'spam)
 137
 138 (defcustom spam-blacklist (expand-file-name "blacklist" spam-directory)
 139   "The location of the blacklist.
 140 The file format is one regular expression per line.
 141 The regular expression is matched against the address."
 142   :type 'file
 143   :group 'spam)
 144
 145 (defcustom spam-use-dig t
 146   "Whether query-dig should be used instead of query-dns."
 147   :type 'boolean
 148   :group 'spam)
 149
 150 (defcustom spam-use-blacklist nil
 151   "Whether the blacklist should be used by spam-split."
 152   :type 'boolean
 153   :group 'spam)
 154
 155 (defcustom spam-blacklist-ignored-regexes nil
 156   "Regular expressions that the blacklist should ignore."
 157   :type '(repeat (regexp :tag "Regular expression to ignore when blacklisting"))
 158   :group 'spam)
 159
 160 (defcustom spam-use-whitelist nil
 161   "Whether the whitelist should be used by spam-split."
 162   :type 'boolean
 163   :group 'spam)
 164
 165 (defcustom spam-use-whitelist-exclusive nil
 166   "Whether whitelist-exclusive should be used by spam-split.
 167 Exclusive whitelisting means that all messages from senders not in the whitelist
 168 are considered spam."
 169   :type 'boolean
 170   :group 'spam)
 171
 172 (defcustom spam-use-blackholes nil
 173   "Whether blackholes should be used by spam-split."
 174   :type 'boolean
 175   :group 'spam)
 176
 177 (defcustom spam-use-hashcash nil
 178   "Whether hashcash payments should be detected by spam-split."
 179   :type 'boolean
 180   :group 'spam)
 181
 182 (defcustom spam-use-regex-headers nil
 183   "Whether a header regular expression match should be used by spam-split.
 184 Also see the variables `spam-regex-headers-spam' and `spam-regex-headers-ham'."
 185   :type 'boolean
 186   :group 'spam)
 187
 188 (defcustom spam-use-regex-body nil
 189   "Whether a body regular expression match should be used by spam-split.
 190 Also see the variables `spam-regex-body-spam' and `spam-regex-body-ham'."
 191   :type 'boolean
 192   :group 'spam)
 193
 194 (defcustom spam-use-bogofilter-headers nil
 195   "Whether bogofilter headers should be used by spam-split.
 196 Enable this if you pre-process messages with Bogofilter BEFORE Gnus sees them."
 197   :type 'boolean
 198   :group 'spam)
 199
 200 (defcustom spam-use-bogofilter nil
 201   "Whether bogofilter should be invoked by spam-split.
 202 Enable this if you want Gnus to invoke Bogofilter on new messages."
 203   :type 'boolean
 204   :group 'spam)
 205
 206 (defcustom spam-use-BBDB nil
 207   "Whether BBDB should be used by spam-split."
 208   :type 'boolean
 209   :group 'spam)
 210
 211 (defcustom spam-use-BBDB-exclusive nil
 212   "Whether BBDB-exclusive should be used by spam-split.
 213 Exclusive BBDB means that all messages from senders not in the BBDB are
 214 considered spam."
 215   :type 'boolean
 216   :group 'spam)
 217
 218 (defcustom spam-use-ifile nil
 219   "Whether ifile should be used by spam-split."
 220   :type 'boolean
 221   :group 'spam)
 222
 223 (defcustom spam-use-stat nil
 224   "Whether spam-stat should be used by spam-split."
 225   :type 'boolean
 226   :group 'spam)
 227
 228 (defcustom spam-use-spamoracle nil
 229   "Whether spamoracle should be used by spam-split."
 230   :type 'boolean
 231   :group 'spam)
 232
 233 (defcustom spam-install-hooks (or
 234                                spam-use-dig
 235                                spam-use-blacklist
 236                                spam-use-whitelist
 237                                spam-use-whitelist-exclusive
 238                                spam-use-blackholes
 239                                spam-use-hashcash
 240                                spam-use-regex-headers
 241                                spam-use-regex-body
 242                                spam-use-bogofilter-headers
 243                                spam-use-bogofilter
 244                                spam-use-BBDB
 245                                spam-use-BBDB-exclusive
 246                                spam-use-ifile
 247                                spam-use-stat
 248                                spam-use-spamoracle)
 249   "Whether the spam hooks should be installed, default to t if one of
 250 the spam-use-* variables is set."
 251   :group 'spam
 252   :type 'boolean)
 253
 254 (defcustom spam-split-group "spam"
 255   "Group name where incoming spam should be put by spam-split."
 256   :type 'string
 257   :group 'spam)
 258
 259 ;;; TODO: deprecate this variable, it's confusing since it's a list of strings,
 260 ;;; not regular expressions
 261 (defcustom spam-junk-mailgroups (cons
 262                                  spam-split-group
 263                                  '("mail.junk" "poste.pourriel"))
 264   "Mailgroups with spam contents.
 265 All unmarked article in such group receive the spam mark on group entry."
 266   :type '(repeat (string :tag "Group"))
 267   :group 'spam)
 268
 269 (defcustom spam-blackhole-servers '("bl.spamcop.net" "relays.ordb.org"
 270                                     "dev.null.dk" "relays.visi.com")
 271   "List of blackhole servers."
 272   :type '(repeat (string :tag "Server"))
 273   :group 'spam)
 274
 275 (defcustom spam-blackhole-good-server-regex nil
 276   "String matching IP addresses that should not be checked in the blackholes"
 277   :type '(radio (const nil)
 278                 (regexp :format "%t: %v\n" :size 0))
 279   :group 'spam)
 280
 281 (defcustom spam-face 'gnus-splash-face
 282   "Face for spam-marked articles"
 283   :type 'face
 284   :group 'spam)
 285
 286 (defcustom spam-regex-headers-spam '("^X-Spam-Flag: YES")
 287   "Regular expression for positive header spam matches"
 288   :type '(repeat (regexp :tag "Regular expression to match spam header"))
 289   :group 'spam)
 290
 291 (defcustom spam-regex-headers-ham '("^X-Spam-Flag: NO")
 292   "Regular expression for positive header ham matches"
 293   :type '(repeat (regexp :tag "Regular expression to match ham header"))
 294   :group 'spam)
 295
 296 (defcustom spam-regex-body-spam '()
 297   "Regular expression for positive body spam matches"
 298   :type '(repeat (regexp :tag "Regular expression to match spam body"))
 299   :group 'spam)
 300
 301 (defcustom spam-regex-body-ham '()
 302   "Regular expression for positive body ham matches"
 303   :type '(repeat (regexp :tag "Regular expression to match ham body"))
 304   :group 'spam)
 305
 306 (defgroup spam-ifile nil
 307   "Spam ifile configuration."
 308   :group 'spam)
 309
 310 (defcustom spam-ifile-path (executable-find "ifile")
 311   "File path of the ifile executable program."
 312   :type '(choice (file :tag "Location of ifile")
 313                  (const :tag "ifile is not installed"))
 314   :group 'spam-ifile)
 315
 316 (defcustom spam-ifile-database-path nil
 317   "File path of the ifile database."
 318   :type '(choice (file :tag "Location of the ifile database")
 319                  (const :tag "Use the default"))
 320   :group 'spam-ifile)
 321
 322 (defcustom spam-ifile-spam-category "spam"
 323   "Name of the spam ifile category."
 324   :type 'string
 325   :group 'spam-ifile)
 326
 327 (defcustom spam-ifile-ham-category nil
 328   "Name of the ham ifile category.  If nil, the current group name will
 329 be used."
 330   :type '(choice (string :tag "Use a fixed category")
 331                  (const :tag "Use the current group name"))
 332   :group 'spam-ifile)
 333
 334 (defcustom spam-ifile-all-categories nil
 335   "Whether the ifile check will return all categories, or just spam.
 336 Set this to t if you want to use the spam-split invocation of ifile as
 337 your main source of newsgroup names."
 338   :type 'boolean
 339   :group 'spam-ifile)
 340
 341 (defgroup spam-bogofilter nil
 342   "Spam bogofilter configuration."
 343   :group 'spam)
 344
 345 (defcustom spam-bogofilter-path (executable-find "bogofilter")
 346   "File path of the Bogofilter executable program."
 347   :type '(choice (file :tag "Location of bogofilter")
 348                  (const :tag "Bogofilter is not installed"))
 349   :group 'spam-bogofilter)
 350
 351 (defcustom spam-bogofilter-header "X-Bogosity"
 352   "The header that Bogofilter inserts in messages."
 353   :type 'string
 354   :group 'spam-bogofilter)
 355
 356 (defcustom spam-bogofilter-spam-switch "-s"
 357   "The switch that Bogofilter uses to register spam messages."
 358   :type 'string
 359   :group 'spam-bogofilter)
 360
 361 (defcustom spam-bogofilter-ham-switch "-n"
 362   "The switch that Bogofilter uses to register ham messages."
 363   :type 'string
 364   :group 'spam-bogofilter)
 365
 366 (defcustom spam-bogofilter-spam-strong-switch "-S"
 367   "The switch that Bogofilter uses to unregister ham messages."
 368   :type 'string
 369   :group 'spam-bogofilter)
 370
 371 (defcustom spam-bogofilter-ham-strong-switch "-N"
 372   "The switch that Bogofilter uses to unregister spam messages."
 373   :type 'string
 374   :group 'spam-bogofilter)
 375
 376 (defcustom spam-bogofilter-bogosity-positive-spam-header "^\\(Yes\\|Spam\\)"
 377   "The regex on `spam-bogofilter-header' for positive spam identification."
 378   :type 'regexp
 379   :group 'spam-bogofilter)
 380
 381 (defcustom spam-bogofilter-database-directory nil
 382   "Directory path of the Bogofilter databases."
 383   :type '(choice (directory
 384                   :tag "Location of the Bogofilter database directory")
 385                  (const :tag "Use the default"))
 386   :group 'spam-bogofilter)
 387
 388 (defgroup spam-spamoracle nil
 389   "Spam spamoracle configuration."
 390   :group 'spam)
 391
 392 (defcustom spam-spamoracle-database nil
 393   "Location of spamoracle database file. When nil, use the default
 394 spamoracle database."
 395   :type '(choice (directory :tag "Location of spamoracle database file.")
 396                  (const :tag "Use the default"))
 397   :group 'spam-spamoracle)
 398
 399 (defcustom spam-spamoracle-binary (executable-find "spamoracle")
 400   "Location of the spamoracle binary."
 401   :type '(choice (directory :tag "Location of the spamoracle binary")
 402                  (const :tag "Use the default"))
 403   :group 'spam-spamoracle)
 404
 405 ;;; Key bindings for spam control.
 406
 407 (gnus-define-keys gnus-summary-mode-map
 408   "St" spam-bogofilter-score
 409   "Sx" gnus-summary-mark-as-spam
 410   "Mst" spam-bogofilter-score
 411   "Msx" gnus-summary-mark-as-spam
 412   "\M-d" gnus-summary-mark-as-spam)
 413
 414 (defvar spam-old-ham-articles nil
 415   "List of old ham articles, generated when a group is entered.")
 416
 417 (defvar spam-old-spam-articles nil
 418   "List of old spam articles, generated when a group is entered.")
 419
 420
 421 ;; convenience functions
 422 (defun spam-xor (a b) ; logical exclusive or
 423   (and (or a b) (not (and a b))))
 424
 425 (defun spam-group-ham-mark-p (group mark &optional spam)
 426   (when (stringp group)
 427     (let* ((marks (spam-group-ham-marks group spam))
 428            (marks (if (symbolp mark)
 429                       marks
 430                     (mapcar 'symbol-value marks))))
 431       (memq mark marks))))
 432
 433 (defun spam-group-spam-mark-p (group mark)
 434   (spam-group-ham-mark-p group mark t))
 435
 436 (defun spam-group-ham-marks (group &optional spam)
 437   (when (stringp group)
 438     (let* ((marks (if spam
 439                       (gnus-parameter-spam-marks group)
 440                     (gnus-parameter-ham-marks group)))
 441            (marks (car marks))
 442            (marks (if (listp (car marks)) (car marks) marks)))
 443       marks)))
 444
 445 (defun spam-group-spam-marks (group)
 446   (spam-group-ham-marks group t))
 447
 448 (defun spam-group-spam-contents-p (group)
 449   (if (stringp group)
 450       (or (member group spam-junk-mailgroups)
 451           (memq 'gnus-group-spam-classification-spam
 452                 (gnus-parameter-spam-contents group)))
 453     nil))
 454
 455 (defun spam-group-ham-contents-p (group)
 456   (if (stringp group)
 457       (memq 'gnus-group-spam-classification-ham
 458             (gnus-parameter-spam-contents group))
 459     nil))
 460
 461 (defvar spam-list-of-processors
 462   '((gnus-group-spam-exit-processor-report-gmane spam spam-use-gmane)
 463     (gnus-group-spam-exit-processor-bogofilter   spam spam-use-bogofilter)
 464     (gnus-group-spam-exit-processor-blacklist    spam spam-use-blacklist)
 465     (gnus-group-spam-exit-processor-ifile        spam spam-use-ifile)
 466     (gnus-group-spam-exit-processor-stat         spam spam-use-stat)
 467     (gnus-group-spam-exit-processor-spamoracle   spam spam-use-spamoracle)
 468     (gnus-group-ham-exit-processor-ifile         ham spam-use-ifile)
 469     (gnus-group-ham-exit-processor-bogofilter    ham spam-use-bogofilter)
 470     (gnus-group-ham-exit-processor-stat          ham spam-use-stat)
 471     (gnus-group-ham-exit-processor-whitelist     ham spam-use-whitelist)
 472     (gnus-group-ham-exit-processor-BBDB          ham spam-use-BBDB)
 473     (gnus-group-ham-exit-processor-copy          ham spam-use-ham-copy)
 474     (gnus-group-ham-exit-processor-spamoracle    ham spam-use-spamoracle))
 475   "The spam-list-of-processors list contains pairs associating a
 476 ham/spam exit processor variable with a classification and a
 477 spam-use-* variable.")
 478
 479 (defun spam-group-processor-p (group processor)
 480   (if (and (stringp group)
 481            (symbolp processor))
 482       (or (member processor (nth 0 (gnus-parameter-spam-process group)))
 483           (spam-group-processor-multiple-p
 484            group
 485            (cdr-safe (assoc processor spam-list-of-processors))))
 486     nil))
 487
 488 (defun spam-group-processor-multiple-p (group processor-info)
 489   (let* ((classification (nth 0 processor-info))
 490          (check (nth 1 processor-info))
 491          (parameters (nth 0 (gnus-parameter-spam-process group)))
 492          found)
 493     (dolist (parameter parameters)
 494       (when (and (null found)
 495                  (listp parameter)
 496                  (eq classification (nth 0 parameter))
 497                  (eq check (nth 1 parameter)))
 498         (setq found t)))
 499     found))
 500
 501 (defun spam-group-spam-processor-report-gmane-p (group)
 502   (spam-group-processor-p group 'gnus-group-spam-exit-processor-report-gmane))
 503
 504 (defun spam-group-spam-processor-bogofilter-p (group)
 505   (spam-group-processor-p group 'gnus-group-spam-exit-processor-bogofilter))
 506
 507 (defun spam-group-spam-processor-blacklist-p (group)
 508   (spam-group-processor-p group 'gnus-group-spam-exit-processor-blacklist))
 509
 510 (defun spam-group-spam-processor-ifile-p (group)
 511   (spam-group-processor-p group 'gnus-group-spam-exit-processor-ifile))
 512
 513 (defun spam-group-ham-processor-ifile-p (group)
 514   (spam-group-processor-p group 'gnus-group-ham-exit-processor-ifile))
 515
 516 (defun spam-group-spam-processor-spamoracle-p (group)
 517   (spam-group-processor-p group 'gnus-group-spam-exit-processor-spamoracle))
 518
 519 (defun spam-group-ham-processor-bogofilter-p (group)
 520   (spam-group-processor-p group 'gnus-group-ham-exit-processor-bogofilter))
 521
 522 (defun spam-group-spam-processor-stat-p (group)
 523   (spam-group-processor-p group 'gnus-group-spam-exit-processor-stat))
 524
 525 (defun spam-group-ham-processor-stat-p (group)
 526   (spam-group-processor-p group 'gnus-group-ham-exit-processor-stat))
 527
 528 (defun spam-group-ham-processor-whitelist-p (group)
 529   (spam-group-processor-p group 'gnus-group-ham-exit-processor-whitelist))
 530
 531 (defun spam-group-ham-processor-BBDB-p (group)
 532   (spam-group-processor-p group 'gnus-group-ham-exit-processor-BBDB))
 533
 534 (defun spam-group-ham-processor-copy-p (group)
 535   (spam-group-processor-p group 'gnus-group-ham-exit-processor-copy))
 536
 537 (defun spam-group-ham-processor-spamoracle-p (group)
 538   (spam-group-processor-p group 'gnus-group-ham-exit-processor-spamoracle))
 539
 540 ;;; Summary entry and exit processing.
 541
 542 (defun spam-summary-prepare ()
 543   (setq spam-old-ham-articles
 544         (spam-list-articles gnus-newsgroup-articles 'ham))
 545   (setq spam-old-spam-articles
 546         (spam-list-articles gnus-newsgroup-articles 'spam))
 547   (spam-mark-junk-as-spam-routine))
 548
 549 ;; The spam processors are invoked for any group, spam or ham or neither
 550 (defun spam-summary-prepare-exit ()
 551   (unless gnus-group-is-exiting-without-update-p
 552     (gnus-message 6 "Exiting summary buffer and applying spam rules")
 553
 554     ;; first of all, unregister any articles that are no longer ham or spam
 555     ;; we have to iterate over the processors, or else we'll be too slow
 556     (dolist (classification '(spam ham))
 557       (let* ((old-articles (if (eq classification 'spam)
 558                                spam-old-spam-articles
 559                              spam-old-ham-articles))
 560              (new-articles (spam-list-articles
 561                             gnus-newsgroup-articles
 562                             classification))
 563              (changed-articles (gnus-set-difference old-articles new-articles)))
 564         ;; now that we have the changed articles, we go through the processors
 565         (dolist (processor-param spam-list-of-processors)
 566           (let ((processor (nth 0 processor-param))
 567                 (processor-classification (nth 1 processor-param))
 568                 (check (nth 2 processor-param))
 569                 unregister-list)
 570             (dolist (article changed-articles)
 571               (let ((id (spam-fetch-field-message-id-fast article)))
 572                 (when (spam-log-unregistration-needed-p
 573                        id 'process classification check)
 574                   (push article unregister-list))))
 575             ;; call spam-register-routine with specific articles to unregister,
 576             ;; when there are articles to unregister and the check is enabled
 577             (when (and unregister-list (symbol-value check))
 578               (spam-register-routine classification check t unregister-list))))))
 579
 580     ;; find all the spam processors applicable to this group
 581     (dolist (processor-param spam-list-of-processors)
 582       (let ((processor (nth 0 processor-param))
 583             (classification (nth 1 processor-param))
 584             (check (nth 2 processor-param)))
 585         (when (and (eq 'spam classification)
 586                    (spam-group-processor-p gnus-newsgroup-name processor))
 587           (spam-register-routine classification check))))
 588
 589     (if spam-move-spam-nonspam-groups-only
 590         (when (not (spam-group-spam-contents-p gnus-newsgroup-name))
 591           (spam-mark-spam-as-expired-and-move-routine
 592            (gnus-parameter-spam-process-destination gnus-newsgroup-name)))
 593       (gnus-message 5 "Marking spam as expired and moving it to %s"
 594                     gnus-newsgroup-name)
 595       (spam-mark-spam-as-expired-and-move-routine
 596        (gnus-parameter-spam-process-destination gnus-newsgroup-name)))
 597
 598     ;; now we redo spam-mark-spam-as-expired-and-move-routine to only
 599     ;; expire spam, in case the above did not expire them
 600     (gnus-message 5 "Marking spam as expired without moving it")
 601     (spam-mark-spam-as-expired-and-move-routine nil)
 602
 603     (when (or (spam-group-ham-contents-p gnus-newsgroup-name)
 604               (and (spam-group-spam-contents-p gnus-newsgroup-name)
 605                    spam-process-ham-in-spam-groups)
 606               spam-process-ham-in-nonham-groups)
 607       ;; find all the ham processors applicable to this group
 608       (dolist (processor-param spam-list-of-processors)
 609         (let ((processor (nth 0 processor-param))
 610               (classification (nth 1 processor-param))
 611               (check (nth 2 processor-param)))
 612           (when (and (eq 'ham classification)
 613                      (spam-group-processor-p gnus-newsgroup-name processor))
 614             (spam-register-routine classification check)))))
 615
 616     (when (spam-group-ham-processor-copy-p gnus-newsgroup-name)
 617       (gnus-message 5 "Copying ham")
 618       (spam-ham-copy-routine
 619        (gnus-parameter-ham-process-destination gnus-newsgroup-name)))
 620
 621     ;; now move all ham articles out of spam groups
 622     (when (spam-group-spam-contents-p gnus-newsgroup-name)
 623       (gnus-message 5 "Moving ham messages from spam group")
 624       (spam-ham-move-routine
 625        (gnus-parameter-ham-process-destination gnus-newsgroup-name))))
 626
 627   (setq spam-old-ham-articles nil)
 628   (setq spam-old-spam-articles nil))
 629
 630 (defun spam-mark-junk-as-spam-routine ()
 631   ;; check the global list of group names spam-junk-mailgroups and the
 632   ;; group parameters
 633   (when (spam-group-spam-contents-p gnus-newsgroup-name)
 634     (gnus-message 5 "Marking %s articles as spam"
 635                   (if spam-mark-only-unseen-as-spam
 636                       "unseen"
 637                     "unread"))
 638     (let ((articles (if spam-mark-only-unseen-as-spam
 639                         gnus-newsgroup-unseen
 640                       gnus-newsgroup-unreads)))
 641       (dolist (article articles)
 642         (gnus-summary-mark-article article gnus-spam-mark)))))
 643
 644 (defun spam-mark-spam-as-expired-and-move-routine (&rest groups)
 645   (if (and (car-safe groups) (listp (car-safe groups)))
 646       (apply 'spam-mark-spam-as-expired-and-move-routine (car groups))
 647     (gnus-summary-kill-process-mark)
 648     (let ((articles gnus-newsgroup-articles)
 649           (backend-supports-deletions
 650            (gnus-check-backend-function
 651             'request-move-article gnus-newsgroup-name))
 652           article tomove deletep)
 653       (dolist (article articles)
 654         (when (eq (gnus-summary-article-mark article) gnus-spam-mark)
 655           (gnus-summary-mark-article article gnus-expirable-mark)
 656           (push article tomove)))
 657
 658       ;; now do the actual copies
 659       (dolist (group groups)
 660         (when (and tomove
 661                    (stringp group))
 662           (dolist (article tomove)
 663             (gnus-summary-set-process-mark article))
 664           (when tomove
 665             (if (or (not backend-supports-deletions)
 666                     (> (length groups) 1))
 667                 (progn
 668                   (gnus-summary-copy-article nil group)
 669                   (setq deletep t))
 670               (gnus-summary-move-article nil group)))))
 671
 672       ;; now delete the articles, if there was a copy done, and the
 673       ;; backend allows it
 674       (when (and deletep backend-supports-deletions)
 675         (dolist (article tomove)
 676           (gnus-summary-set-process-mark article))
 677         (when tomove
 678           (let ((gnus-novice-user nil)) ; don't ask me if I'm sure
 679             (gnus-summary-delete-article nil))))
 680
 681       (gnus-summary-yank-process-mark))))
 682
 683 (defun spam-ham-copy-or-move-routine (copy groups)
 684   (gnus-summary-kill-process-mark)
 685   (let ((articles gnus-newsgroup-articles)
 686         (backend-supports-deletions
 687          (gnus-check-backend-function
 688           'request-move-article gnus-newsgroup-name))
 689         (respool-method (gnus-find-method-for-group gnus-newsgroup-name))
 690         article mark todo deletep respool)
 691     (dolist (article articles)
 692       (when (spam-group-ham-mark-p gnus-newsgroup-name
 693                                    (gnus-summary-article-mark article))
 694         (push article todo)))
 695
 696     (when (member 'respool groups)
 697       (setq respool t)                  ; boolean for later
 698       (setq groups '("fake"))) ; when respooling, groups are dynamic so fake it
 699
 700     ;; now do the actual move
 701     (dolist (group groups)
 702       (when (and todo (stringp group))
 703         (dolist (article todo)
 704           (when spam-mark-ham-unread-before-move-from-spam-group
 705             (gnus-summary-mark-article article gnus-unread-mark))
 706           (gnus-summary-set-process-mark article))
 707
 708         (if respool                        ; respooling is with a "fake" group
 709             (let ((spam-split-disabled
 710                    (or spam-split-disabled
 711                        spam-disable-spam-split-during-ham-respool)))
 712               (gnus-summary-respool-article nil respool-method))
 713           (if (or (not backend-supports-deletions) ; else, we are not respooling
 714                   (> (length groups) 1))
 715               (progn                ; if copying, copy and set deletep
 716                 (gnus-summary-copy-article nil group)
 717                 (setq deletep t))
 718             (gnus-summary-move-article nil group))))) ; else move articles
 719
 720     ;; now delete the articles, unless a) copy is t, and there was a copy done
 721     ;;                                 b) a move was done to a single group
 722     ;;                                 c) backend-supports-deletions is nil
 723     (unless copy
 724       (when (and deletep backend-supports-deletions)
 725         (dolist (article todo)
 726           (gnus-summary-set-process-mark article))
 727         (when todo
 728           (let ((gnus-novice-user nil)) ; don't ask me if I'm sure
 729             (gnus-summary-delete-article nil))))))
 730
 731   (gnus-summary-yank-process-mark))
 732
 733 (defun spam-ham-copy-routine (&rest groups)
 734   (if (and (car-safe groups) (listp (car-safe groups)))
 735       (apply 'spam-ham-copy-routine (car groups))
 736     (spam-ham-copy-or-move-routine t groups)))
 737
 738 (defun spam-ham-move-routine (&rest groups)
 739   (if (and (car-safe groups) (listp (car-safe groups)))
 740       (apply 'spam-ham-move-routine (car groups))
 741     (spam-ham-copy-or-move-routine nil groups)))
 742
 743 (eval-and-compile
 744   (defalias 'spam-point-at-eol (if (fboundp 'point-at-eol)
 745                                    'point-at-eol
 746                                  'line-end-position)))
 747
 748 (defun spam-get-article-as-string (article)
 749   (let ((article-buffer (spam-get-article-as-buffer article))
 750         article-string)
 751     (when article-buffer
 752       (save-window-excursion
 753         (set-buffer article-buffer)
 754         (setq article-string (buffer-string))))
 755     article-string))
 756
 757 (defun spam-get-article-as-buffer (article)
 758   (let ((article-buffer))
 759     (when (numberp article)
 760       (save-window-excursion
 761         (gnus-summary-goto-subject article)
 762         (gnus-summary-show-article t)
 763         (setq article-buffer (get-buffer gnus-article-buffer))))
 764     article-buffer))
 765
 766 ;; disabled for now
 767 ;; (defun spam-get-article-as-filename (article)
 768 ;;   (let ((article-filename))
 769 ;;     (when (numberp article)
 770 ;;       (nnml-possibly-change-directory
 771 ;;        (gnus-group-real-name gnus-newsgroup-name))
 772 ;;       (setq article-filename (expand-file-name
 773 ;;                              (int-to-string article) nnml-current-directory)))
 774 ;;     (if (file-exists-p article-filename)
 775 ;;      article-filename
 776 ;;       nil)))
 777
 778 (defun spam-fetch-field-from-fast (article)
 779   "Fetch the `from' field quickly, using the internal gnus-data-list function"
 780   (if (and (numberp article)
 781            (assoc article (gnus-data-list nil)))
 782       (mail-header-from
 783        (gnus-data-header (assoc article (gnus-data-list nil))))
 784     nil))
 785
 786 (defun spam-fetch-field-subject-fast (article)
 787   "Fetch the `subject' field quickly, using the internal
 788   gnus-data-list function"
 789   (if (and (numberp article)
 790            (assoc article (gnus-data-list nil)))
 791       (mail-header-subject
 792        (gnus-data-header (assoc article (gnus-data-list nil))))
 793     nil))
 794
 795 (defun spam-fetch-field-message-id-fast (article)
 796   "Fetch the `Message-ID' field quickly, using the internal
 797   gnus-data-list function"
 798   (if (and (numberp article)
 799            (assoc article (gnus-data-list nil)))
 800       (mail-header-message-id
 801        (gnus-data-header (assoc article (gnus-data-list nil))))
 802     nil))
 803
 804 \f
 805 ;;;; Spam determination.
 806
 807 (defvar spam-list-of-checks
 808   '((spam-use-blacklist          . spam-check-blacklist)
 809     (spam-use-regex-headers      . spam-check-regex-headers)
 810     (spam-use-regex-body         . spam-check-regex-body)
 811     (spam-use-whitelist          . spam-check-whitelist)
 812     (spam-use-BBDB               . spam-check-BBDB)
 813     (spam-use-ifile              . spam-check-ifile)
 814     (spam-use-spamoracle         . spam-check-spamoracle)
 815     (spam-use-stat               . spam-check-stat)
 816     (spam-use-blackholes         . spam-check-blackholes)
 817     (spam-use-hashcash           . spam-check-hashcash)
 818     (spam-use-bogofilter-headers . spam-check-bogofilter-headers)
 819     (spam-use-bogofilter         . spam-check-bogofilter))
 820   "The spam-list-of-checks list contains pairs associating a parameter
 821 variable with a spam checking function.  If the parameter variable is
 822 true, then the checking function is called, and its value decides what
 823 happens.  Each individual check may return nil, t, or a mailgroup
 824 name.  The value nil means that the check does not yield a decision,
 825 and so, that further checks are needed.  The value t means that the
 826 message is definitely not spam, and that further spam checks should be
 827 inhibited.  Otherwise, a mailgroup name is returned where the mail
 828 should go, and further checks are also inhibited.  The usual mailgroup
 829 name is the value of `spam-split-group', meaning that the message is
 830 definitely a spam.")
 831
 832 (defvar spam-list-of-statistical-checks
 833   '(spam-use-ifile
 834     spam-use-regex-body
 835     spam-use-stat
 836     spam-use-bogofilter
 837     spam-use-spamoracle)
 838   "The spam-list-of-statistical-checks list contains all the mail
 839 splitters that need to have the full message body available.")
 840
 841 (defvar spam-split-disabled nil
 842   "If non-nil, spam-split is disabled, and always returns nil.")
 843
 844 ;;;TODO: modify to invoke self with each check if invoked without specifics
 845 (defun spam-split (&rest specific-checks)
 846   "Split this message into the `spam' group if it is spam.
 847 This function can be used as an entry in `nnmail-split-fancy',
 848 for example like this: (: spam-split).  It can take checks as
 849 parameters.  A string as a parameter will set the
 850 spam-split-group to that string.
 851
 852 See the Info node `(gnus)Fancy Mail Splitting' for more details."
 853   (interactive)
 854   (unless spam-split-disabled
 855     (let ((spam-split-group-choice spam-split-group))
 856       (dolist (check specific-checks)
 857         (when (stringp check)
 858           (setq spam-split-group-choice check)
 859           (setq specific-checks (delq check specific-checks))))
 860
 861       (let ((spam-split-group spam-split-group-choice))
 862         (save-excursion
 863           (save-restriction
 864             (dolist (check spam-list-of-statistical-checks)
 865               (when (and (symbolp check) (symbol-value check))
 866                 (widen)
 867                 (gnus-message 8 "spam-split: widening the buffer (%s requires it)"
 868                               (symbol-name check))
 869                 (return)))
 870             ;;   (progn (widen) (debug (buffer-string)))
 871             (let ((list-of-checks spam-list-of-checks)
 872                   decision)
 873               (while (and list-of-checks (not decision))
 874                 (let ((pair (pop list-of-checks)))
 875                   (when (and (symbol-value (car pair))
 876                              (or (null specific-checks)
 877                                  (memq (car pair) specific-checks)))
 878                     (gnus-message 5 "spam-split: calling the %s function"
 879                                   (symbol-name (cdr pair)))
 880                     (setq decision (funcall (cdr pair))))))
 881               (if (eq decision t)
 882                   nil
 883                 decision))))))))
 884
 885 (defvar spam-registration-functions
 886   ;; first the ham register, second the spam register function
 887   ;; third the ham unregister, fourth the spam unregister function
 888   '((spam-use-blacklist  nil
 889                          spam-blacklist-register-routine
 890                          nil
 891                          spam-blacklist-unregister-routine)
 892     (spam-use-whitelist  spam-whitelist-register-routine
 893                          nil
 894                          spam-whitelist-unregister-routine
 895                          nil)
 896     (spam-use-BBDB       spam-BBDB-register-routine
 897                          nil
 898                          spam-BBDB-unregister-routine
 899                          nil)
 900     (spam-use-ifile      spam-ifile-register-ham-routine
 901                          spam-ifile-register-spam-routine
 902                          spam-ifile-unregister-ham-routine
 903                          spam-ifile-unregister-spam-routine)
 904     (spam-use-spamoracle spam-spamoracle-learn-ham
 905                          spam-spamoracle-learn-spam
 906                          spam-spamoracle-unlearn-ham
 907                          spam-spamoracle-unlearn-spam)
 908     (spam-use-stat       spam-stat-register-ham-routine
 909                          spam-stat-register-spam-routine
 910                          spam-stat-unregister-ham-routine
 911                          spam-stat-unregister-spam-routine)
 912     ;; note that spam-use-gmane is not a legitimate check
 913     (spam-use-gmane      nil
 914                          spam-report-gmane-register-routine
 915                          ;; does Gmane support unregistration?
 916                          nil
 917                          nil)
 918     (spam-use-bogofilter spam-bogofilter-register-ham-routine
 919                          spam-bogofilter-register-spam-routine
 920                          spam-bogofilter-unregister-ham-routine
 921                          spam-bogofilter-unregister-spam-routine))
 922   "The spam-registration-functions list contains pairs
 923 associating a parameter variable with the ham and spam
 924 registration functions, and the ham and spam unregistration
 925 functions")
 926
 927 (defun spam-classification-valid-p (classification)
 928   (or  (eq classification 'spam)
 929        (eq classification 'ham)))
 930
 931 (defun spam-process-type-valid-p (process-type)
 932   (or  (eq process-type 'incoming)
 933        (eq process-type 'process)))
 934
 935 (defun spam-registration-check-valid-p (check)
 936   (assoc check spam-registration-functions))
 937
 938 (defun spam-unregistration-check-valid-p (check)
 939   (assoc check spam-registration-functions))
 940
 941 (defun spam-registration-function (classification check)
 942   (let ((flist (cdr-safe (assoc check spam-registration-functions))))
 943     (if (eq classification 'spam)
 944         (nth 1 flist)
 945       (nth 0 flist))))
 946
 947 (defun spam-unregistration-function (classification check)
 948   (let ((flist (cdr-safe (assoc check spam-registration-functions))))
 949     (if (eq classification 'spam)
 950         (nth 3 flist)
 951       (nth 2 flist))))
 952
 953 (defun spam-list-articles (articles classification)
 954   (let ((mark-check (if (eq classification 'spam)
 955                         'spam-group-spam-mark-p
 956                       'spam-group-ham-mark-p))
 957         mark list)
 958     (dolist (article articles)
 959       (when (funcall mark-check
 960                      gnus-newsgroup-name
 961                      (gnus-summary-article-mark article))
 962         (push article list)))
 963     list))
 964
 965 (defun spam-register-routine (classification
 966                               check
 967                               &optional unregister
 968                               specific-articles)
 969   (when (and (spam-classification-valid-p classification)
 970              (spam-registration-check-valid-p check))
 971     (let* ((register-function
 972             (spam-registration-function classification check))
 973            (unregister-function
 974             (spam-unregistration-function classification check))
 975            (run-function (if unregister
 976                              unregister-function
 977                            register-function))
 978            (log-function (if unregister
 979                              'spam-log-undo-registration
 980                            'spam-log-processing-to-registry))
 981            article articles)
 982
 983       (when run-function
 984         ;; make list of articles, using specific-articles if given
 985         (setq articles (or specific-articles
 986                            (spam-list-articles
 987                             gnus-newsgroup-articles
 988                             classification)))
 989         ;; process them
 990         (gnus-message 5 "%s %d %s articles with classification %s, check %s"
 991                       (if unregister "Unregistering" "Registering")
 992                       (length articles)
 993                       (if specific-articles "specific" "")
 994                       (symbol-name classification)
 995                       (symbol-name check))
 996         (funcall run-function articles)
 997         ;; now log all the registrations (or undo them, depending on unregister)
 998         (dolist (article articles)
 999           (funcall log-function
1000                    (spam-fetch-field-message-id-fast article)
1001                    'process
1002                    classification
1003                    check
1004                    gnus-newsgroup-name))))))
1005
1006 ;;; log a ham- or spam-processor invocation to the registry
1007 (defun spam-log-processing-to-registry (id type classification check group)
1008   (when spam-log-to-registry
1009     (if (and (stringp id)
1010              (stringp group)
1011              (spam-process-type-valid-p type)
1012              (spam-classification-valid-p classification)
1013              (spam-registration-check-valid-p check))
1014         (let ((cell-list (cdr-safe (gnus-registry-fetch-extra id type)))
1015               (cell (list classification check group)))
1016           (push cell cell-list)
1017           (gnus-registry-store-extra-entry
1018            id
1019            type
1020            cell-list))
1021
1022       (gnus-message 5 (format "%s called with bad ID, type, classification, check, or group"
1023                               "spam-log-processing-to-registry")))))
1024
1025 ;;; check if a ham- or spam-processor registration needs to be undone
1026 (defun spam-log-unregistration-needed-p (id type classification check)
1027   (when spam-log-to-registry
1028     (if (and (stringp id)
1029              (spam-process-type-valid-p type)
1030              (spam-classification-valid-p classification)
1031              (spam-registration-check-valid-p check))
1032         (let ((cell-list (cdr-safe (gnus-registry-fetch-extra id type)))
1033               found)
1034           (dolist (cell cell-list)
1035             (unless found
1036               (when (and (eq classification (nth 0 cell))
1037                          (eq check (nth 1 cell)))
1038                 (setq found t))))
1039           found)
1040       (progn
1041         (gnus-message 5 (format "%s called with bad ID, type, classification, or check"
1042                                 "spam-log-unregistration-needed-p"))
1043         nil))))
1044
1045
1046 ;;; undo a ham- or spam-processor registration (the group is not used)
1047 (defun spam-log-undo-registration (id type classification check &optional group)
1048   (when (and spam-log-to-registry
1049              (spam-log-unregistration-needed-p id type classification check))
1050     (if (and (stringp id)
1051              (spam-process-type-valid-p type)
1052              (spam-classification-valid-p classification)
1053              (spam-registration-check-valid-p check))
1054         (let ((cell-list (cdr-safe (gnus-registry-fetch-extra id type)))
1055               new-cell-list found)
1056           (dolist (cell cell-list)
1057             (unless (and (eq classification (nth 0 cell))
1058                          (eq check (nth 1 cell)))
1059               (push cell new-cell-list)))
1060           (gnus-registry-store-extra-entry
1061            id
1062            type
1063            new-cell-list))
1064       (progn
1065         (gnus-message 5 (format "%s called with bad ID, type, check, or group"
1066                                 "spam-log-undo-registration"))
1067         nil))))
1068
1069 ;;; set up IMAP widening if it's necessary
1070 (defun spam-setup-widening ()
1071   (dolist (check spam-list-of-statistical-checks)
1072     (when (symbol-value check)
1073       (setq nnimap-split-download-body-default t))))
1074
1075 \f
1076 ;;;; Regex body
1077
1078 (defun spam-check-regex-body ()
1079   (let ((spam-regex-headers-ham spam-regex-body-ham)
1080         (spam-regex-headers-spam spam-regex-body-spam))
1081     (spam-check-regex-headers t)))
1082
1083 \f
1084 ;;;; Regex headers
1085
1086 (defun spam-check-regex-headers (&optional body)
1087   (let ((type (if body "body" "header"))
1088         ret found)
1089     (dolist (h-regex spam-regex-headers-ham)
1090       (unless found
1091         (goto-char (point-min))
1092         (when (re-search-forward h-regex nil t)
1093           (message "Ham regex %s search positive." type)
1094           (setq found t))))
1095     (dolist (s-regex spam-regex-headers-spam)
1096       (unless found
1097         (goto-char (point-min))
1098         (when (re-search-forward s-regex nil t)
1099           (message "Spam regex %s search positive." type)
1100           (setq found t)
1101           (setq ret spam-split-group))))
1102     ret))
1103
1104 \f
1105 ;;;; Blackholes.
1106
1107 (defun spam-reverse-ip-string (ip)
1108   (when (stringp ip)
1109     (mapconcat 'identity
1110                (nreverse (split-string ip "\\."))
1111                ".")))
1112
1113 (defun spam-check-blackholes ()
1114   "Check the Received headers for blackholed relays."
1115   (let ((headers (nnmail-fetch-field "received"))
1116         ips matches)
1117     (when headers
1118       (with-temp-buffer
1119         (insert headers)
1120         (goto-char (point-min))
1121         (gnus-message 5 "Checking headers for relay addresses")
1122         (while (re-search-forward
1123                 "\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\)" nil t)
1124           (gnus-message 9 "Blackhole search found host IP %s." (match-string 1))
1125           (push (spam-reverse-ip-string (match-string 1))
1126                 ips)))
1127       (dolist (server spam-blackhole-servers)
1128         (dolist (ip ips)
1129           (unless (and spam-blackhole-good-server-regex
1130                        ;; match the good-server-regex against the reversed (again) IP string
1131                        (string-match
1132                         spam-blackhole-good-server-regex
1133                         (spam-reverse-ip-string ip)))
1134             (unless matches
1135               (let ((query-string (concat ip "." server)))
1136                 (if spam-use-dig
1137                     (let ((query-result (query-dig query-string)))
1138                       (when query-result
1139                         (gnus-message 5 "(DIG): positive blackhole check '%s'"
1140                                       query-result)
1141                         (push (list ip server query-result)
1142                               matches)))
1143                   ;; else, if not using dig.el
1144                   (when (query-dns query-string)
1145                     (gnus-message 5 "positive blackhole check")
1146                     (push (list ip server (query-dns query-string 'TXT))
1147                           matches)))))))))
1148     (when matches
1149       spam-split-group)))
1150 \f
1151 ;;;; Hashcash.
1152
1153 (condition-case nil
1154     (progn
1155       (require 'hashcash)
1156
1157       (defun spam-check-hashcash ()
1158         "Check the headers for hashcash payments."
1159         (mail-check-payment)))   ;mail-check-payment returns a boolean
1160
1161   (file-error (progn
1162                 (defalias 'mail-check-payment 'ignore)
1163                 (defalias 'spam-check-hashcash 'ignore))))
1164 \f
1165 ;;;; BBDB
1166
1167 ;;; original idea for spam-check-BBDB from Alexander Kotelnikov
1168 ;;; <sacha@giotto.sj.ru>
1169
1170 ;; all this is done inside a condition-case to trap errors
1171
1172 (condition-case nil
1173     (progn
1174       (require 'bbdb)
1175       (require 'bbdb-com)
1176
1177       (defun spam-enter-ham-BBDB (addresses &optional remove)
1178         "Enter an address into the BBDB; implies ham (non-spam) sender"
1179         (dolist (from addresses)
1180           (when (stringp from)
1181             (let* ((parsed-address (gnus-extract-address-components from))
1182                    (name (or (nth 0 parsed-address) "Ham Sender"))
1183                    (remove-function (if remove
1184                                         'bbdb-delete-record-internal
1185                                       'ignore))
1186                    (net-address (nth 1 parsed-address))
1187                    (record (and net-address
1188                                 (bbdb-search-simple nil net-address))))
1189               (when net-address
1190                 (gnus-message 5 "%s address %s %s BBDB"
1191                               (if remove "Deleting" "Adding")
1192                               from
1193                               (if remove "from" "to"))
1194                 (if record
1195                     (funcall remove-function record)
1196                   (bbdb-create-internal name nil net-address nil nil
1197                                         "ham sender added by spam.el")))))))
1198
1199       (defun spam-BBDB-register-routine (articles &optional unregister)
1200         (let (addresses)
1201           (dolist (article articles)
1202             (when (stringp (spam-fetch-field-from-fast article))
1203               (push (spam-fetch-field-from-fast article) addresses)))
1204           ;; now do the register/unregister action
1205           (spam-enter-ham-BBDB addresses unregister)))
1206
1207       (defun spam-BBDB-unregister-routine (articles)
1208         (spam-BBDB-register-routine articles t))
1209
1210       (defun spam-check-BBDB ()
1211         "Mail from people in the BBDB is classified as ham or non-spam"
1212         (let ((who (nnmail-fetch-field "from")))
1213           (when who
1214             (setq who (nth 1 (gnus-extract-address-components who)))
1215             (if (bbdb-search-simple nil who)
1216                 t
1217               (if spam-use-BBDB-exclusive
1218                   spam-split-group
1219                 nil))))))
1220
1221   (file-error (progn
1222                 (defalias 'bbdb-search-simple 'ignore)
1223                 (defalias 'spam-check-BBDB 'ignore)
1224                 (defalias 'spam-BBDB-register-routine 'ignore)
1225                 (defalias 'spam-enter-ham-BBDB 'ignore)
1226                 (defalias 'bbdb-create-internal 'ignore)
1227                 (defalias 'bbdb-delete-record-internal 'ignore)
1228                 (defalias 'bbdb-records 'ignore))))
1229
1230 \f
1231 ;;;; ifile
1232
1233 ;;; check the ifile backend; return nil if the mail was NOT classified
1234 ;;; as spam
1235
1236 (defun spam-get-ifile-database-parameter ()
1237   "Get the command-line parameter for ifile's database from
1238   spam-ifile-database-path."
1239   (if spam-ifile-database-path
1240       (format "--db-file=%s" spam-ifile-database-path)
1241     nil))
1242
1243 (defun spam-check-ifile ()
1244   "Check the ifile backend for the classification of this message"
1245   (let ((article-buffer-name (buffer-name))
1246         category return)
1247     (with-temp-buffer
1248       (let ((temp-buffer-name (buffer-name))
1249             (db-param (spam-get-ifile-database-parameter)))
1250         (save-excursion
1251           (set-buffer article-buffer-name)
1252           (apply 'call-process-region
1253                  (point-min) (point-max) spam-ifile-path
1254                  nil temp-buffer-name nil "-c"
1255                  (if db-param `(,db-param "-q") `("-q"))))
1256         ;; check the return now (we're back in the temp buffer)
1257         (goto-char (point-min))
1258         (if (not (eobp))
1259             (setq category (buffer-substring (point) (spam-point-at-eol))))
1260         (when (not (zerop (length category))) ; we need a category here
1261           (if spam-ifile-all-categories
1262               (setq return category)
1263             ;; else, if spam-ifile-all-categories is not set...
1264             (when (string-equal spam-ifile-spam-category category)
1265               (setq return spam-split-group)))))) ; note return is nil otherwise
1266     return))
1267
1268 (defun spam-ifile-register-with-ifile (articles category &optional unregister)
1269   "Register an article, given as a string, with a category.
1270 Uses `gnus-newsgroup-name' if category is nil (for ham registration)."
1271   (let ((category (or category gnus-newsgroup-name))
1272         (add-or-delete-option (if unregister "-d" "-i"))
1273         (db (spam-get-ifile-database-parameter))
1274         parameters)
1275     (with-temp-buffer
1276       (dolist (article articles)
1277         (let ((article-string (spam-get-article-as-string article)))
1278           (when (stringp article-string)
1279             (insert article-string))))
1280       (apply 'call-process-region
1281              (point-min) (point-max) spam-ifile-path
1282              nil nil nil
1283              add-or-delete-option category
1284              (if db `(,db "-h") `("-h"))))))
1285
1286 (defun spam-ifile-register-spam-routine (articles &optional unregister)
1287   (spam-ifile-register-with-ifile articles spam-ifile-spam-category unregister))
1288
1289 (defun spam-ifile-unregister-spam-routine (articles)
1290   (spam-ifile-register-spam-routine articles t))
1291
1292 (defun spam-ifile-register-ham-routine (articles &optional unregister)
1293   (spam-ifile-register-with-ifile articles spam-ifile-ham-category unregister))
1294
1295 (defun spam-ifile-unregister-ham-routine (articles)
1296   (spam-ifile-register-ham-routine articles t))
1297
1298 \f
1299 ;;;; spam-stat
1300
1301 (condition-case nil
1302     (progn
1303       (let ((spam-stat-install-hooks nil))
1304         (require 'spam-stat))
1305
1306       (defun spam-check-stat ()
1307         "Check the spam-stat backend for the classification of this message"
1308         (let ((spam-stat-split-fancy-spam-group spam-split-group) ; override
1309               (spam-stat-buffer (buffer-name)) ; stat the current buffer
1310               category return)
1311           (spam-stat-split-fancy)))
1312
1313       (defun spam-stat-register-spam-routine (articles &optional unregister)
1314         (dolist (article articles)
1315           (let ((article-string (spam-get-article-as-string article)))
1316             (with-temp-buffer
1317               (insert article-string)
1318               (if unregister
1319                   (spam-stat-buffer-change-to-non-spam)
1320               (spam-stat-buffer-is-spam))))))
1321
1322       (defun spam-stat-unregister-spam-routine (articles)
1323         (spam-stat-register-spam-routine articles t))
1324
1325       (defun spam-stat-register-ham-routine (articles &optional unregister)
1326         (dolist (article articles)
1327           (let ((article-string (spam-get-article-as-string article)))
1328             (with-temp-buffer
1329               (insert article-string)
1330               (if unregister
1331                   (spam-stat-buffer-change-to-spam)
1332               (spam-stat-buffer-is-non-spam))))))
1333
1334       (defun spam-stat-unregister-ham-routine (articles)
1335         (spam-stat-register-ham-routine articles t))
1336
1337       (defun spam-maybe-spam-stat-load ()
1338         (when spam-use-stat (spam-stat-load)))
1339
1340       (defun spam-maybe-spam-stat-save ()
1341         (when spam-use-stat (spam-stat-save))))
1342
1343   (file-error (progn
1344                 (defalias 'spam-stat-load 'ignore)
1345                 (defalias 'spam-stat-save 'ignore)
1346                 (defalias 'spam-maybe-spam-stat-load 'ignore)
1347                 (defalias 'spam-maybe-spam-stat-save 'ignore)
1348                 (defalias 'spam-stat-register-ham-routine 'ignore)
1349                 (defalias 'spam-stat-unregister-ham-routine 'ignore)
1350                 (defalias 'spam-stat-register-spam-routine 'ignore)
1351                 (defalias 'spam-stat-unregister-spam-routine 'ignore)
1352                 (defalias 'spam-stat-buffer-is-spam 'ignore)
1353                 (defalias 'spam-stat-buffer-change-to-spam 'ignore)
1354                 (defalias 'spam-stat-buffer-is-non-spam 'ignore)
1355                 (defalias 'spam-stat-buffer-change-to-non-spam 'ignore)
1356                 (defalias 'spam-stat-split-fancy 'ignore)
1357                 (defalias 'spam-check-stat 'ignore))))
1358
1359 \f
1360
1361 ;;;; Blacklists and whitelists.
1362
1363 (defvar spam-whitelist-cache nil)
1364 (defvar spam-blacklist-cache nil)
1365
1366 (defun spam-kill-whole-line ()
1367   (beginning-of-line)
1368   (let ((kill-whole-line t))
1369     (kill-line)))
1370
1371 ;;; address can be a list, too
1372 (defun spam-enter-whitelist (address &optional remove)
1373   "Enter ADDRESS (list or single) into the whitelist.  With a
1374   non-nil REMOVE, remove them."
1375   (interactive "sAddress: ")
1376   (spam-enter-list address spam-whitelist remove)
1377   (setq spam-whitelist-cache nil))
1378
1379 ;;; address can be a list, too
1380 (defun spam-enter-blacklist (address &optional remove)
1381   "Enter ADDRESS (list or single) into the blacklist.  With a
1382   non-nil REMOVE, remove them."
1383   (interactive "sAddress: ")
1384   (spam-enter-list address spam-blacklist remove)
1385   (setq spam-blacklist-cache nil))
1386
1387 (defun spam-enter-list (addresses file &optional remove)
1388   "Enter ADDRESSES into the given FILE.
1389 Either the whitelist or the blacklist files can be used.  With
1390 REMOVE not nil, remove the ADDRESSES."
1391   (if (stringp addresses)
1392       (spam-enter-list (list addresses) file remove)
1393     ;; else, we have a list of addresses here
1394     (unless (file-exists-p (file-name-directory file))
1395       (make-directory (file-name-directory file) t))
1396     (save-excursion
1397       (set-buffer
1398        (find-file-noselect file))
1399       (dolist (a addresses)
1400         (when (stringp a)
1401           (goto-char (point-min))
1402           (if (re-search-forward (regexp-quote a) nil t)
1403               ;; found the address
1404               (when remove
1405                 (spam-kill-whole-line))
1406             ;; else, the address was not found
1407             (unless remove
1408               (goto-char (point-max))
1409               (unless (bobp)
1410                 (insert "\n"))
1411               (insert a "\n")))))
1412       (save-buffer))))
1413
1414 ;;; returns t if the sender is in the whitelist, nil or
1415 ;;; spam-split-group otherwise
1416 (defun spam-check-whitelist ()
1417   ;; FIXME!  Should it detect when file timestamps change?
1418   (unless spam-whitelist-cache
1419     (setq spam-whitelist-cache (spam-parse-list spam-whitelist)))
1420   (if (spam-from-listed-p spam-whitelist-cache)
1421       t
1422     (if spam-use-whitelist-exclusive
1423         spam-split-group
1424       nil)))
1425
1426 (defun spam-check-blacklist ()
1427   ;; FIXME!  Should it detect when file timestamps change?
1428   (unless spam-blacklist-cache
1429     (setq spam-blacklist-cache (spam-parse-list spam-blacklist)))
1430   (and (spam-from-listed-p spam-blacklist-cache) spam-split-group))
1431
1432 (defun spam-parse-list (file)
1433   (when (file-readable-p file)
1434     (let (contents address)
1435       (with-temp-buffer
1436         (insert-file-contents file)
1437         (while (not (eobp))
1438           (setq address (buffer-substring (point) (spam-point-at-eol)))
1439           (forward-line 1)
1440           ;; insert the e-mail address if detected, otherwise the raw data
1441           (unless (zerop (length address))
1442             (let ((pure-address (nth 1 (gnus-extract-address-components address))))
1443               (push (or pure-address address) contents)))))
1444       (nreverse contents))))
1445
1446 (defun spam-from-listed-p (cache)
1447   (let ((from (nnmail-fetch-field "from"))
1448         found)
1449     (while cache
1450       (let ((address (pop cache)))
1451         (unless (zerop (length address)) ; 0 for a nil address too
1452           (setq address (regexp-quote address))
1453           ;; fix regexp-quote's treatment of user-intended regexes
1454           (while (string-match "\\\\\\*" address)
1455             (setq address (replace-match ".*" t t address))))
1456         (when (and address (string-match address from))
1457           (setq found t
1458                 cache nil))))
1459     found))
1460
1461 (defun spam-filelist-register-routine (articles blacklist &optional unregister)
1462   (let ((de-symbol (if blacklist 'spam-use-whitelist 'spam-use-blacklist))
1463         (declassification (if blacklist 'ham 'spam))
1464         (enter-function
1465          (if blacklist 'spam-enter-blacklist 'spam-enter-whitelist))
1466         (remove-function
1467          (if blacklist 'spam-enter-whitelist 'spam-enter-blacklist))
1468         from addresses unregister-list)
1469     (dolist (article articles)
1470       (let ((from (spam-fetch-field-from-fast article))
1471             (id (spam-fetch-field-message-id-fast article))
1472             sender-ignored)
1473         (when (stringp from)
1474           (dolist (ignore-regex spam-blacklist-ignored-regexes)
1475             (when (and (not sender-ignored)
1476                        (stringp ignore-regex)
1477                        (string-match ignore-regex from))
1478               (setq sender-ignored t)))
1479           ;; remember the messages we need to unregister, unless remove is set
1480           (when (and
1481                  (null unregister)
1482                  (spam-log-unregistration-needed-p
1483                   id 'process declassification de-symbol))
1484             (push from unregister-list))
1485           (unless sender-ignored
1486             (push from addresses)))))
1487
1488     (if unregister
1489         (funcall enter-function addresses t) ; unregister all these addresses
1490       ;; else, register normally and unregister what we need to
1491       (funcall remove-function unregister-list t)
1492       (dolist (article unregister-list)
1493         (spam-log-undo-registration
1494          (spam-fetch-field-message-id-fast article)
1495          'process
1496          declassification
1497          de-symbol))
1498       (funcall enter-function addresses nil))))
1499
1500 (defun spam-blacklist-unregister-routine (articles)
1501   (spam-blacklist-register-routine articles t))
1502
1503 (defun spam-blacklist-register-routine (articles &optional unregister)
1504   (spam-filelist-register-routine articles t unregister))
1505
1506 (defun spam-whitelist-unregister-routine (articles)
1507   (spam-whitelist-register-routine articles t))
1508
1509 (defun spam-whitelist-register-routine (articles &optional unregister)
1510   (spam-filelist-register-routine articles nil unregister))
1511
1512 \f
1513 ;;;; Spam-report glue
1514 (defun spam-report-gmane-register-routine (articles)
1515   (when articles
1516     (apply 'spam-report-gmane articles)))
1517
1518 \f
1519 ;;;; Bogofilter
1520 (defun spam-check-bogofilter-headers (&optional score)
1521   (let ((header (nnmail-fetch-field spam-bogofilter-header)))
1522     (when header                        ; return nil when no header
1523       (if score                         ; scoring mode
1524           (if (string-match "spamicity=\\([0-9.]+\\)" header)
1525               (match-string 1 header)
1526             "0")
1527         ;; spam detection mode
1528         (when (string-match spam-bogofilter-bogosity-positive-spam-header
1529                             header)
1530           spam-split-group)))))
1531
1532 ;; return something sensible if the score can't be determined
1533 (defun spam-bogofilter-score ()
1534   "Get the Bogofilter spamicity score"
1535   (interactive)
1536   (save-window-excursion
1537     (gnus-summary-show-article t)
1538     (set-buffer gnus-article-buffer)
1539     (let ((score (or (spam-check-bogofilter-headers t)
1540                      (spam-check-bogofilter t))))
1541       (message "Spamicity score %s" score)
1542       (or score "0"))
1543     (gnus-summary-show-article)))
1544
1545 (defun spam-check-bogofilter (&optional score)
1546   "Check the Bogofilter backend for the classification of this message"
1547   (let ((article-buffer-name (buffer-name))
1548         (db spam-bogofilter-database-directory)
1549         return)
1550     (with-temp-buffer
1551       (let ((temp-buffer-name (buffer-name)))
1552         (save-excursion
1553           (set-buffer article-buffer-name)
1554           (apply 'call-process-region
1555                  (point-min) (point-max)
1556                  spam-bogofilter-path
1557                  nil temp-buffer-name nil
1558                  (if db `("-d" ,db "-v") `("-v"))))
1559         (setq return (spam-check-bogofilter-headers score))))
1560     return))
1561
1562 (defun spam-bogofilter-register-with-bogofilter (articles
1563                                                  spam
1564                                                  &optional unregister)
1565   "Register an article, given as a string, as spam or non-spam."
1566   (dolist (article articles)
1567     (let ((article-string (spam-get-article-as-string article))
1568           (db spam-bogofilter-database-directory)
1569           (switch (if unregister
1570                       (if spam
1571                           spam-bogofilter-spam-strong-switch
1572                         spam-bogofilter-ham-strong-switch)
1573                     (if spam
1574                         spam-bogofilter-spam-switch
1575                       spam-bogofilter-ham-switch))))
1576       (when (stringp article-string)
1577         (with-temp-buffer
1578           (insert article-string)
1579
1580           (apply 'call-process-region
1581                  (point-min) (point-max)
1582                  spam-bogofilter-path
1583                  nil nil nil switch
1584                  (if db `("-d" ,db "-v") `("-v"))))))))
1585
1586 (defun spam-bogofilter-register-spam-routine (articles &optional unregister)
1587   (spam-bogofilter-register-with-bogofilter articles t unregister))
1588
1589 (defun spam-bogofilter-unregister-spam-routine (articles)
1590   (spam-bogofilter-register-spam-routine articles t))
1591
1592 (defun spam-bogofilter-register-ham-routine (articles &optional unregister)
1593   (spam-bogofilter-register-with-bogofilter articles nil unregister))
1594
1595 (defun spam-bogofilter-unregister-ham-routine (articles)
1596   (spam-bogofilter-register-ham-routine articles t))
1597
1598
1599 \f
1600 ;;;; spamoracle
1601 (defun spam-check-spamoracle ()
1602   "Run spamoracle on an article to determine whether it's spam."
1603   (let ((article-buffer-name (buffer-name)))
1604     (with-temp-buffer
1605       (let ((temp-buffer-name (buffer-name)))
1606         (save-excursion
1607           (set-buffer article-buffer-name)
1608           (let ((status
1609                  (apply 'call-process-region
1610                         (point-min) (point-max)
1611                         spam-spamoracle-binary
1612                         nil temp-buffer-name nil
1613                         (if spam-spamoracle-database
1614                             `("-f" ,spam-spamoracle-database "mark")
1615                           '("mark")))))
1616             (if (eq 0 status)
1617                 (progn
1618                   (set-buffer temp-buffer-name)
1619                   (goto-char (point-min))
1620                   (when (re-search-forward "^X-Spam: yes;" nil t)
1621                     spam-split-group))
1622               (error "Error running spamoracle" status))))))))
1623
1624 (defun spam-spamoracle-learn (articles article-is-spam-p &optional unregister)
1625   "Run spamoracle in training mode."
1626   (with-temp-buffer
1627     (let ((temp-buffer-name (buffer-name)))
1628       (save-excursion
1629         (goto-char (point-min))
1630         (dolist (article articles)
1631           (insert (spam-get-article-as-string article)))
1632         (let* ((arg (if (spam-xor unregister article-is-spam-p)
1633                         "-spam"
1634                       "-good"))
1635                (status
1636                 (apply 'call-process-region
1637                        (point-min) (point-max)
1638                        spam-spamoracle-binary
1639                        nil temp-buffer-name nil
1640                        (if spam-spamoracle-database
1641                            `("-f" ,spam-spamoracle-database
1642                              "add" ,arg)
1643                          `("add" ,arg)))))
1644           (when (not (eq 0 status))
1645             (error "Error running spamoracle" status)))))))
1646
1647 (defun spam-spamoracle-learn-ham (articles &optional unregister)
1648   (spam-spamoracle-learn articles nil unregister))
1649
1650 (defun spam-spamoracle-unlearn-ham (articles &optional unregister)
1651   (spam-spamoracle-learn-ham articles t))
1652
1653 (defun spam-spamoracle-learn-spam (articles &optional unregister)
1654   (spam-spamoracle-learn articles t unregister))
1655
1656 (defun spam-spamoracle-unlearn-spam (articles &optional unregister)
1657   (spam-spamoracle-learn-spam articles t))
1658
1659 \f
1660 ;;;; Hooks
1661
1662 ;;;###autoload
1663 (defun spam-initialize ()
1664   "Install the spam.el hooks and do other initialization"
1665   (interactive)
1666   (setq spam-install-hooks t)
1667   ;; TODO: How do we redo this every time spam-face is customized?
1668   (push '((eq mark gnus-spam-mark) . spam-face)
1669         gnus-summary-highlight)
1670   ;; Add hooks for loading and saving the spam stats
1671   (add-hook 'gnus-save-newsrc-hook 'spam-maybe-spam-stat-save)
1672   (add-hook 'gnus-get-top-new-news-hook 'spam-maybe-spam-stat-load)
1673   (add-hook 'gnus-startup-hook 'spam-maybe-spam-stat-load)
1674   (add-hook 'gnus-summary-prepare-exit-hook 'spam-summary-prepare-exit)
1675   (add-hook 'gnus-summary-prepare-hook 'spam-summary-prepare)
1676   (add-hook 'gnus-get-new-news-hook 'spam-setup-widening))
1677
1678 (defun spam-unload-hook ()
1679   "Uninstall the spam.el hooks"
1680   (interactive)
1681   (remove-hook 'gnus-save-newsrc-hook 'spam-maybe-spam-stat-save)
1682   (remove-hook 'gnus-get-top-new-news-hook 'spam-maybe-spam-stat-load)
1683   (remove-hook 'gnus-startup-hook 'spam-maybe-spam-stat-load)
1684   (remove-hook 'gnus-summary-prepare-exit-hook 'spam-summary-prepare-exit)
1685   (remove-hook 'gnus-summary-prepare-hook 'spam-summary-prepare)
1686   (remove-hook 'gnus-get-new-news-hook 'spam-setup-widening))
1687
1688 (when spam-install-hooks
1689   (spam-initialize))
1690
1691 (provide 'spam)
1692
1693 ;;; spam.el ends here.