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

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