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