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         article tomove deletep)
 565     (dolist (article articles)
 566       (when (eq (gnus-summary-article-mark article) gnus-spam-mark)
 567         (gnus-summary-mark-article article gnus-expirable-mark)
 568         (push article tomove)))
 569
 570     ;; now do the actual copies
 571     (dolist (group groups)
 572       (when (and tomove
 573                  (stringp group))
 574         (dolist (article tomove)
 575           (gnus-summary-set-process-mark article))
 576         (when tomove
 577           (if (> (length groups) 1)
 578               (progn
 579                 (gnus-summary-copy-article nil group)
 580                 (setq deletep t))
 581             (gnus-summary-move-article nil group)))))
 582
 583     ;; now delete the articles, if there was a copy done
 584     (when deletep
 585       (dolist (article tomove)
 586         (gnus-summary-set-process-mark article))
 587       (when tomove
 588         (let ((gnus-novice-user nil))   ; don't ask me if I'm sure
 589           (gnus-summary-delete-article nil))))
 590
 591     (gnus-summary-yank-process-mark)))
 592
 593 (defun spam-ham-copy-or-move-routine (copy groups)
 594   (gnus-summary-kill-process-mark)
 595   (let ((articles gnus-newsgroup-articles)
 596         article mark todo deletep)
 597     (dolist (article articles)
 598       (when (spam-group-ham-mark-p gnus-newsgroup-name
 599                                    (gnus-summary-article-mark article))
 600         (push article todo)))
 601
 602     ;; now do the actual move
 603     (dolist (group groups)
 604       (when (and todo (stringp group))
 605         (dolist (article todo)
 606           (when spam-mark-ham-unread-before-move-from-spam-group
 607             (gnus-summary-mark-article article gnus-unread-mark))
 608           (gnus-summary-set-process-mark article))
 609
 610         (if (> (length groups) 1)
 611             (progn
 612               (gnus-summary-copy-article nil group)
 613               (setq deletep t))
 614           (gnus-summary-move-article nil group))))
 615
 616     ;; now delete the articles, unless a) copy is t, and when there was a copy done
 617     ;;                                 b) a move was done to a single group
 618     (unless copy
 619       (when deletep
 620         (dolist (article todo)
 621           (gnus-summary-set-process-mark article))
 622         (when todo
 623           (let ((gnus-novice-user nil)) ; don't ask me if I'm sure
 624             (gnus-summary-delete-article nil))))))
 625
 626   (gnus-summary-yank-process-mark))
 627
 628 (defun spam-ham-copy-routine (&rest groups)
 629   (spam-ham-copy-or-move-routine t groups))
 630
 631 (defun spam-ham-move-routine (&rest groups)
 632   (spam-ham-copy-or-move-routine nil groups))
 633
 634 (defun spam-generic-register-routine (spam-func ham-func)
 635   (let ((articles gnus-newsgroup-articles)
 636         article mark ham-articles spam-articles)
 637
 638     (while articles
 639       (setq article (pop articles)
 640             mark (gnus-summary-article-mark article))
 641       (cond ((spam-group-spam-mark-p gnus-newsgroup-name mark)
 642              (push article spam-articles))
 643             ((memq article gnus-newsgroup-saved))
 644             ((spam-group-ham-mark-p gnus-newsgroup-name mark)
 645              (push article ham-articles))))
 646
 647     (when (and ham-articles ham-func)
 648       (mapc ham-func ham-articles))     ; we use mapc because unlike
 649                                         ; mapcar it discards the
 650                                         ; return values
 651     (when (and spam-articles spam-func)
 652       (mapc spam-func spam-articles)))) ; we use mapc because unlike
 653                                         ; mapcar it discards the
 654                                         ; return values
 655
 656 (eval-and-compile
 657   (defalias 'spam-point-at-eol (if (fboundp 'point-at-eol)
 658                                    'point-at-eol
 659                                  'line-end-position)))
 660
 661 (defun spam-get-article-as-string (article)
 662   (let ((article-buffer (spam-get-article-as-buffer article))
 663                         article-string)
 664     (when article-buffer
 665       (save-window-excursion
 666         (set-buffer article-buffer)
 667         (setq article-string (buffer-string))))
 668   article-string))
 669
 670 (defun spam-get-article-as-buffer (article)
 671   (let ((article-buffer))
 672     (when (numberp article)
 673       (save-window-excursion
 674         (gnus-summary-goto-subject article)
 675         (gnus-summary-show-article t)
 676         (setq article-buffer (get-buffer gnus-article-buffer))))
 677     article-buffer))
 678
 679 ;; disabled for now
 680 ;; (defun spam-get-article-as-filename (article)
 681 ;;   (let ((article-filename))
 682 ;;     (when (numberp article)
 683 ;;       (nnml-possibly-change-directory (gnus-group-real-name gnus-newsgroup-name))
 684 ;;       (setq article-filename (expand-file-name (int-to-string article) nnml-current-directory)))
 685 ;;     (if (file-exists-p article-filename)
 686 ;;      article-filename
 687 ;;       nil)))
 688
 689 (defun spam-fetch-field-from-fast (article)
 690   "Fetch the `from' field quickly, using the internal gnus-data-list function"
 691   (if (and (numberp article)
 692            (assoc article (gnus-data-list nil)))
 693       (mail-header-from (gnus-data-header (assoc article (gnus-data-list nil))))
 694     nil))
 695
 696 (defun spam-fetch-field-subject-fast (article)
 697   "Fetch the `subject' field quickly, using the internal gnus-data-list function"
 698   (if (and (numberp article)
 699            (assoc article (gnus-data-list nil)))
 700       (mail-header-subject (gnus-data-header (assoc article (gnus-data-list nil))))
 701     nil))
 702
 703 (defun spam-fetch-field-message-id-fast (article)
 704   "Fetch the `subject' field quickly, using the internal gnus-data-list function"
 705   (if (and (numberp article)
 706            (assoc article (gnus-data-list nil)))
 707       (mail-header-message-id (gnus-data-header (assoc article (gnus-data-list nil))))
 708     nil))
 709
 710 \f
 711 ;;;; Spam determination.
 712
 713 (defvar spam-list-of-checks
 714   '((spam-use-blacklist                 .       spam-check-blacklist)
 715     (spam-use-regex-headers             .       spam-check-regex-headers)
 716     (spam-use-regex-body                .       spam-check-regex-body)
 717     (spam-use-whitelist                 .       spam-check-whitelist)
 718     (spam-use-BBDB                      .       spam-check-BBDB)
 719     (spam-use-ifile                     .       spam-check-ifile)
 720     (spam-use-spamoracle                .       spam-check-spamoracle)
 721     (spam-use-stat                      .       spam-check-stat)
 722     (spam-use-blackholes                .       spam-check-blackholes)
 723     (spam-use-hashcash                  .       spam-check-hashcash)
 724     (spam-use-bogofilter-headers        .       spam-check-bogofilter-headers)
 725     (spam-use-bogofilter                .       spam-check-bogofilter))
 726 "The spam-list-of-checks list contains pairs associating a parameter
 727 variable with a spam checking function.  If the parameter variable is
 728 true, then the checking function is called, and its value decides what
 729 happens.  Each individual check may return nil, t, or a mailgroup
 730 name.  The value nil means that the check does not yield a decision,
 731 and so, that further checks are needed.  The value t means that the
 732 message is definitely not spam, and that further spam checks should be
 733 inhibited.  Otherwise, a mailgroup name is returned where the mail
 734 should go, and further checks are also inhibited.  The usual mailgroup
 735 name is the value of `spam-split-group', meaning that the message is
 736 definitely a spam.")
 737
 738 (defvar spam-list-of-statistical-checks
 739   '(spam-use-ifile spam-use-regex-body spam-use-stat spam-use-bogofilter spam-use-spamoracle)
 740 "The spam-list-of-statistical-checks list contains all the mail
 741 splitters that need to have the full message body available.")
 742
 743 ;;;TODO: modify to invoke self with each specific check if invoked without specific checks
 744 (defun spam-split (&rest specific-checks)
 745   "Split this message into the `spam' group if it is spam.
 746 This function can be used as an entry in `nnmail-split-fancy',
 747 for example like this: (: spam-split).  It can take checks as
 748 parameters.  A string as a parameter will set the
 749 spam-split-group to that string.
 750
 751 See the Info node `(gnus)Fancy Mail Splitting' for more details."
 752   (interactive)
 753   (let ((spam-split-group-choice spam-split-group))
 754     (dolist (check specific-checks)
 755       (when (stringp check)
 756         (setq spam-split-group-choice check)
 757         (setq specific-checks (delq check specific-checks))))
 758
 759     (let ((spam-split-group spam-split-group-choice))
 760       (save-excursion
 761         (save-restriction
 762           (dolist (check spam-list-of-statistical-checks)
 763             (when (and (symbolp check) (symbol-value check))
 764               (widen)
 765               (gnus-message 8 "spam-split: widening the buffer (%s requires it)"
 766                             (symbol-name check))
 767               (return)))
 768           ;;   (progn (widen) (debug (buffer-string)))
 769           (let ((list-of-checks spam-list-of-checks)
 770                 decision)
 771             (while (and list-of-checks (not decision))
 772               (let ((pair (pop list-of-checks)))
 773                 (when (and (symbol-value (car pair))
 774                            (or (null specific-checks)
 775                                (memq (car pair) specific-checks)))
 776                   (gnus-message 5 "spam-split: calling the %s function"
 777                                 (symbol-name (cdr pair)))
 778                   (setq decision (funcall (cdr pair))))))
 779             (if (eq decision t)
 780                 nil
 781               decision)))))))
 782
 783 ;;; log a ham- or spam-processor invocation to the registry
 784 (defun spam-log-processing-to-registry (id type classification check group)
 785   (when spam-log-to-registry
 786     (if (and (stringp id)
 787              (stringp group)
 788              (or (eq type 'incoming)
 789                  (eq type 'process))
 790              (or (eq classification 'spam)
 791                  (eq classification 'ham))
 792              (assoc check spam-list-of-checks))
 793         (let ((cell-list (cdr-safe (gnus-registry-fetch-extra id type)))
 794                (cell (list classification check group)))
 795           (push cell cell-list)
 796           (gnus-registry-store-extra-entry
 797            id
 798            type
 799            cell-list))
 800
 801       (gnus-message 5 (format "%s called with bad ID, type, check, or group"
 802                               "spam-log-processing-to-registry")))))
 803
 804 ;;; check if a ham- or spam-processor registration needs to be undone
 805 (defun spam-log-unregistration-needed-p (id type classification check)
 806   (when spam-log-to-registry
 807     (if (and (stringp id)
 808              (or (eq type 'incoming)
 809                  (eq type 'process))
 810              (or (eq classification 'spam)
 811                  (eq classification 'ham))
 812              (assoc check spam-list-of-checks))
 813         (let ((cell-list (cdr-safe (gnus-registry-fetch-extra id type)))
 814               found)
 815           (dolist (cell cell-list)
 816             (unless found
 817               (when (and (eq classification (nth 0 cell))
 818                          (eq check (nth 1 cell)))
 819                 (setq found t))))
 820           found)
 821       (progn
 822         (gnus-message 5 (format "%s called with bad ID, type, check, or group"
 823                                 "spam-log-unregistration-needed-p"))
 824         nil))))
 825
 826 ;;; set up IMAP widening if it's necessary
 827 (defun spam-setup-widening ()
 828   (dolist (check spam-list-of-statistical-checks)
 829     (when (symbol-value check)
 830       (setq nnimap-split-download-body-default t))))
 831
 832 \f
 833 ;;;; Regex body
 834
 835 (defun spam-check-regex-body ()
 836   (let ((spam-regex-headers-ham spam-regex-body-ham)
 837         (spam-regex-headers-spam spam-regex-body-spam))
 838     (spam-check-regex-headers t)))
 839
 840 \f
 841 ;;;; Regex headers
 842
 843 (defun spam-check-regex-headers (&optional body)
 844   (let ((type (if body "body" "header"))
 845          ret found)
 846     (dolist (h-regex spam-regex-headers-ham)
 847       (unless found
 848         (goto-char (point-min))
 849         (when (re-search-forward h-regex nil t)
 850           (message "Ham regex %s search positive." type)
 851           (setq found t))))
 852     (dolist (s-regex spam-regex-headers-spam)
 853       (unless found
 854         (goto-char (point-min))
 855         (when (re-search-forward s-regex nil t)
 856           (message "Spam regex %s search positive." type)
 857           (setq found t)
 858           (setq ret spam-split-group))))
 859     ret))
 860
 861 \f
 862 ;;;; Blackholes.
 863
 864 (defun spam-reverse-ip-string (ip)
 865   (when (stringp ip)
 866     (mapconcat 'identity
 867                (nreverse (split-string ip "\\."))
 868                ".")))
 869
 870 (defun spam-check-blackholes ()
 871   "Check the Received headers for blackholed relays."
 872   (let ((headers (nnmail-fetch-field "received"))
 873         ips matches)
 874     (when headers
 875       (with-temp-buffer
 876         (insert headers)
 877         (goto-char (point-min))
 878         (gnus-message 5 "Checking headers for relay addresses")
 879         (while (re-search-forward
 880                 "\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\)" nil t)
 881           (gnus-message 9 "Blackhole search found host IP %s." (match-string 1))
 882           (push (spam-reverse-ip-string (match-string 1))
 883                 ips)))
 884       (dolist (server spam-blackhole-servers)
 885         (dolist (ip ips)
 886           (unless (and spam-blackhole-good-server-regex
 887                        ;; match the good-server-regex against the reversed (again) IP string
 888                        (string-match
 889                         spam-blackhole-good-server-regex
 890                         (spam-reverse-ip-string ip)))
 891             (unless matches
 892               (let ((query-string (concat ip "." server)))
 893                 (if spam-use-dig
 894                     (let ((query-result (query-dig query-string)))
 895                       (when query-result
 896                         (gnus-message 5 "(DIG): positive blackhole check '%s'"
 897                                       query-result)
 898                         (push (list ip server query-result)
 899                               matches)))
 900                   ;; else, if not using dig.el
 901                   (when (query-dns query-string)
 902                     (gnus-message 5 "positive blackhole check")
 903                     (push (list ip server (query-dns query-string 'TXT))
 904                           matches)))))))))
 905     (when matches
 906       spam-split-group)))
 907 \f
 908 ;;;; Hashcash.
 909
 910 (condition-case nil
 911     (progn
 912       (require 'hashcash)
 913
 914       (defun spam-check-hashcash ()
 915         "Check the headers for hashcash payments."
 916         (mail-check-payment)))          ;mail-check-payment returns a boolean
 917
 918   (file-error (progn
 919                 (defalias 'mail-check-payment 'ignore)
 920                 (defalias 'spam-check-hashcash 'ignore))))
 921 \f
 922 ;;;; BBDB
 923
 924 ;;; original idea for spam-check-BBDB from Alexander Kotelnikov
 925 ;;; <sacha@giotto.sj.ru>
 926
 927 ;; all this is done inside a condition-case to trap errors
 928
 929 (condition-case nil
 930     (progn
 931       (require 'bbdb)
 932       (require 'bbdb-com)
 933
 934   (defun spam-enter-ham-BBDB (from)
 935     "Enter an address into the BBDB; implies ham (non-spam) sender"
 936     (when (stringp from)
 937       (let* ((parsed-address (gnus-extract-address-components from))
 938              (name (or (car parsed-address) "Ham Sender"))
 939              (net-address (car (cdr parsed-address))))
 940         (gnus-message 5 "Adding address %s to BBDB" from)
 941         (when (and net-address
 942                    (not (bbdb-search-simple nil net-address)))
 943           (bbdb-create-internal name nil net-address nil nil
 944                                 "ham sender added by spam.el")))))
 945
 946   (defun spam-BBDB-register-routine ()
 947     (spam-generic-register-routine
 948      ;; spam function
 949      nil
 950      ;; ham function
 951      (lambda (article)
 952        (spam-log-processing-to-registry
 953         (spam-fetch-field-message-id-fast article)
 954         'process
 955         'ham
 956         'spam-use-BBDB
 957         gnus-newsgroup-name)
 958        (spam-enter-ham-BBDB (spam-fetch-field-from-fast article)))))
 959
 960   (defun spam-check-BBDB ()
 961     "Mail from people in the BBDB is classified as ham or non-spam"
 962     (let ((who (nnmail-fetch-field "from")))
 963       (when who
 964         (setq who (cadr (gnus-extract-address-components who)))
 965         (if (bbdb-search-simple nil who)
 966             t
 967           (if spam-use-BBDB-exclusive
 968               spam-split-group
 969             nil))))))
 970
 971   (file-error (progn
 972                 (defalias 'bbdb-search-simple 'ignore)
 973                 (defalias 'spam-check-BBDB 'ignore)
 974                 (defalias 'spam-BBDB-register-routine 'ignore)
 975                 (defalias 'spam-enter-ham-BBDB 'ignore)
 976                 (defalias 'bbdb-create-internal 'ignore)
 977                 (defalias 'bbdb-records 'ignore))))
 978
 979 \f
 980 ;;;; ifile
 981
 982 ;;; check the ifile backend; return nil if the mail was NOT classified
 983 ;;; as spam
 984
 985 (defun spam-get-ifile-database-parameter ()
 986   "Get the command-line parameter for ifile's database from spam-ifile-database-path."
 987   (if spam-ifile-database-path
 988       (format "--db-file=%s" spam-ifile-database-path)
 989     nil))
 990
 991 (defun spam-check-ifile ()
 992   "Check the ifile backend for the classification of this message"
 993   (let ((article-buffer-name (buffer-name))
 994         category return)
 995     (with-temp-buffer
 996       (let ((temp-buffer-name (buffer-name))
 997             (db-param (spam-get-ifile-database-parameter)))
 998         (save-excursion
 999           (set-buffer article-buffer-name)
1000           (if db-param
1001               (call-process-region (point-min) (point-max) spam-ifile-path
1002                                    nil temp-buffer-name nil "-q" "-c" db-param)
1003             (call-process-region (point-min) (point-max) spam-ifile-path
1004                                  nil temp-buffer-name nil "-q" "-c")))
1005         (goto-char (point-min))
1006         (if (not (eobp))
1007             (setq category (buffer-substring (point) (spam-point-at-eol))))
1008         (when (not (zerop (length category))) ; we need a category here
1009           (if spam-ifile-all-categories
1010               (setq return category)
1011             ;; else, if spam-ifile-all-categories is not set...
1012             (when (string-equal spam-ifile-spam-category category)
1013               (setq return spam-split-group))))))
1014     return))
1015
1016 (defun spam-ifile-register-with-ifile (article-string category)
1017   "Register an article, given as a string, with a category.
1018 Uses `gnus-newsgroup-name' if category is nil (for ham registration)."
1019   (when (stringp article-string)
1020     (let ((category (or category gnus-newsgroup-name))
1021           (db-param (spam-get-ifile-database-parameter)))
1022       (with-temp-buffer
1023         (insert article-string)
1024         (if db-param
1025             (call-process-region (point-min) (point-max) spam-ifile-path
1026                                  nil nil nil
1027                                  "-h" "-i" category db-param)
1028           (call-process-region (point-min) (point-max) spam-ifile-path
1029                                nil nil nil
1030                                "-h" "-i" category))))))
1031
1032 (defun spam-ifile-register-spam-routine ()
1033   (spam-generic-register-routine
1034    (lambda (article)
1035      (spam-log-processing-to-registry
1036       (spam-fetch-field-message-id-fast article)
1037       'process
1038       'spam
1039       'spam-use-ifile
1040       gnus-newsgroup-name)
1041      (spam-ifile-register-with-ifile
1042       (spam-get-article-as-string article) spam-ifile-spam-category))
1043    nil))
1044
1045 (defun spam-ifile-register-ham-routine ()
1046   (spam-generic-register-routine
1047    nil
1048    (lambda (article)
1049      (spam-log-processing-to-registry
1050       (spam-fetch-field-message-id-fast article)
1051       'process
1052       'ham
1053       'spam-use-ifile
1054       gnus-newsgroup-name)
1055      (spam-ifile-register-with-ifile
1056       (spam-get-article-as-string article) spam-ifile-ham-category))))
1057
1058 \f
1059 ;;;; spam-stat
1060
1061 (condition-case nil
1062     (progn
1063       (let ((spam-stat-install-hooks nil))
1064         (require 'spam-stat))
1065
1066       (defun spam-check-stat ()
1067         "Check the spam-stat backend for the classification of this message"
1068         (let ((spam-stat-split-fancy-spam-group spam-split-group) ; override
1069               (spam-stat-buffer (buffer-name)) ; stat the current buffer
1070               category return)
1071           (spam-stat-split-fancy)))
1072
1073       (defun spam-stat-register-spam-routine ()
1074         (spam-generic-register-routine
1075          (lambda (article)
1076            (spam-log-processing-to-registry
1077             (spam-fetch-field-message-id-fast article)
1078             'process
1079             'spam
1080             'spam-use-stat
1081             gnus-newsgroup-name)
1082            (let ((article-string (spam-get-article-as-string article)))
1083              (with-temp-buffer
1084                (insert article-string)
1085                (spam-stat-buffer-is-spam))))
1086          nil))
1087
1088       (defun spam-stat-register-ham-routine ()
1089         (spam-generic-register-routine
1090          nil
1091          (lambda (article)
1092            (spam-log-processing-to-registry
1093             (spam-fetch-field-message-id-fast article)
1094             'process
1095             'ham
1096             'spam-use-stat
1097             gnus-newsgroup-name)
1098            (let ((article-string (spam-get-article-as-string article)))
1099              (with-temp-buffer
1100                (insert article-string)
1101                (spam-stat-buffer-is-non-spam))))))
1102
1103       (defun spam-maybe-spam-stat-load ()
1104         (when spam-use-stat (spam-stat-load)))
1105
1106       (defun spam-maybe-spam-stat-save ()
1107         (when spam-use-stat (spam-stat-save))))
1108
1109   (file-error (progn
1110                 (defalias 'spam-maybe-spam-stat-load 'ignore)
1111                 (defalias 'spam-maybe-spam-stat-save 'ignore)
1112                 (defalias 'spam-stat-register-ham-routine 'ignore)
1113                 (defalias 'spam-stat-register-spam-routine 'ignore)
1114                 (defalias 'spam-stat-buffer-is-spam 'ignore)
1115                 (defalias 'spam-stat-buffer-is-non-spam 'ignore)
1116                 (defalias 'spam-stat-split-fancy 'ignore)
1117                 (defalias 'spam-stat-load 'ignore)
1118                 (defalias 'spam-stat-save 'ignore)
1119                 (defalias 'spam-check-stat 'ignore))))
1120
1121 \f
1122
1123 ;;;; Blacklists and whitelists.
1124
1125 (defvar spam-whitelist-cache nil)
1126 (defvar spam-blacklist-cache nil)
1127
1128 (defun spam-enter-whitelist (address)
1129   "Enter ADDRESS into the whitelist."
1130   (interactive "sAddress: ")
1131   (spam-enter-list address spam-whitelist)
1132   (setq spam-whitelist-cache nil))
1133
1134 (defun spam-enter-blacklist (address)
1135   "Enter ADDRESS into the blacklist."
1136   (interactive "sAddress: ")
1137   (spam-enter-list address spam-blacklist)
1138   (setq spam-blacklist-cache nil))
1139
1140 (defun spam-enter-list (address file)
1141   "Enter ADDRESS into the given FILE, either the whitelist or the blacklist."
1142   (unless (file-exists-p (file-name-directory file))
1143     (make-directory (file-name-directory file) t))
1144   (save-excursion
1145     (set-buffer
1146      (find-file-noselect file))
1147     (goto-char (point-min))
1148     (unless (re-search-forward (regexp-quote address) nil t)
1149       (goto-char (point-max))
1150       (unless (bobp)
1151         (insert "\n"))
1152       (insert address "\n")
1153       (save-buffer))))
1154
1155 ;;; returns t if the sender is in the whitelist, nil or spam-split-group otherwise
1156 (defun spam-check-whitelist ()
1157   ;; FIXME!  Should it detect when file timestamps change?
1158   (unless spam-whitelist-cache
1159     (setq spam-whitelist-cache (spam-parse-list spam-whitelist)))
1160   (if (spam-from-listed-p spam-whitelist-cache)
1161       t
1162     (if spam-use-whitelist-exclusive
1163         spam-split-group
1164       nil)))
1165
1166 (defun spam-check-blacklist ()
1167   ;; FIXME!  Should it detect when file timestamps change?
1168   (unless spam-blacklist-cache
1169     (setq spam-blacklist-cache (spam-parse-list spam-blacklist)))
1170   (and (spam-from-listed-p spam-blacklist-cache) spam-split-group))
1171
1172 (defun spam-parse-list (file)
1173   (when (file-readable-p file)
1174     (let (contents address)
1175       (with-temp-buffer
1176         (insert-file-contents file)
1177         (while (not (eobp))
1178           (setq address (buffer-substring (point) (spam-point-at-eol)))
1179           (forward-line 1)
1180           ;; insert the e-mail address if detected, otherwise the raw data
1181           (unless (zerop (length address))
1182             (let ((pure-address (cadr (gnus-extract-address-components address))))
1183               (push (or pure-address address) contents)))))
1184       (nreverse contents))))
1185
1186 (defun spam-from-listed-p (cache)
1187   (let ((from (nnmail-fetch-field "from"))
1188         found)
1189     (while cache
1190       (let ((address (pop cache)))
1191         (unless (zerop (length address)) ; 0 for a nil address too
1192           (setq address (regexp-quote address))
1193           ;; fix regexp-quote's treatment of user-intended regexes
1194           (while (string-match "\\\\\\*" address)
1195             (setq address (replace-match ".*" t t address))))
1196         (when (and address (string-match address from))
1197           (setq found t
1198                 cache nil))))
1199     found))
1200
1201 (defun spam-blacklist-register-routine ()
1202   (spam-generic-register-routine
1203    ;; the spam function
1204    (lambda (article)
1205      (spam-log-processing-to-registry
1206       (spam-fetch-field-message-id-fast article)
1207       'process
1208       'spam
1209       'spam-use-blacklist
1210       gnus-newsgroup-name)
1211      (let ((from (spam-fetch-field-from-fast article)))
1212        (when (stringp from)
1213            (spam-enter-blacklist from))))
1214    ;; the ham function
1215    nil))
1216
1217 (defun spam-whitelist-register-routine ()
1218   (spam-generic-register-routine
1219    ;; the spam function
1220    nil
1221    ;; the ham function
1222    (lambda (article)
1223      (spam-log-processing-to-registry
1224       (spam-fetch-field-message-id-fast article)
1225       'process
1226       'ham
1227       'spam-use-whitelist
1228       gnus-newsgroup-name)
1229      (let ((from (spam-fetch-field-from-fast article)))
1230        (when (stringp from)
1231            (spam-enter-whitelist from))))))
1232
1233 \f
1234 ;;;; Spam-report glue
1235 (defun spam-report-gmane-register-routine ()
1236   (spam-generic-register-routine
1237    'spam-report-gmane
1238    nil))
1239
1240 \f
1241 ;;;; Bogofilter
1242 (defun spam-check-bogofilter-headers (&optional score)
1243   (let ((header (nnmail-fetch-field spam-bogofilter-header)))
1244     (when header                        ; return nil when no header
1245       (if score                         ; scoring mode
1246           (if (string-match "spamicity=\\([0-9.]+\\)" header)
1247               (match-string 1 header)
1248             "0")
1249         ;; spam detection mode
1250         (when (string-match spam-bogofilter-bogosity-positive-spam-header
1251                             header)
1252           spam-split-group)))))
1253
1254 ;; return something sensible if the score can't be determined
1255 (defun spam-bogofilter-score ()
1256   "Get the Bogofilter spamicity score"
1257   (interactive)
1258   (save-window-excursion
1259     (gnus-summary-show-article t)
1260     (set-buffer gnus-article-buffer)
1261     (let ((score (or (spam-check-bogofilter-headers t)
1262                      (spam-check-bogofilter t))))
1263       (message "Spamicity score %s" score)
1264       (or score "0"))
1265     (gnus-summary-show-article)))
1266
1267 (defun spam-check-bogofilter (&optional score)
1268   "Check the Bogofilter backend for the classification of this message"
1269   (let ((article-buffer-name (buffer-name))
1270         return)
1271     (with-temp-buffer
1272       (let ((temp-buffer-name (buffer-name)))
1273         (save-excursion
1274           (set-buffer article-buffer-name)
1275           (if spam-bogofilter-database-directory
1276               (call-process-region (point-min) (point-max)
1277                                    spam-bogofilter-path
1278                                    nil temp-buffer-name nil "-v"
1279                                    "-d" spam-bogofilter-database-directory)
1280             (call-process-region (point-min) (point-max) spam-bogofilter-path
1281                                  nil temp-buffer-name nil "-v")))
1282         (setq return (spam-check-bogofilter-headers score))))
1283     return))
1284
1285 (defun spam-bogofilter-register-with-bogofilter (article-string spam)
1286   "Register an article, given as a string, as spam or non-spam."
1287   (when (stringp article-string)
1288     (let ((switch (if spam spam-bogofilter-spam-switch
1289                     spam-bogofilter-ham-switch)))
1290       (with-temp-buffer
1291         (insert article-string)
1292         (if spam-bogofilter-database-directory
1293             (call-process-region (point-min) (point-max)
1294                                  spam-bogofilter-path
1295                                  nil nil nil "-v" switch
1296                                  "-d" spam-bogofilter-database-directory)
1297           (call-process-region (point-min) (point-max) spam-bogofilter-path
1298                                nil nil nil "-v" switch))))))
1299
1300 (defun spam-bogofilter-register-spam-routine ()
1301   (spam-generic-register-routine
1302    (lambda (article)
1303      (spam-log-processing-to-registry
1304       (spam-fetch-field-message-id-fast article)
1305       'process
1306       'spam
1307       'spam-use-bogofilter
1308       gnus-newsgroup-name)
1309      (spam-bogofilter-register-with-bogofilter
1310       (spam-get-article-as-string article) t))
1311    nil))
1312
1313 (defun spam-bogofilter-register-ham-routine ()
1314   (spam-generic-register-routine
1315    nil
1316    (lambda (article)
1317      (spam-log-processing-to-registry
1318       (spam-fetch-field-message-id-fast article)
1319       'process
1320       'ham
1321       'spam-use-bogofilter
1322       gnus-newsgroup-name)
1323      (spam-bogofilter-register-with-bogofilter
1324       (spam-get-article-as-string article) nil))))
1325
1326 \f
1327 ;;;; spamoracle
1328 (defun spam-check-spamoracle ()
1329   "Run spamoracle on an article to determine whether it's spam."
1330   (let ((article-buffer-name (buffer-name)))
1331     (with-temp-buffer
1332       (let ((temp-buffer-name (buffer-name)))
1333         (save-excursion
1334           (set-buffer article-buffer-name)
1335           (let ((status
1336                  (apply 'call-process-region
1337                         (point-min) (point-max)
1338                         spam-spamoracle-binary
1339                         nil temp-buffer-name nil
1340                         (if spam-spamoracle-database
1341                             `("-f" ,spam-spamoracle-database "mark")
1342                           '("mark")))))
1343             (if (zerop status)
1344                 (progn
1345                   (set-buffer temp-buffer-name)
1346                   (goto-char (point-min))
1347                   (when (re-search-forward "^X-Spam: yes;" nil t)
1348                     spam-split-group))
1349               (error "Error running spamoracle" status))))))))
1350
1351 (defun spam-spamoracle-learn (article article-is-spam-p)
1352   "Run spamoracle in training mode."
1353   (with-temp-buffer
1354     (let ((temp-buffer-name (buffer-name)))
1355       (save-excursion
1356         (goto-char (point-min))
1357         (insert (spam-get-article-as-string article))
1358         (let* ((arg (if article-is-spam-p "-spam" "-good"))
1359                (status
1360                 (apply 'call-process-region
1361                        (point-min) (point-max)
1362                        spam-spamoracle-binary
1363                        nil temp-buffer-name nil
1364                        (if spam-spamoracle-database
1365                            `("-f" ,spam-spamoracle-database
1366                              "add" ,arg)
1367                          `("add" ,arg)))))
1368           (when (not (zerop status))
1369             (error "Error running spamoracle" status)))))))
1370
1371 (defun spam-spamoracle-learn-ham ()
1372   (spam-generic-register-routine
1373    nil
1374    (lambda (article)
1375      (spam-log-processing-to-registry
1376       (spam-fetch-field-message-id-fast article)
1377       'process
1378       'ham
1379       'spam-use-spamoracle
1380       gnus-newsgroup-name)
1381      (spam-spamoracle-learn article nil))))
1382
1383 (defun spam-spamoracle-learn-spam ()
1384   (spam-generic-register-routine
1385    (lambda (article)
1386      (spam-log-processing-to-registry
1387       (spam-fetch-field-message-id-fast article)
1388       'process
1389       'spam
1390       'spam-use-spamoracle
1391       gnus-newsgroup-name)
1392      (spam-spamoracle-learn article t))
1393    nil))
1394 \f
1395 ;;;; Hooks
1396
1397 ;;;###autoload
1398 (defun spam-initialize ()
1399   "Install the spam.el hooks and do other initialization"
1400   (interactive)
1401   (setq spam-install-hooks t)
1402   ;; TODO: How do we redo this every time spam-face is customized?
1403   (push '((eq mark gnus-spam-mark) . spam-face)
1404         gnus-summary-highlight)
1405   ;; Add hooks for loading and saving the spam stats
1406   (when spam-use-stat
1407     (add-hook 'gnus-save-newsrc-hook 'spam-maybe-spam-stat-save)
1408     (add-hook 'gnus-get-top-new-news-hook 'spam-maybe-spam-stat-load)
1409     (add-hook 'gnus-startup-hook 'spam-maybe-spam-stat-load))
1410   (add-hook 'gnus-summary-prepare-exit-hook 'spam-summary-prepare-exit)
1411   (add-hook 'gnus-summary-prepare-hook 'spam-summary-prepare)
1412   (add-hook 'gnus-get-new-news-hook 'spam-setup-widening))
1413
1414 (defun spam-unload-hook ()
1415   "Uninstall the spam.el hooks"
1416   (interactive)
1417   (remove-hook 'gnus-save-newsrc-hook 'spam-maybe-spam-stat-save)
1418   (remove-hook 'gnus-get-top-new-news-hook 'spam-maybe-spam-stat-load)
1419   (remove-hook 'gnus-startup-hook 'spam-maybe-spam-stat-load)
1420   (remove-hook 'gnus-summary-prepare-exit-hook 'spam-summary-prepare-exit)
1421   (remove-hook 'gnus-summary-prepare-hook 'spam-summary-prepare)
1422   (remove-hook 'gnus-get-new-news-hook 'spam-setup-widening))
1423
1424 (when spam-install-hooks
1425   (spam-initialize))
1426
1427 (provide 'spam)
1428
1429 ;;; spam.el ends here.