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

   1 ;;; spam.el --- Identifying spam
   2
   3 ;; Copyright (C) 2002-2013 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;; Maintainer: Ted Zlatanov <tzz@lifelogs.com>
   7 ;; Keywords: network, spam, mail, bogofilter, BBDB, dspam, dig, whitelist, blacklist, gmane, hashcash, spamassassin, bsfilter, ifile, stat, crm114, spamoracle
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  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 ;; TODO: cross-server splitting, remote processing, training through files
  36
  37 ;;; Code:
  38
  39 ;;{{{ compilation directives and autoloads/requires
  40
  41 ;; For Emacs <22.2 and XEmacs.
  42 (eval-and-compile
  43   (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
  44
  45 (eval-when-compile (require 'cl))
  46
  47 (require 'message)              ;for the message-fetch-field functions
  48 (require 'gnus-sum)
  49 (require 'gnus-uu)                      ; because of key prefix issues
  50 ;;; for the definitions of group content classification and spam processors
  51 (require 'gnus)
  52
  53 (eval-when-compile (require 'hashcash))
  54
  55 ;; for nnimap-split-download-body-default
  56 (eval-when-compile (require 'nnimap))
  57
  58 ;; autoload query-dig
  59 (autoload 'query-dig "dig")
  60
  61 ;; autoload spam-report
  62 (autoload 'spam-report-gmane "spam-report")
  63 (autoload 'spam-report-gmane-spam "spam-report")
  64 (autoload 'spam-report-gmane-ham "spam-report")
  65 (autoload 'spam-report-resend "spam-report")
  66
  67 ;; autoload gnus-registry
  68 (autoload 'gnus-registry-group-count "gnus-registry")
  69 (autoload 'gnus-registry-get-id-key "gnus-registry")
  70 (autoload 'gnus-registry-set-id-key "gnus-registry")
  71 (autoload 'gnus-registry-handle-action "gnus-registry")
  72
  73 ;; autoload dns-query
  74 (autoload 'dns-query "dns")
  75
  76 ;;}}}
  77
  78 ;;{{{ Main parameters.
  79 (defvar spam-backends nil
  80   "List of spam.el backends with all the pertinent data.
  81 Populated by `spam-install-backend-super'.")
  82
  83 (defgroup spam nil
  84   "Spam configuration."
  85   :version "22.1"
  86   :group 'mail
  87   :group 'news)
  88
  89 (defcustom spam-summary-exit-behavior 'default
  90   "Exit behavior at the time of summary exit.
  91 Note that setting the `spam-use-move' or `spam-use-copy' backends on
  92 a group through group/topic parameters overrides this mechanism."
  93   :type '(choice
  94           (const
  95            :tag "Move spam out of all groups and ham out of spam groups"
  96            default)
  97           (const
  98            :tag "Move spam out of all groups and ham out of all groups"
  99            move-all)
 100           (const
 101            :tag "Never move spam or ham out of any groups"
 102            move-none))
 103   :group 'spam)
 104
 105 (defcustom spam-directory (nnheader-concat gnus-directory "spam/")
 106   "Directory for spam whitelists and blacklists."
 107   :type 'directory
 108   :group 'spam)
 109
 110 (defcustom spam-mark-new-messages-in-spam-group-as-spam t
 111   "Whether new messages in a spam group should get the spam-mark."
 112   :type 'boolean
 113   ;; :version "22.1" ;; Gnus 5.10.8 / No Gnus 0.3
 114   :group 'spam)
 115
 116 (defcustom spam-log-to-registry nil
 117   "Whether spam/ham processing should be logged in the registry."
 118   :type 'boolean
 119   :group 'spam)
 120
 121 (defcustom spam-split-symbolic-return nil
 122   "Whether `spam-split' should work with symbols or group names."
 123   :type 'boolean
 124   :group 'spam)
 125
 126 (defcustom spam-split-symbolic-return-positive nil
 127   "Whether `spam-split' should ALWAYS work with symbols or group names.
 128 Do not set this if you use `spam-split' in a fancy split method."
 129   :type 'boolean
 130   :group 'spam)
 131
 132 (defcustom spam-mark-only-unseen-as-spam t
 133   "Whether only unseen articles should be marked as spam in spam groups.
 134 When nil, all unread articles in a spam group are marked as
 135 spam.  Set this if you want to leave an article unread in a spam group
 136 without losing it to the automatic spam-marking process."
 137   :type 'boolean
 138   :group 'spam)
 139
 140 (defcustom spam-mark-ham-unread-before-move-from-spam-group nil
 141   "Whether ham should be marked unread before it's moved.
 142 The article is moved out of a spam group according to `ham-process-destination'.
 143 This variable is an official entry in the international Longest Variable Name
 144 Competition."
 145   :type 'boolean
 146   :group 'spam)
 147
 148 (defcustom spam-disable-spam-split-during-ham-respool nil
 149   "Whether `spam-split' should be ignored while resplitting ham.
 150 This is useful to prevent ham from ending up in the same spam
 151 group after the resplit.  Don't set this to t if you have `spam-split' as the
 152 last rule in your split configuration."
 153   :type 'boolean
 154   :group 'spam)
 155
 156 (defcustom spam-autodetect-recheck-messages nil
 157   "Should spam.el recheck all messages when autodetecting?
 158 Normally this is nil, so only unseen messages will be checked."
 159   :type 'boolean
 160   :group 'spam)
 161
 162 (defcustom spam-whitelist (expand-file-name "whitelist" spam-directory)
 163   "The location of the whitelist.
 164 The file format is one regular expression per line.
 165 The regular expression is matched against the address."
 166   :type 'file
 167   :group 'spam)
 168
 169 (defcustom spam-blacklist (expand-file-name "blacklist" spam-directory)
 170   "The location of the blacklist.
 171 The file format is one regular expression per line.
 172 The regular expression is matched against the address."
 173   :type 'file
 174   :group 'spam)
 175
 176 (defcustom spam-use-dig t
 177   "Whether `query-dig' should be used instead of `dns-query'."
 178   :type 'boolean
 179   :group 'spam)
 180
 181 (defcustom spam-use-gmane-xref nil
 182   "Whether the Gmane spam xref should be used by `spam-split'."
 183   :type 'boolean
 184   :group 'spam)
 185
 186 (defcustom spam-use-blacklist nil
 187   "Whether the blacklist should be used by `spam-split'."
 188   :type 'boolean
 189   :group 'spam)
 190
 191 (defcustom spam-blacklist-ignored-regexes nil
 192   "Regular expressions that the blacklist should ignore."
 193   :type '(repeat (regexp :tag "Regular expression to ignore when blacklisting"))
 194   :group 'spam)
 195
 196 (defcustom spam-use-whitelist nil
 197   "Whether the whitelist should be used by `spam-split'."
 198   :type 'boolean
 199   :group 'spam)
 200
 201 (defcustom spam-use-whitelist-exclusive nil
 202   "Whether whitelist-exclusive should be used by `spam-split'.
 203 Exclusive whitelisting means that all messages from senders not in the whitelist
 204 are considered spam."
 205   :type 'boolean
 206   :group 'spam)
 207
 208 (defcustom spam-use-blackholes nil
 209   "Whether blackholes should be used by `spam-split'."
 210   :type 'boolean
 211   :group 'spam)
 212
 213 (defcustom spam-use-hashcash nil
 214   "Whether hashcash payments should be detected by `spam-split'."
 215   :type 'boolean
 216   :group 'spam)
 217
 218 (defcustom spam-use-regex-headers nil
 219   "Whether a header regular expression match should be used by `spam-split'.
 220 Also see the variables `spam-regex-headers-spam' and `spam-regex-headers-ham'."
 221   :type 'boolean
 222   :group 'spam)
 223
 224 (defcustom spam-use-regex-body nil
 225   "Whether a body regular expression match should be used by `spam-split'.
 226 Also see the variables `spam-regex-body-spam' and `spam-regex-body-ham'."
 227   :type 'boolean
 228   :group 'spam)
 229
 230 (defcustom spam-use-bogofilter-headers nil
 231   "Whether bogofilter headers should be used by `spam-split'.
 232 Enable this if you pre-process messages with Bogofilter BEFORE Gnus sees them."
 233   :type 'boolean
 234   :group 'spam)
 235
 236 (defcustom spam-use-bogofilter nil
 237   "Whether bogofilter should be invoked by `spam-split'.
 238 Enable this if you want Gnus to invoke Bogofilter on new messages."
 239   :type 'boolean
 240   :group 'spam)
 241
 242 (defcustom spam-use-bsfilter-headers nil
 243   "Whether bsfilter headers should be used by `spam-split'.
 244 Enable this if you pre-process messages with Bsfilter BEFORE Gnus sees them."
 245   :type 'boolean
 246   :group 'spam)
 247
 248 (defcustom spam-use-bsfilter nil
 249   "Whether bsfilter should be invoked by `spam-split'.
 250 Enable this if you want Gnus to invoke Bsfilter on new messages."
 251   :type 'boolean
 252   :group 'spam)
 253
 254 (defcustom spam-use-BBDB nil
 255   "Whether BBDB should be used by `spam-split'."
 256   :type 'boolean
 257   :group 'spam)
 258
 259 (defcustom spam-use-BBDB-exclusive nil
 260   "Whether BBDB-exclusive should be used by `spam-split'.
 261 Exclusive BBDB means that all messages from senders not in the BBDB are
 262 considered spam."
 263   :type 'boolean
 264   :group 'spam)
 265
 266 (defcustom spam-use-ifile nil
 267   "Whether ifile should be used by `spam-split'."
 268   :type 'boolean
 269   :group 'spam)
 270
 271 (defcustom spam-use-stat nil
 272   "Whether `spam-stat' should be used by `spam-split'."
 273   :type 'boolean
 274   :group 'spam)
 275
 276 (defcustom spam-use-spamoracle nil
 277   "Whether spamoracle should be used by `spam-split'."
 278   :type 'boolean
 279   :group 'spam)
 280
 281 (defcustom spam-use-spamassassin nil
 282   "Whether spamassassin should be invoked by `spam-split'.
 283 Enable this if you want Gnus to invoke SpamAssassin on new messages."
 284   :type 'boolean
 285   :group 'spam)
 286
 287 (defcustom spam-use-spamassassin-headers nil
 288   "Whether spamassassin headers should be checked by `spam-split'.
 289 Enable this if you pre-process messages with SpamAssassin BEFORE Gnus sees
 290 them."
 291   :type 'boolean
 292   :group 'spam)
 293
 294 (defcustom spam-use-crm114 nil
 295   "Whether the CRM114 Mailfilter should be used by `spam-split'."
 296   :type 'boolean
 297   :group 'spam)
 298
 299 (defcustom spam-install-hooks (or
 300                                spam-use-dig
 301                                spam-use-gmane-xref
 302                                spam-use-blacklist
 303                                spam-use-whitelist
 304                                spam-use-whitelist-exclusive
 305                                spam-use-blackholes
 306                                spam-use-hashcash
 307                                spam-use-regex-headers
 308                                spam-use-regex-body
 309                                spam-use-bogofilter
 310                                spam-use-bogofilter-headers
 311                                spam-use-spamassassin
 312                                spam-use-spamassassin-headers
 313                                spam-use-bsfilter
 314                                spam-use-bsfilter-headers
 315                                spam-use-BBDB
 316                                spam-use-BBDB-exclusive
 317                                spam-use-ifile
 318                                spam-use-stat
 319                                spam-use-spamoracle
 320                                spam-use-crm114)
 321   "Whether the spam hooks should be installed.
 322 Default to t if one of the spam-use-* variables is set."
 323   :group 'spam
 324   :type 'boolean)
 325
 326 (defcustom spam-split-group "spam"
 327   "Group name where incoming spam should be put by `spam-split'."
 328   :type 'string
 329   :group 'spam)
 330
 331 ;;; TODO: deprecate this variable, it's confusing since it's a list of strings,
 332 ;;; not regular expressions
 333 (defcustom spam-junk-mailgroups (cons
 334                                  spam-split-group
 335                                  '("mail.junk" "poste.pourriel"))
 336   "Mailgroups with spam contents.
 337 All unmarked article in such group receive the spam mark on group entry."
 338   :type '(repeat (string :tag "Group"))
 339   :group 'spam)
 340
 341
 342 (defcustom spam-gmane-xref-spam-group "gmane.spam.detected"
 343   "The group where spam xrefs can be found on Gmane.
 344 Only meaningful if you enable `spam-use-gmane-xref'."
 345   :type 'string
 346   :group 'spam)
 347
 348 (defcustom spam-blackhole-servers '("bl.spamcop.net" "relays.ordb.org"
 349                                     "dev.null.dk" "relays.visi.com")
 350   "List of blackhole servers.
 351 Only meaningful if you enable `spam-use-blackholes'."
 352   :type '(repeat (string :tag "Server"))
 353   :group 'spam)
 354
 355 (defcustom spam-blackhole-good-server-regex nil
 356   "String matching IP addresses that should not be checked in the blackholes.
 357 Only meaningful if you enable `spam-use-blackholes'."
 358   :type '(radio (const nil) regexp)
 359   :group 'spam)
 360
 361 (defface spam
 362   '((((class color) (type tty) (background dark))
 363      (:foreground "gray80" :background "gray50"))
 364     (((class color) (type tty) (background light))
 365      (:foreground "gray50" :background "gray80"))
 366     (((class color) (background dark))
 367      (:foreground "ivory2"))
 368     (((class color) (background light))
 369      (:foreground "ivory4"))
 370     (t :inverse-video t))
 371   "Face for spam-marked articles."
 372   :group 'spam)
 373 ;; backward-compatibility alias
 374 (put 'spam-face 'face-alias 'spam)
 375 (put 'spam-face 'obsolete-face "22.1")
 376
 377 (defcustom spam-face 'spam
 378   "Face for spam-marked articles."
 379   :type 'face
 380   :group 'spam)
 381
 382 (defcustom spam-regex-headers-spam '("^X-Spam-Flag: YES")
 383   "Regular expression for positive header spam matches.
 384 Only meaningful if you enable `spam-use-regex-headers'."
 385   :type '(repeat (regexp :tag "Regular expression to match spam header"))
 386   :group 'spam)
 387
 388 (defcustom spam-regex-headers-ham '("^X-Spam-Flag: NO")
 389   "Regular expression for positive header ham matches.
 390 Only meaningful if you enable `spam-use-regex-headers'."
 391   :type '(repeat (regexp :tag "Regular expression to match ham header"))
 392   :group 'spam)
 393
 394 (defcustom spam-regex-body-spam '()
 395   "Regular expression for positive body spam matches.
 396 Only meaningful if you enable `spam-use-regex-body'."
 397   :type '(repeat (regexp :tag "Regular expression to match spam body"))
 398   :group 'spam)
 399
 400 (defcustom spam-regex-body-ham '()
 401   "Regular expression for positive body ham matches.
 402 Only meaningful if you enable `spam-use-regex-body'."
 403   :type '(repeat (regexp :tag "Regular expression to match ham body"))
 404   :group 'spam)
 405
 406 (defcustom spam-summary-score-preferred-header nil
 407   "Preferred header to use for `spam-summary-score'."
 408   :type '(choice :tag "Header name"
 409           (symbol :tag "SpamAssassin etc" X-Spam-Status)
 410           (symbol :tag "Bogofilter"       X-Bogosity)
 411           (const  :tag "No preference, take best guess." nil))
 412   :group 'spam)
 413
 414 (defgroup spam-ifile nil
 415   "Spam ifile configuration."
 416   :group 'spam)
 417
 418 (make-obsolete-variable 'spam-ifile-path 'spam-ifile-program
 419                         "Gnus 5.10.9 (Emacs 22.1)")
 420 (defcustom spam-ifile-program (executable-find "ifile")
 421   "Name of the ifile program."
 422   :type '(choice (file :tag "Location of ifile")
 423                  (const :tag "ifile is not installed"))
 424   :group 'spam-ifile)
 425
 426 (make-obsolete-variable 'spam-ifile-database-path 'spam-ifile-database
 427                         "Gnus 5.10.9 (Emacs 22.1)")
 428 (defcustom spam-ifile-database nil
 429   "File name of the ifile database."
 430   :type '(choice (file :tag "Location of the ifile database")
 431                  (const :tag "Use the default"))
 432   :group 'spam-ifile)
 433
 434 (defcustom spam-ifile-spam-category "spam"
 435   "Name of the spam ifile category."
 436   :type 'string
 437   :group 'spam-ifile)
 438
 439 (defcustom spam-ifile-ham-category nil
 440   "Name of the ham ifile category.
 441 If nil, the current group name will be used."
 442   :type '(choice (string :tag "Use a fixed category")
 443                  (const :tag "Use the current group name"))
 444   :group 'spam-ifile)
 445
 446 (defcustom spam-ifile-all-categories nil
 447   "Whether the ifile check will return all categories, or just spam.
 448 Set this to t if you want to use the `spam-split' invocation of ifile as
 449 your main source of newsgroup names."
 450   :type 'boolean
 451   :group 'spam-ifile)
 452
 453 (defgroup spam-bogofilter nil
 454   "Spam bogofilter configuration."
 455   :group 'spam)
 456
 457 (make-obsolete-variable 'spam-bogofilter-path 'spam-bogofilter-program
 458                         "Gnus 5.10.9 (Emacs 22.1)")
 459 (defcustom spam-bogofilter-program (executable-find "bogofilter")
 460   "Name of the Bogofilter program."
 461   :type '(choice (file :tag "Location of bogofilter")
 462                  (const :tag "Bogofilter is not installed"))
 463   :group 'spam-bogofilter)
 464
 465 (defvar spam-bogofilter-valid 'unknown "Is the bogofilter version valid?")
 466
 467 (defcustom spam-bogofilter-header "X-Bogosity"
 468   "The header that Bogofilter inserts in messages."
 469   :type 'string
 470   :group 'spam-bogofilter)
 471
 472 (defcustom spam-bogofilter-spam-switch "-s"
 473   "The switch that Bogofilter uses to register spam messages."
 474   :type 'string
 475   :group 'spam-bogofilter)
 476
 477 (defcustom spam-bogofilter-ham-switch "-n"
 478   "The switch that Bogofilter uses to register ham messages."
 479   :type 'string
 480   :group 'spam-bogofilter)
 481
 482 (defcustom spam-bogofilter-spam-strong-switch "-S"
 483   "The switch that Bogofilter uses to unregister ham messages."
 484   :type 'string
 485   :group 'spam-bogofilter)
 486
 487 (defcustom spam-bogofilter-ham-strong-switch "-N"
 488   "The switch that Bogofilter uses to unregister spam messages."
 489   :type 'string
 490   :group 'spam-bogofilter)
 491
 492 (defcustom spam-bogofilter-bogosity-positive-spam-header "^\\(Yes\\|Spam\\)"
 493   "The regex on `spam-bogofilter-header' for positive spam identification."
 494   :type 'regexp
 495   :group 'spam-bogofilter)
 496
 497 (defcustom spam-bogofilter-database-directory nil
 498   "Location of the Bogofilter database.
 499 When nil, use the default location."
 500   :type '(choice (directory
 501                   :tag "Location of the Bogofilter database directory")
 502                  (const :tag "Use the default"))
 503   :group 'spam-bogofilter)
 504
 505 (defgroup spam-bsfilter nil
 506   "Spam bsfilter configuration."
 507   :group 'spam)
 508
 509 (make-obsolete-variable 'spam-bsfilter-path 'spam-bsfilter-program
 510                         "Gnus 5.10.9 (Emacs 22.1)")
 511 (defcustom spam-bsfilter-program (executable-find "bsfilter")
 512   "Name of the Bsfilter program."
 513   :type '(choice (file :tag "Location of bsfilter")
 514                  (const :tag "Bsfilter is not installed"))
 515   :group 'spam-bsfilter)
 516
 517 (defcustom spam-bsfilter-header "X-Spam-Flag"
 518   "The header inserted by Bsfilter to flag spam."
 519   :type 'string
 520   :group 'spam-bsfilter)
 521
 522 (defcustom spam-bsfilter-probability-header "X-Spam-Probability"
 523   "The header that Bsfilter inserts in messages."
 524   :type 'string
 525   :group 'spam-bsfilter)
 526
 527 (defcustom spam-bsfilter-spam-switch "--add-spam"
 528   "The switch that Bsfilter uses to register spam messages."
 529   :type 'string
 530   :group 'spam-bsfilter)
 531
 532 (defcustom spam-bsfilter-ham-switch "--add-clean"
 533   "The switch that Bsfilter uses to register ham messages."
 534   :type 'string
 535   :group 'spam-bsfilter)
 536
 537 (defcustom spam-bsfilter-spam-strong-switch "--sub-spam"
 538   "The switch that Bsfilter uses to unregister ham messages."
 539   :type 'string
 540   :group 'spam-bsfilter)
 541
 542 (defcustom spam-bsfilter-ham-strong-switch "--sub-clean"
 543   "The switch that Bsfilter uses to unregister spam messages."
 544   :type 'string
 545   :group 'spam-bsfilter)
 546
 547 (defcustom spam-bsfilter-database-directory nil
 548   "Directory path of the Bsfilter databases."
 549   :type '(choice (directory
 550                   :tag "Location of the Bsfilter database directory")
 551                  (const :tag "Use the default"))
 552   :group 'spam-bsfilter)
 553
 554 (defgroup spam-spamoracle nil
 555   "Spam spamoracle configuration."
 556   :group 'spam)
 557
 558 (defcustom spam-spamoracle-database nil
 559   "Location of spamoracle database file.
 560 When nil, use the default spamoracle database."
 561   :type '(choice (directory :tag "Location of spamoracle database file.")
 562                  (const :tag "Use the default"))
 563   :group 'spam-spamoracle)
 564
 565 (defcustom spam-spamoracle-binary (executable-find "spamoracle")
 566   "Location of the spamoracle binary."
 567   :type '(choice (directory :tag "Location of the spamoracle binary")
 568                  (const :tag "Use the default"))
 569   :group 'spam-spamoracle)
 570
 571 (defgroup spam-spamassassin nil
 572   "Spam SpamAssassin configuration."
 573   :group 'spam)
 574
 575 (make-obsolete-variable 'spam-spamassassin-path
 576   'spam-spamassassin-program "Gnus 5.10.9 (Emacs 22.1)")
 577 (defcustom spam-assassin-program (executable-find "spamassassin")
 578   "Name of the spamassassin program.
 579 Hint: set this to \"spamc\" if you have spamd running.  See the spamc and
 580 spamd man pages for more information on these programs."
 581   :type '(choice (file :tag "Location of spamc")
 582                  (const :tag "spamassassin is not installed"))
 583   :group 'spam-spamassassin)
 584
 585 (defcustom spam-spamassassin-arguments ()
 586   "Arguments to pass to the spamassassin executable.
 587 This must be a list.  For example, `(\"-C\" \"configfile\")'."
 588   :type '(restricted-sexp :match-alternatives (listp))
 589   :group 'spam-spamassassin)
 590
 591 (defcustom spam-spamassassin-spam-flag-header "X-Spam-Flag"
 592   "The header inserted by SpamAssassin to flag spam."
 593   :type 'string
 594   :group 'spam-spamassassin)
 595
 596 (defcustom spam-spamassassin-positive-spam-flag-header "YES"
 597   "The regex on `spam-spamassassin-spam-flag-header' for positive spam
 598 identification"
 599   :type 'string
 600   :group 'spam-spamassassin)
 601
 602 (defcustom spam-spamassassin-spam-status-header "X-Spam-Status"
 603   "The header inserted by SpamAssassin, giving extended scoring information"
 604   :type 'string
 605   :group 'spam-spamassassin)
 606
 607 (make-obsolete-variable 'spam-sa-learn-path 'spam-sa-learn-program
 608                         "Gnus 5.10.9 (Emacs 22.1)")
 609 (defcustom spam-sa-learn-program (executable-find "sa-learn")
 610   "Name of the sa-learn program."
 611   :type '(choice (file :tag "Location of spamassassin")
 612                  (const :tag "spamassassin is not installed"))
 613   :group 'spam-spamassassin)
 614
 615 (defcustom spam-sa-learn-rebuild t
 616   "Whether sa-learn should rebuild the database every time it is called
 617 Enable this if you want sa-learn to rebuild the database automatically.  Doing
 618 this will slightly increase the running time of the spam registration process.
 619 If you choose not to do this, you will have to run \"sa-learn --rebuild\" in
 620 order for SpamAssassin to recognize the new registered spam."
 621   :type 'boolean
 622   :group 'spam-spamassassin)
 623
 624 (defcustom spam-sa-learn-spam-switch "--spam"
 625   "The switch that sa-learn uses to register spam messages."
 626   :type 'string
 627   :group 'spam-spamassassin)
 628
 629 (defcustom spam-sa-learn-ham-switch "--ham"
 630   "The switch that sa-learn uses to register ham messages."
 631   :type 'string
 632   :group 'spam-spamassassin)
 633
 634 (defcustom spam-sa-learn-unregister-switch "--forget"
 635   "The switch that sa-learn uses to unregister messages messages."
 636   :type 'string
 637   :group 'spam-spamassassin)
 638
 639 (defgroup spam-crm114 nil
 640   "Spam CRM114 Mailfilter configuration."
 641   :group 'spam)
 642
 643 (defcustom spam-crm114-program (executable-find "mailfilter.crm")
 644   "File path of the CRM114 Mailfilter executable program."
 645   :type '(choice (file :tag "Location of CRM114 Mailfilter")
 646          (const :tag "CRM114 Mailfilter is not installed"))
 647   :group 'spam-crm114)
 648
 649 (defcustom spam-crm114-header "X-CRM114-Status"
 650   "The header that CRM114 Mailfilter inserts in messages."
 651   :type 'string
 652   :group 'spam-crm114)
 653
 654 (defcustom spam-crm114-spam-switch "--learnspam"
 655   "The switch that CRM114 Mailfilter uses to register spam messages."
 656   :type 'string
 657   :group 'spam-crm114)
 658
 659 (defcustom spam-crm114-ham-switch "--learnnonspam"
 660   "The switch that CRM114 Mailfilter uses to register ham messages."
 661   :type 'string
 662   :group 'spam-crm114)
 663
 664 (defcustom spam-crm114-spam-strong-switch "--unlearn"
 665   "The switch that CRM114 Mailfilter uses to unregister ham messages."
 666   :type 'string
 667   :group 'spam-crm114)
 668
 669 (defcustom spam-crm114-ham-strong-switch "--unlearn"
 670   "The switch that CRM114 Mailfilter uses to unregister spam messages."
 671   :type 'string
 672   :group 'spam-crm114)
 673
 674 (defcustom spam-crm114-positive-spam-header "^SPAM"
 675   "The regex on `spam-crm114-header' for positive spam identification."
 676   :type 'regexp
 677   :group 'spam-crm114)
 678
 679 (defcustom spam-crm114-database-directory nil
 680   "Directory path of the CRM114 Mailfilter databases."
 681   :type '(choice (directory
 682           :tag "Location of the CRM114 Mailfilter database directory")
 683          (const :tag "Use the default"))
 684   :group 'spam-crm114)
 685
 686 ;;; Key bindings for spam control.
 687
 688 (gnus-define-keys gnus-summary-mode-map
 689   "St" spam-generic-score
 690   "Sx" gnus-summary-mark-as-spam
 691   "Mst" spam-generic-score
 692   "Msx" gnus-summary-mark-as-spam
 693   "\M-d" gnus-summary-mark-as-spam
 694   "$" gnus-summary-mark-as-spam)
 695
 696 (defvar spam-cache-lookups t
 697   "Whether spam.el will try to cache lookups using `spam-caches'.")
 698
 699 (defvar spam-caches (make-hash-table
 700                      :size 10
 701                      :test 'equal)
 702   "Cache of spam detection entries.")
 703
 704 (defvar spam-old-articles nil
 705   "List of old ham and spam articles, generated when a group is entered.")
 706
 707 (defvar spam-split-disabled nil
 708   "If non-nil, `spam-split' is disabled, and always returns nil.")
 709
 710 (defvar spam-split-last-successful-check nil
 711   "Internal variable.
 712 `spam-split' will set this to nil or a spam-use-XYZ check if it
 713 finds ham or spam.")
 714
 715 ;; internal variables for backends
 716 ;; TODO: find a way to create these on the fly in spam-install-backend-super
 717 (defvar spam-use-copy nil)
 718 (defvar spam-use-move nil)
 719 (defvar spam-use-gmane nil)
 720 (defvar spam-use-resend nil)
 721
 722 ;;}}}
 723
 724 ;;{{{ convenience functions
 725
 726 (defun spam-clear-cache (symbol)
 727   "Clear the `spam-caches' entry for a check."
 728   (remhash symbol spam-caches))
 729
 730 (defun spam-xor (a b)
 731   "Logical A xor B."
 732   (and (or a b) (not (and a b))))
 733
 734 (defun spam-set-difference (list1 list2)
 735   "Return a set difference of LIST1 and LIST2.
 736 When either list is nil, the other is returned."
 737   (if (and list1 list2)
 738       ;; we have two non-nil lists
 739       (progn
 740         (dolist (item (append list1 list2))
 741           (when (and (memq item list1) (memq item list2))
 742             (setq list1 (delq item list1))
 743             (setq list2 (delq item list2))))
 744         (append list1 list2))
 745     ;; if either of the lists was nil, return the other one
 746     (if list1 list1 list2)))
 747
 748 (defun spam-group-ham-mark-p (group mark &optional spam)
 749   "Checks if MARK is considered a ham mark in GROUP."
 750   (when (stringp group)
 751     (let* ((marks (spam-group-ham-marks group spam))
 752            (marks (if (symbolp mark)
 753                       marks
 754                     (mapcar 'symbol-value marks))))
 755       (memq mark marks))))
 756
 757 (defun spam-group-spam-mark-p (group mark)
 758   "Checks if MARK is considered a spam mark in GROUP."
 759   (spam-group-ham-mark-p group mark t))
 760
 761 (defun spam-group-ham-marks (group &optional spam)
 762   "In GROUP, get all the ham marks."
 763   (when (stringp group)
 764     (let* ((marks (if spam
 765                       (gnus-parameter-spam-marks group)
 766                     (gnus-parameter-ham-marks group)))
 767            (marks (car marks))
 768            (marks (if (listp (car marks)) (car marks) marks)))
 769       marks)))
 770
 771 (defun spam-group-spam-marks (group)
 772   "In GROUP, get all the spam marks."
 773   (spam-group-ham-marks group t))
 774
 775 (defun spam-group-spam-contents-p (group)
 776   "Is GROUP a spam group?"
 777   (if (and (stringp group) (< 0 (length group)))
 778       (or (member group spam-junk-mailgroups)
 779           (memq 'gnus-group-spam-classification-spam
 780                 (gnus-parameter-spam-contents group)))
 781     nil))
 782
 783 (defun spam-group-ham-contents-p (group)
 784   "Is GROUP a ham group?"
 785   (if (stringp group)
 786       (memq 'gnus-group-spam-classification-ham
 787             (gnus-parameter-spam-contents group))
 788     nil))
 789
 790 (defun spam-classifications ()
 791   "Return list of valid classifications"
 792   '(spam ham))
 793
 794 (defun spam-classification-valid-p (classification)
 795   "Is CLASSIFICATION a valid spam/ham classification?"
 796   (memq classification (spam-classifications)))
 797
 798 (defun spam-backend-properties ()
 799   "Return list of valid classifications."
 800   '(statistical mover check hrf srf huf suf))
 801
 802 (defun spam-backend-property-valid-p (property)
 803   "Is PROPERTY a valid backend property?"
 804   (memq property (spam-backend-properties)))
 805
 806 (defun spam-backend-function-type-valid-p (type)
 807   (or (eq type 'registration)
 808       (eq type 'unregistration)))
 809
 810 (defun spam-process-type-valid-p (process-type)
 811   (or (eq process-type 'incoming)
 812       (eq process-type 'process)))
 813
 814 (defun spam-list-articles (articles classification)
 815   (let ((mark-check (if (eq classification 'spam)
 816                         'spam-group-spam-mark-p
 817                       'spam-group-ham-mark-p))
 818         alist mark-cache-yes mark-cache-no)
 819     (dolist (article articles)
 820       (let ((mark (gnus-summary-article-mark article)))
 821         (unless (or (memq mark mark-cache-yes)
 822                     (memq mark mark-cache-no))
 823           (if (funcall mark-check
 824                        gnus-newsgroup-name
 825                        mark)
 826               (push mark mark-cache-yes)
 827             (push mark mark-cache-no)))
 828         (when (memq mark mark-cache-yes)
 829           (push article alist))))
 830     alist))
 831
 832 ;;}}}
 833
 834 ;;{{{ backend installation functions and procedures
 835
 836 (defun spam-install-backend-super (backend &rest properties)
 837   "Install BACKEND for spam.el.
 838 Accepts incoming CHECK, ham registration function HRF, spam
 839 registration function SRF, ham unregistration function HUF, spam
 840 unregistration function SUF, and an indication whether the
 841 backend is STATISTICAL."
 842   (setq spam-backends (add-to-list 'spam-backends backend))
 843   (while properties
 844     (let ((property (pop properties))
 845           (value (pop properties)))
 846       (if (spam-backend-property-valid-p property)
 847           (put backend property value)
 848         (gnus-error
 849          5
 850          "spam-install-backend-super got an invalid property %s"
 851          property)))))
 852
 853 (defun spam-backend-list (&optional type)
 854   "Return a list of all the backend symbols, constrained by TYPE.
 855 When TYPE is 'non-mover, only non-mover backends are returned.
 856 When TYPE is 'mover, only mover backends are returned."
 857   (let (list)
 858     (dolist (backend spam-backends)
 859       (when (or
 860              (null type)                ;either no type was requested
 861              ;; or the type is 'mover and the backend is a mover
 862              (and
 863               (eq type 'mover)
 864               (spam-backend-mover-p backend))
 865              ;; or the type is 'non-mover and the backend is not a mover
 866              (and
 867               (eq type 'non-mover)
 868               (not (spam-backend-mover-p backend))))
 869         (push backend list)))
 870       list))
 871
 872 (defun spam-backend-check (backend)
 873   "Get the check function for BACKEND.
 874 Each individual check may return nil, t, or a mailgroup name.
 875 The value nil means that the check does not yield a decision, and
 876 so, that further checks are needed.  The value t means that the
 877 message is definitely not spam, and that further spam checks
 878 should be inhibited.  Otherwise, a mailgroup name or the symbol
 879 'spam (depending on `spam-split-symbolic-return') is returned where
 880 the mail should go, and further checks are also inhibited.  The
 881 usual mailgroup name is the value of `spam-split-group', meaning
 882 that the message is definitely a spam."
 883   (get backend 'check))
 884
 885 (defun spam-backend-valid-p (backend)
 886   "Is BACKEND valid?"
 887   (member backend (spam-backend-list)))
 888
 889 (defun spam-backend-info (backend)
 890   "Return information about BACKEND."
 891   (if (spam-backend-valid-p backend)
 892       (let (info)
 893         (setq info (format "Backend %s has the following properties:\n"
 894                            backend))
 895         (dolist (property (spam-backend-properties))
 896           (setq info (format "%s%s=%s\n"
 897                              info
 898                              property
 899                              (get backend property))))
 900         info)
 901     (gnus-error 5 "spam-backend-info was asked about an invalid backend %s"
 902                 backend)))
 903
 904 (defun spam-backend-function (backend classification type)
 905   "Get the BACKEND function for CLASSIFICATION and TYPE.
 906 TYPE is 'registration or 'unregistration.
 907 CLASSIFICATION is 'ham or 'spam."
 908   (if (and
 909        (spam-classification-valid-p classification)
 910        (spam-backend-function-type-valid-p type))
 911       (let ((retrieval
 912              (intern
 913               (format "spam-backend-%s-%s-function"
 914                       classification
 915                       type))))
 916         (funcall retrieval backend))
 917     (gnus-error
 918      5
 919      "%s was passed invalid backend %s, classification %s, or type %s"
 920      "spam-backend-function"
 921      backend
 922      classification
 923      type)))
 924
 925 (defun spam-backend-article-list-property (classification
 926                                            &optional unregister)
 927   "Property name of article list with CLASSIFICATION and UNREGISTER."
 928   (let* ((r (if unregister "unregister" "register"))
 929          (prop (format "%s-%s" classification r)))
 930     prop))
 931
 932 (defun spam-backend-get-article-todo-list (backend
 933                                            classification
 934                                            &optional unregister)
 935   "Get the articles to be processed for BACKEND and CLASSIFICATION.
 936 With UNREGISTER, get articles to be unregistered.
 937 This is a temporary storage function - nothing here persists."
 938   (get
 939    backend
 940    (intern (spam-backend-article-list-property classification unregister))))
 941
 942 (defun spam-backend-put-article-todo-list (backend classification list
 943                                                    &optional unregister)
 944   "Set the LIST of articles to be processed for BACKEND and CLASSIFICATION.
 945 With UNREGISTER, set articles to be unregistered.
 946 This is a temporary storage function - nothing here persists."
 947   (put
 948    backend
 949    (intern (spam-backend-article-list-property classification unregister))
 950    list))
 951
 952 (defun spam-backend-ham-registration-function (backend)
 953   "Get the ham registration function for BACKEND."
 954   (get backend 'hrf))
 955
 956 (defun spam-backend-spam-registration-function (backend)
 957   "Get the spam registration function for BACKEND."
 958   (get backend 'srf))
 959
 960 (defun spam-backend-ham-unregistration-function (backend)
 961   "Get the ham unregistration function for BACKEND."
 962   (get backend 'huf))
 963
 964 (defun spam-backend-spam-unregistration-function (backend)
 965   "Get the spam unregistration function for BACKEND."
 966   (get backend 'suf))
 967
 968 (defun spam-backend-statistical-p (backend)
 969   "Is BACKEND statistical?"
 970   (get backend 'statistical))
 971
 972 (defun spam-backend-mover-p (backend)
 973   "Is BACKEND a mover?"
 974   (get backend 'mover))
 975
 976 (defun spam-install-backend-alias (backend alias)
 977   "Add ALIAS to an existing BACKEND.
 978 The previous backend settings for ALIAS are erased."
 979
 980   ;; install alias with no properties at first
 981   (spam-install-backend-super alias)
 982
 983   (dolist (property (spam-backend-properties))
 984     (put alias property (get backend property))))
 985
 986 (defun spam-install-checkonly-backend (backend check)
 987   "Install a BACKEND than can only CHECK for spam."
 988   (spam-install-backend-super backend 'check check))
 989
 990 (defun spam-install-mover-backend (backend hrf srf huf suf)
 991   "Install a BACKEND than can move articles at summary exit.
 992 Accepts ham registration function HRF, spam registration function
 993 SRF, ham unregistration function HUF, spam unregistration
 994 function SUF.  The backend has no incoming check and can't be
 995 statistical."
 996   (spam-install-backend-super
 997    backend
 998    'hrf hrf 'srf srf 'huf huf 'suf suf 'mover t))
 999
1000 (defun spam-install-nocheck-backend (backend hrf srf huf suf)
1001   "Install a BACKEND than has no check.
1002 Accepts ham registration function HRF, spam registration function
1003 SRF, ham unregistration function HUF, spam unregistration
1004 function SUF.  The backend has no incoming check and can't be
1005 statistical (it could be, but in practice that doesn't happen)."
1006   (spam-install-backend-super
1007    backend
1008    'hrf hrf 'srf srf 'huf huf 'suf suf))
1009
1010 (defun spam-install-backend (backend check hrf srf huf suf)
1011   "Install a BACKEND.
1012 Accepts incoming CHECK, ham registration function HRF, spam
1013 registration function SRF, ham unregistration function HUF, spam
1014 unregistration function SUF.  The backend won't be
1015 statistical (use `spam-install-statistical-backend' for that)."
1016   (spam-install-backend-super
1017    backend
1018    'check check 'hrf hrf 'srf srf 'huf huf 'suf suf))
1019
1020 (defun spam-install-statistical-backend (backend check hrf srf huf suf)
1021   "Install a BACKEND.
1022 Accepts incoming CHECK, ham registration function HRF, spam
1023 registration function SRF, ham unregistration function HUF, spam
1024 unregistration function SUF.  The backend will be
1025 statistical (use `spam-install-backend' for non-statistical
1026 backends)."
1027   (spam-install-backend-super
1028    backend
1029    'check check 'statistical t 'hrf hrf 'srf srf 'huf huf 'suf suf))
1030
1031 (defun spam-install-statistical-checkonly-backend (backend check)
1032   "Install a statistical BACKEND than can only CHECK for spam."
1033   (spam-install-backend-super
1034    backend
1035    'check check 'statistical t))
1036
1037 ;;}}}
1038
1039 ;;{{{ backend installations
1040 (spam-install-checkonly-backend 'spam-use-blackholes
1041                                 'spam-check-blackholes)
1042
1043 (spam-install-checkonly-backend 'spam-use-hashcash
1044                                 'spam-check-hashcash)
1045
1046 (spam-install-checkonly-backend 'spam-use-spamassassin-headers
1047                                 'spam-check-spamassassin-headers)
1048
1049 (spam-install-checkonly-backend 'spam-use-bogofilter-headers
1050                                 'spam-check-bogofilter-headers)
1051
1052 (spam-install-checkonly-backend 'spam-use-bsfilter-headers
1053                                 'spam-check-bsfilter-headers)
1054
1055 (spam-install-checkonly-backend 'spam-use-gmane-xref
1056                                 'spam-check-gmane-xref)
1057
1058 (spam-install-checkonly-backend 'spam-use-regex-headers
1059                                 'spam-check-regex-headers)
1060
1061 (spam-install-statistical-checkonly-backend 'spam-use-regex-body
1062                                             'spam-check-regex-body)
1063
1064 ;; TODO: NOTE: spam-use-ham-copy is now obsolete, use (ham spam-use-copy)
1065 (spam-install-mover-backend 'spam-use-move
1066                             'spam-move-ham-routine
1067                             'spam-move-spam-routine
1068                             nil
1069                             nil)
1070
1071 (spam-install-nocheck-backend 'spam-use-copy
1072                               'spam-copy-ham-routine
1073                               'spam-copy-spam-routine
1074                               nil
1075                               nil)
1076
1077 (spam-install-nocheck-backend 'spam-use-gmane
1078                               'spam-report-gmane-unregister-routine
1079                               'spam-report-gmane-register-routine
1080                               'spam-report-gmane-register-routine
1081                               'spam-report-gmane-unregister-routine)
1082
1083 (spam-install-nocheck-backend 'spam-use-resend
1084                               'spam-report-resend-register-ham-routine
1085                               'spam-report-resend-register-routine
1086                               nil
1087                               nil)
1088
1089 (spam-install-backend 'spam-use-BBDB
1090                       'spam-check-BBDB
1091                       'spam-BBDB-register-routine
1092                       nil
1093                       'spam-BBDB-unregister-routine
1094                       nil)
1095
1096 (spam-install-backend-alias 'spam-use-BBDB 'spam-use-BBDB-exclusive)
1097
1098 (spam-install-backend 'spam-use-blacklist
1099                       'spam-check-blacklist
1100                       nil
1101                       'spam-blacklist-register-routine
1102                       nil
1103                       'spam-blacklist-unregister-routine)
1104
1105 (spam-install-backend 'spam-use-whitelist
1106                       'spam-check-whitelist
1107                       'spam-whitelist-register-routine
1108                       nil
1109                       'spam-whitelist-unregister-routine
1110                       nil)
1111
1112 (spam-install-statistical-backend 'spam-use-ifile
1113                                   'spam-check-ifile
1114                                   'spam-ifile-register-ham-routine
1115                                   'spam-ifile-register-spam-routine
1116                                   'spam-ifile-unregister-ham-routine
1117                                   'spam-ifile-unregister-spam-routine)
1118
1119 (spam-install-statistical-backend 'spam-use-spamoracle
1120                                   'spam-check-spamoracle
1121                                   'spam-spamoracle-learn-ham
1122                                   'spam-spamoracle-learn-spam
1123                                   'spam-spamoracle-unlearn-ham
1124                                   'spam-spamoracle-unlearn-spam)
1125
1126 (spam-install-statistical-backend 'spam-use-stat
1127                                   'spam-check-stat
1128                                   'spam-stat-register-ham-routine
1129                                   'spam-stat-register-spam-routine
1130                                   'spam-stat-unregister-ham-routine
1131                                   'spam-stat-unregister-spam-routine)
1132
1133 (spam-install-statistical-backend 'spam-use-spamassassin
1134                                   'spam-check-spamassassin
1135                                   'spam-spamassassin-register-ham-routine
1136                                   'spam-spamassassin-register-spam-routine
1137                                   'spam-spamassassin-unregister-ham-routine
1138                                   'spam-spamassassin-unregister-spam-routine)
1139
1140 (spam-install-statistical-backend 'spam-use-bogofilter
1141                                   'spam-check-bogofilter
1142                                   'spam-bogofilter-register-ham-routine
1143                                   'spam-bogofilter-register-spam-routine
1144                                   'spam-bogofilter-unregister-ham-routine
1145                                   'spam-bogofilter-unregister-spam-routine)
1146
1147 (spam-install-statistical-backend 'spam-use-bsfilter
1148                                   'spam-check-bsfilter
1149                                   'spam-bsfilter-register-ham-routine
1150                                   'spam-bsfilter-register-spam-routine
1151                                   'spam-bsfilter-unregister-ham-routine
1152                                   'spam-bsfilter-unregister-spam-routine)
1153
1154 (spam-install-statistical-backend 'spam-use-crm114
1155                                   'spam-check-crm114
1156                                   'spam-crm114-register-ham-routine
1157                                   'spam-crm114-register-spam-routine
1158                                   'spam-crm114-unregister-ham-routine
1159                                   'spam-crm114-unregister-spam-routine)
1160 ;;}}}
1161
1162 ;;{{{ scoring and summary formatting
1163 (defun spam-necessary-extra-headers ()
1164   "Return the extra headers spam.el thinks are necessary."
1165   (let (list)
1166     (when (or spam-use-spamassassin
1167               spam-use-spamassassin-headers
1168               spam-use-regex-headers)
1169       (push 'X-Spam-Status list))
1170     (when (or spam-use-bogofilter
1171               spam-use-regex-headers)
1172       (push 'X-Bogosity list))
1173     (when (or spam-use-crm114
1174               spam-use-regex-headers)
1175       (push 'X-CRM114-Status list))
1176     list))
1177
1178 (defun spam-user-format-function-S (headers)
1179   (when headers
1180     (format "%3.2f"
1181             (spam-summary-score headers spam-summary-score-preferred-header))))
1182
1183 (defun spam-article-sort-by-spam-status (h1 h2)
1184   "Sort articles by score."
1185   (let (result)
1186     (dolist (header (spam-necessary-extra-headers))
1187       (let ((s1 (spam-summary-score h1 header))
1188             (s2 (spam-summary-score h2 header)))
1189       (unless (= s1 s2)
1190         (setq result (< s1 s2))
1191         (return))))
1192     result))
1193
1194 (defvar spam-spamassassin-score-regexp
1195   ".*\\b\\(?:score\\|hits\\)=\\(-?[0-9.]+\\)"
1196   "Regexp matching SpamAssassin score header.
1197 The first group must match the number.")
1198
1199 (defun spam-extra-header-to-number (header headers)
1200   "Transform an extra HEADER to a number, using list of HEADERS.
1201 Note this has to be fast."
1202   (let ((header-content (gnus-extra-header header headers)))
1203     (if header-content
1204         (cond
1205          ((eq header 'X-Spam-Status)
1206           (string-to-number (gnus-replace-in-string
1207                              header-content
1208                              spam-spamassassin-score-regexp
1209                              "\\1")))
1210          ;; for CRM checking, it's probably faster to just do the string match
1211          ((string-match "( pR: \\([0-9.-]+\\)" header-content)
1212           (- (string-to-number (match-string 1 header-content))))
1213          ((eq header 'X-Bogosity)
1214           (string-to-number (gnus-replace-in-string
1215                              (gnus-replace-in-string
1216                               header-content
1217                               ".*spamicity=" "")
1218                              ",.*" "")))
1219          (t nil))
1220       nil)))
1221
1222 (defun spam-summary-score (headers &optional specific-header)
1223   "Score an article for the summary buffer, as fast as possible.
1224 With SPECIFIC-HEADER, returns only that header's score.
1225 Will not return a nil score."
1226   (let (score)
1227     (dolist (header
1228              (if specific-header
1229                  (list specific-header)
1230                (spam-necessary-extra-headers)))
1231       (setq score
1232             (spam-extra-header-to-number header headers))
1233       (when score
1234         (return)))
1235     (or score 0)))
1236
1237 (defun spam-generic-score (&optional recheck)
1238   "Invoke whatever scoring method we can."
1239   (interactive "P")
1240   (cond
1241    ((or spam-use-spamassassin spam-use-spamassassin-headers)
1242     (spam-spamassassin-score recheck))
1243    ((or spam-use-bsfilter spam-use-bsfilter-headers)
1244     (spam-bsfilter-score recheck))
1245    (spam-use-crm114
1246     (spam-crm114-score))
1247    (t (spam-bogofilter-score recheck))))
1248 ;;}}}
1249
1250 ;;{{{ set up widening, processor checks
1251
1252 ;;; set up IMAP widening if it's necessary
1253 (defun spam-setup-widening ()
1254   (when (spam-widening-needed-p)
1255     (setq nnimap-split-download-body-default t)))
1256
1257 (defun spam-widening-needed-p (&optional force-symbols)
1258   (let (found)
1259     (dolist (backend (spam-backend-list))
1260       (when (and (spam-backend-statistical-p backend)
1261                  (or (symbol-value backend)
1262                      (memq backend force-symbols)))
1263         (setq found backend)))
1264     found))
1265
1266 (defvar spam-list-of-processors
1267   ;; note the nil processors are not defined in gnus.el
1268   '((gnus-group-spam-exit-processor-bogofilter   spam spam-use-bogofilter)
1269     (gnus-group-spam-exit-processor-bsfilter     spam spam-use-bsfilter)
1270     (gnus-group-spam-exit-processor-blacklist    spam spam-use-blacklist)
1271     (gnus-group-spam-exit-processor-ifile        spam spam-use-ifile)
1272     (gnus-group-spam-exit-processor-stat         spam spam-use-stat)
1273     (gnus-group-spam-exit-processor-spamoracle   spam spam-use-spamoracle)
1274     (gnus-group-spam-exit-processor-spamassassin spam spam-use-spamassassin)
1275     (gnus-group-spam-exit-processor-report-gmane spam spam-use-gmane) ;; Buggy?
1276     (gnus-group-ham-exit-processor-ifile         ham spam-use-ifile)
1277     (gnus-group-ham-exit-processor-bogofilter    ham spam-use-bogofilter)
1278     (gnus-group-ham-exit-processor-bsfilter      ham spam-use-bsfilter)
1279     (gnus-group-ham-exit-processor-stat          ham spam-use-stat)
1280     (gnus-group-ham-exit-processor-whitelist     ham spam-use-whitelist)
1281     (gnus-group-ham-exit-processor-BBDB          ham spam-use-BBDB)
1282     (gnus-group-ham-exit-processor-copy          ham spam-use-ham-copy)
1283     (gnus-group-ham-exit-processor-spamassassin  ham spam-use-spamassassin)
1284     (gnus-group-ham-exit-processor-spamoracle    ham spam-use-spamoracle))
1285   "The OBSOLETE `spam-list-of-processors' list.
1286 This list contains pairs associating the obsolete ham/spam exit
1287 processor variables with a classification and a spam-use-*
1288 variable.  When the processor variable is nil, just the
1289 classification and spam-use-* check variable are used.  This is
1290 superseded by the new spam backend code, so it's only consulted
1291 for backwards compatibility.")
1292 (make-obsolete-variable 'spam-list-of-processors nil "22.1")
1293
1294 (defun spam-group-processor-p (group backend &optional classification)
1295   "Checks if GROUP has a BACKEND with CLASSIFICATION registered.
1296 Also accepts the obsolete processors, which can be found in
1297 gnus.el and in spam-list-of-processors.  In the case of mover
1298 backends, checks the setting of `spam-summary-exit-behavior' in
1299 addition to the set values for the group."
1300   (if (and (stringp group)
1301            (symbolp backend))
1302       (let ((old-style (assq backend spam-list-of-processors))
1303             (parameters (nth 0 (gnus-parameter-spam-process group)))
1304             found)
1305         (if old-style  ; old-style processor
1306             (spam-group-processor-p group (nth 2 old-style) (nth 1 old-style))
1307           ;; now search for the parameter
1308           (dolist (parameter parameters)
1309             (when (and (null found)
1310                        (listp parameter)
1311                        (eq classification (nth 0 parameter))
1312                        (eq backend (nth 1 parameter)))
1313               (setq found t)))
1314
1315           ;; now, if the parameter was not found, do the
1316           ;; spam-summary-exit-behavior-logic for mover backends
1317           (unless found
1318             (when (spam-backend-mover-p backend)
1319               (setq
1320                found
1321                (cond
1322                 ((eq spam-summary-exit-behavior 'move-all) t)
1323                 ((eq spam-summary-exit-behavior 'move-none) nil)
1324                 ((eq spam-summary-exit-behavior 'default)
1325                  (or (eq classification 'spam) ;move spam out of all groups
1326                      ;; move ham out of spam groups
1327                      (and (eq classification 'ham)
1328                           (spam-group-spam-contents-p group))))
1329                 (t (gnus-error 5 "Unknown spam-summary-exit-behavior: %s"
1330                                spam-summary-exit-behavior))))))
1331
1332           found))
1333     nil))
1334
1335 ;;}}}
1336
1337 ;;{{{ Summary entry and exit processing.
1338
1339 (defun spam-mark-junk-as-spam-routine ()
1340   ;; check the global list of group names spam-junk-mailgroups and the
1341   ;; group parameters
1342   (when (spam-group-spam-contents-p gnus-newsgroup-name)
1343     (gnus-message 6 "Marking %s articles as spam"
1344                   (if spam-mark-only-unseen-as-spam
1345                       "unseen"
1346                     "unread"))
1347     (let ((articles (if spam-mark-only-unseen-as-spam
1348                         gnus-newsgroup-unseen
1349                       gnus-newsgroup-unreads)))
1350       (if spam-mark-new-messages-in-spam-group-as-spam
1351           (dolist (article articles)
1352             (gnus-summary-mark-article article gnus-spam-mark))
1353         (gnus-message 9 "Did not mark new messages as spam.")))))
1354
1355 (defun spam-summary-prepare ()
1356   (setq spam-old-articles
1357         (list (cons 'ham (spam-list-articles gnus-newsgroup-articles 'ham))
1358               (cons 'spam (spam-list-articles gnus-newsgroup-articles 'spam))))
1359   (spam-mark-junk-as-spam-routine))
1360
1361 ;; The spam processors are invoked for any group, spam or ham or neither
1362 (defun spam-summary-prepare-exit ()
1363   (unless gnus-group-is-exiting-without-update-p
1364     (gnus-message 6 "Exiting summary buffer and applying spam rules")
1365
1366     ;; before we begin, remove any article limits
1367 ;    (ignore-errors
1368 ;      (gnus-summary-pop-limit t))
1369
1370     ;; first of all, unregister any articles that are no longer ham or spam
1371     ;; we have to iterate over the processors, or else we'll be too slow
1372     (dolist (classification (spam-classifications))
1373       (let* ((old-articles (cdr-safe (assq classification spam-old-articles)))
1374              (new-articles (spam-list-articles
1375                             gnus-newsgroup-articles
1376                             classification))
1377              (changed-articles (spam-set-difference new-articles old-articles)))
1378         ;; now that we have the changed articles, we go through the processors
1379         (dolist (backend (spam-backend-list))
1380           (let (unregister-list)
1381             (dolist (article changed-articles)
1382               (let ((id (spam-fetch-field-message-id-fast article)))
1383                 (when (spam-log-unregistration-needed-p
1384                        id 'process classification backend)
1385                   (push article unregister-list))))
1386             ;; call spam-register-routine with specific articles to unregister,
1387             ;; when there are articles to unregister and the check is enabled
1388             (when (and unregister-list (symbol-value backend))
1389               (spam-backend-put-article-todo-list backend
1390                                                   classification
1391                                                   unregister-list
1392                                                   t))))))
1393
1394     ;; do the non-moving backends first, then the moving ones
1395     (dolist (backend-type '(non-mover mover))
1396       (dolist (classification (spam-classifications))
1397         (dolist (backend (spam-backend-list backend-type))
1398           (when (spam-group-processor-p
1399                  gnus-newsgroup-name
1400                  backend
1401                  classification)
1402             (spam-backend-put-article-todo-list backend
1403                                                 classification
1404                                                 (spam-list-articles
1405                                                  gnus-newsgroup-articles
1406                                                  classification))))))
1407
1408     (spam-resolve-registrations-routine) ; do the registrations now
1409
1410     ;; we mark all the leftover spam articles as expired at the end
1411     (dolist (article (spam-list-articles
1412                       gnus-newsgroup-articles
1413                       'spam))
1414       (gnus-summary-mark-article article gnus-expirable-mark)))
1415
1416   (setq spam-old-articles nil))
1417
1418 ;;}}}
1419
1420 ;;{{{ spam-use-move and spam-use-copy backend support functions
1421
1422 (defun spam-copy-or-move-routine (copy groups articles classification)
1423
1424   (when (and (car-safe groups) (listp (car-safe groups)))
1425     (setq groups (pop groups)))
1426
1427   (unless (listp groups)
1428     (setq groups (list groups)))
1429
1430     ;; remove the current process mark
1431   (gnus-summary-kill-process-mark)
1432
1433   (let ((backend-supports-deletions
1434          (gnus-check-backend-function
1435           'request-move-article gnus-newsgroup-name))
1436         (respool-method (gnus-find-method-for-group gnus-newsgroup-name))
1437         article mark deletep respool valid-move-destinations)
1438
1439     (when (member 'respool groups)
1440       (setq respool t)                  ; boolean for later
1441       (setq groups '("fake"))) ; when respooling, groups are dynamic so fake it
1442
1443     ;; exclude invalid move destinations
1444     (dolist (group groups)
1445       (unless
1446           (or
1447            (and
1448             (eq classification 'spam)
1449             (spam-group-spam-contents-p gnus-newsgroup-name)
1450             (spam-group-spam-contents-p group)
1451             (gnus-message
1452              3
1453              "Sorry, can't move spam from spam group %s to spam group %s"
1454              gnus-newsgroup-name
1455              group))
1456            (and
1457             (eq classification 'ham)
1458             (spam-group-ham-contents-p gnus-newsgroup-name)
1459             (spam-group-ham-contents-p group)
1460             (gnus-message
1461              3
1462              "Sorry, can't move ham from ham group %s to ham group %s"
1463              gnus-newsgroup-name
1464              group)))
1465         (push group valid-move-destinations)))
1466
1467     (setq groups (nreverse valid-move-destinations))
1468
1469     ;; now do the actual move
1470     (dolist (group groups)
1471
1472       (when (and articles (stringp group))
1473
1474         ;; first, mark the article with the process mark and, if needed,
1475         ;; the unread or expired mark (for ham and spam respectively)
1476         (dolist (article articles)
1477           (when (and (eq classification 'ham)
1478                      spam-mark-ham-unread-before-move-from-spam-group)
1479             (gnus-message 9 "Marking ham article %d unread before move"
1480                           article)
1481             (gnus-summary-mark-article article gnus-unread-mark))
1482           (when (and (eq classification 'spam)
1483                      (not copy))
1484             (gnus-message 9 "Marking spam article %d expirable before move"
1485                           article)
1486             (gnus-summary-mark-article article gnus-expirable-mark))
1487           (gnus-summary-set-process-mark article)
1488
1489           (if respool              ; respooling is with a "fake" group
1490               (let ((spam-split-disabled
1491                      (or spam-split-disabled
1492                          (and (eq classification 'ham)
1493                               spam-disable-spam-split-during-ham-respool))))
1494                 (gnus-message 9 "Respooling article %d with method %s"
1495                               article respool-method)
1496                 (gnus-summary-respool-article nil respool-method))
1497             ;; else, we are not respooling
1498             (if (or (not backend-supports-deletions)
1499                     (> (length groups) 1))
1500                 (progn              ; if copying, copy and set deletep
1501                   (gnus-message 9 "Copying article %d to group %s"
1502                                 article group)
1503                   (gnus-summary-copy-article nil group)
1504                   (setq deletep t))
1505               (gnus-message 9 "Moving article %d to group %s"
1506                             article group)
1507               (gnus-summary-move-article nil group)))))) ; else move articles
1508
1509     ;; now delete the articles, unless a) copy is t, and there was a copy done
1510     ;;                                 b) a move was done to a single group
1511     ;;                                 c) backend-supports-deletions is nil
1512     (unless copy
1513       (when (and deletep backend-supports-deletions)
1514         (dolist (article articles)
1515           (gnus-summary-set-process-mark article)
1516           (gnus-message 9 "Deleting article %d" article))
1517         (when articles
1518           (let ((gnus-novice-user nil)) ; don't ask me if I'm sure
1519             (gnus-summary-delete-article nil)))))
1520     (gnus-summary-yank-process-mark)
1521     (length articles)))
1522
1523 (defun spam-copy-spam-routine (articles)
1524   (spam-copy-or-move-routine
1525    t
1526    (gnus-parameter-spam-process-destination gnus-newsgroup-name)
1527    articles
1528    'spam))
1529
1530 (defun spam-move-spam-routine (articles)
1531   (spam-copy-or-move-routine
1532    nil
1533    (gnus-parameter-spam-process-destination gnus-newsgroup-name)
1534    articles
1535    'spam))
1536
1537 (defun spam-copy-ham-routine (articles)
1538   (spam-copy-or-move-routine
1539    t
1540    (gnus-parameter-ham-process-destination gnus-newsgroup-name)
1541    articles
1542    'ham))
1543
1544 (defun spam-move-ham-routine (articles)
1545   (spam-copy-or-move-routine
1546    nil
1547    (gnus-parameter-ham-process-destination gnus-newsgroup-name)
1548    articles
1549    'ham))
1550
1551 ;;}}}
1552
1553 ;;{{{ article and field retrieval code
1554 (defun spam-get-article-as-string (article)
1555   (when (numberp article)
1556     (with-temp-buffer
1557       (gnus-request-article-this-buffer
1558        article
1559        gnus-newsgroup-name)
1560       (buffer-string))))
1561
1562 ;; disabled for now
1563 ;; (defun spam-get-article-as-filename (article)
1564 ;;   (let ((article-filename))
1565 ;;     (when (numberp article)
1566 ;;       (nnml-possibly-change-directory
1567 ;;        (gnus-group-real-name gnus-newsgroup-name))
1568 ;;       (setq article-filename (expand-file-name
1569 ;;                              (int-to-string article) nnml-current-directory)))
1570 ;;     (if (file-exists-p article-filename)
1571 ;;      article-filename
1572 ;;       nil)))
1573
1574 (defun spam-fetch-field-fast (article field &optional prepared-data-header)
1575   "Fetch a FIELD for ARTICLE with the internal `gnus-data-list' function.
1576 When PREPARED-DATA-HEADER is given, don't look in the Gnus data.
1577 When FIELD is 'number, ARTICLE can be any number (since we want
1578 to find it out)."
1579   (when (numberp article)
1580     (let* ((data-header (or prepared-data-header
1581                             (spam-fetch-article-header article))))
1582       (cond
1583        ((not (arrayp data-header))
1584         (gnus-message 6 "Article %d has a nil data header" article))
1585        ((equal field 'number)
1586         (mail-header-number data-header))
1587        ((equal field 'from)
1588         (mail-header-from data-header))
1589        ((equal field 'message-id)
1590         (mail-header-message-id data-header))
1591        ((equal field 'subject)
1592         (mail-header-subject data-header))
1593        ((equal field 'references)
1594         (mail-header-references data-header))
1595        ((equal field 'date)
1596         (mail-header-date data-header))
1597        ((equal field 'xref)
1598         (mail-header-xref data-header))
1599        ((equal field 'extra)
1600         (mail-header-extra data-header))
1601        (t
1602         (gnus-error
1603          5
1604          "spam-fetch-field-fast: unknown field %s requested"
1605          field)
1606         nil)))))
1607
1608 (defun spam-fetch-field-from-fast (article &optional prepared-data-header)
1609   (spam-fetch-field-fast article 'from prepared-data-header))
1610
1611 (defun spam-fetch-field-subject-fast (article &optional prepared-data-header)
1612   (spam-fetch-field-fast article 'subject prepared-data-header))
1613
1614 (defun spam-fetch-field-message-id-fast (article &optional prepared-data-header)
1615   (spam-fetch-field-fast article 'message-id prepared-data-header))
1616
1617 (defun spam-generate-fake-headers (article)
1618   (let ((dh (spam-fetch-article-header article)))
1619     (if dh
1620         (concat
1621          (format
1622           ;; 80-character limit makes for strange constructs
1623           (concat "From: %s\nSubject: %s\nMessage-ID: %s\n"
1624                   "Date: %s\nReferences: %s\nXref: %s\n")
1625           (spam-fetch-field-fast article 'from dh)
1626           (spam-fetch-field-fast article 'subject dh)
1627           (spam-fetch-field-fast article 'message-id dh)
1628           (spam-fetch-field-fast article 'date dh)
1629           (spam-fetch-field-fast article 'references dh)
1630           (spam-fetch-field-fast article 'xref dh))
1631          (when (spam-fetch-field-fast article 'extra dh)
1632            (format "%s\n" (spam-fetch-field-fast article 'extra dh))))
1633       (gnus-message
1634        5
1635        "spam-generate-fake-headers: article %d didn't have a valid header"
1636        article))))
1637
1638 (defun spam-fetch-article-header (article)
1639   (with-current-buffer gnus-summary-buffer
1640     (gnus-read-header article)
1641     (nth 3 (assq article gnus-newsgroup-data))))
1642 ;;}}}
1643
1644 ;;{{{ Spam determination.
1645
1646 (defun spam-split (&rest specific-checks)
1647   "Split this message into the `spam' group if it is spam.
1648 This function can be used as an entry in the variable `nnmail-split-fancy',
1649 for example like this: (: spam-split).  It can take checks as
1650 parameters.  A string as a parameter will set the
1651 `spam-split-group' to that string.
1652
1653 See the Info node `(gnus)Fancy Mail Splitting' for more details."
1654   (interactive)
1655   (setq spam-split-last-successful-check nil)
1656   (unless spam-split-disabled
1657     (let ((spam-split-group-choice spam-split-group))
1658       (dolist (check specific-checks)
1659         (when (stringp check)
1660           (setq spam-split-group-choice check)
1661           (setq specific-checks (delq check specific-checks))))
1662
1663       (let ((spam-split-group spam-split-group-choice)
1664             (widening-needed-check (spam-widening-needed-p specific-checks)))
1665         (save-excursion
1666           (save-restriction
1667             (when widening-needed-check
1668               (widen)
1669               (gnus-message 8 "spam-split: widening the buffer (%s requires it)"
1670                             widening-needed-check))
1671             (let ((backends (spam-backend-list))
1672                   decision)
1673               (while (and backends (not decision))
1674                 (let* ((backend (pop backends))
1675                        (check-function (spam-backend-check backend))
1676                        (spam-split-group (if spam-split-symbolic-return
1677                                              'spam
1678                                            spam-split-group)))
1679                   (when (or
1680                          ;; either, given specific checks, this is one of them
1681                          (memq backend specific-checks)
1682                          ;; or, given no specific checks, spam-use-CHECK is set
1683                          (and (null specific-checks) (symbol-value backend)))
1684                     (gnus-message 6 "spam-split: calling the %s function"
1685                                   check-function)
1686                     (setq decision (funcall check-function))
1687                     ;; if we got a decision at all, save the current check
1688                     (when decision
1689                       (setq spam-split-last-successful-check backend))
1690
1691                     (when (eq decision 'spam)
1692                       (unless spam-split-symbolic-return
1693                         (gnus-error
1694                          5
1695                          (format "spam-split got %s but %s is nil"
1696                                  decision
1697                                  spam-split-symbolic-return)))))))
1698               (if (eq decision t)
1699                   (if spam-split-symbolic-return-positive 'ham nil)
1700                 decision))))))))
1701
1702 (defun spam-find-spam ()
1703   "Detect spam in the current newsgroup using `spam-split'."
1704   (interactive)
1705
1706   (let* ((group gnus-newsgroup-name)
1707          (autodetect (gnus-parameter-spam-autodetect group))
1708          (methods (gnus-parameter-spam-autodetect-methods group))
1709          (first-method (nth 0 methods))
1710          (articles (if spam-autodetect-recheck-messages
1711                        gnus-newsgroup-articles
1712                      gnus-newsgroup-unseen))
1713          article-cannot-be-faked)
1714
1715
1716     (dolist (backend methods)
1717       (when (spam-backend-statistical-p backend)
1718         (setq article-cannot-be-faked t)
1719         (return)))
1720
1721     (when (memq 'default methods)
1722       (setq article-cannot-be-faked t))
1723
1724     (when (and autodetect
1725                (not (equal first-method 'none)))
1726       (mapcar
1727        (lambda (article)
1728          (let ((id (spam-fetch-field-message-id-fast article))
1729                (subject (spam-fetch-field-subject-fast article))
1730                (sender (spam-fetch-field-from-fast article))
1731                registry-lookup)
1732
1733            (unless id
1734              (gnus-message 6 "Article %d has no message ID!" article))
1735
1736            (when (and id spam-log-to-registry)
1737              (setq registry-lookup (spam-log-registration-type id 'incoming))
1738              (when registry-lookup
1739                (gnus-message
1740                 9
1741                 "spam-find-spam: message %s was already registered incoming"
1742                 id)))
1743
1744            (let* ((spam-split-symbolic-return t)
1745                   (spam-split-symbolic-return-positive t)
1746                   (fake-headers (spam-generate-fake-headers article))
1747                   (split-return
1748                    (or registry-lookup
1749                        (with-temp-buffer
1750                          (if article-cannot-be-faked
1751                              (gnus-request-article-this-buffer
1752                               article
1753                               group)
1754                            ;; else, we fake the article
1755                            (when fake-headers (insert fake-headers)))
1756                          (if (or (null first-method)
1757                                  (equal first-method 'default))
1758                              (spam-split)
1759                            (apply 'spam-split methods))))))
1760              (if (equal split-return 'spam)
1761                  (gnus-summary-mark-article article gnus-spam-mark))
1762
1763              (when (and id split-return spam-log-to-registry)
1764                (when (zerop (gnus-registry-group-count id))
1765                  (gnus-registry-handle-action id nil group subject sender))
1766
1767                (unless registry-lookup
1768                  (spam-log-processing-to-registry
1769                   id
1770                   'incoming
1771                   split-return
1772                   spam-split-last-successful-check
1773                   group))))))
1774        articles))))
1775
1776 ;;}}}
1777
1778 ;;{{{ registration/unregistration functions
1779
1780 (defun spam-resolve-registrations-routine ()
1781   "Go through the backends and register or unregister articles as needed."
1782   (dolist (backend-type '(non-mover mover))
1783     (dolist (classification (spam-classifications))
1784       (dolist (backend (spam-backend-list backend-type))
1785         (let ((rlist (spam-backend-get-article-todo-list
1786                       backend classification))
1787               (ulist (spam-backend-get-article-todo-list
1788                       backend classification t))
1789               (delcount 0))
1790
1791           ;; clear the old lists right away
1792           (spam-backend-put-article-todo-list backend
1793                                               classification
1794                                               nil
1795                                               nil)
1796           (spam-backend-put-article-todo-list backend
1797                                               classification
1798                                               nil
1799                                               t)
1800
1801           ;; eliminate duplicates
1802           (dolist (article (copy-sequence ulist))
1803             (when (memq article rlist)
1804               (incf delcount)
1805               (setq rlist (delq article rlist))
1806               (setq ulist (delq article ulist))))
1807
1808           (unless (zerop delcount)
1809             (gnus-message
1810              9
1811              "%d messages did not have to unregister and then register"
1812              delcount))
1813
1814           ;; unregister articles
1815           (unless (zerop (length ulist))
1816             (let ((num (spam-unregister-routine classification backend ulist)))
1817               (when (> num 0)
1818                 (gnus-message
1819                  6
1820                  "%d %s messages were unregistered by backend %s."
1821                  num
1822                  classification
1823                  backend))))
1824
1825             ;; register articles
1826             (unless (zerop (length rlist))
1827               (let ((num (spam-register-routine classification backend rlist)))
1828                 (when (> num 0)
1829                   (gnus-message
1830                    6
1831                    "%d %s messages were registered by backend %s."
1832                    num
1833                    classification
1834                    backend)))))))))
1835
1836 (defun spam-unregister-routine (classification
1837                                 backend
1838                                 specific-articles)
1839   (spam-register-routine classification backend specific-articles t))
1840
1841 (defun spam-register-routine (classification
1842                               backend
1843                               specific-articles
1844                               &optional unregister)
1845   (when (and (spam-classification-valid-p classification)
1846              (spam-backend-valid-p backend))
1847     (let* ((register-function
1848             (spam-backend-function backend classification 'registration))
1849            (unregister-function
1850             (spam-backend-function backend classification 'unregistration))
1851            (run-function (if unregister
1852                              unregister-function
1853                            register-function))
1854            (log-function (if unregister
1855                              'spam-log-undo-registration
1856                            'spam-log-processing-to-registry))
1857            article articles)
1858
1859       (when run-function
1860         ;; make list of articles, using specific-articles if given
1861         (setq articles (or specific-articles
1862                            (spam-list-articles
1863                             gnus-newsgroup-articles
1864                             classification)))
1865         ;; process them
1866         (when (> (length articles) 0)
1867           (gnus-message 5 "%s %d %s articles as %s using backend %s"
1868                         (if unregister "Unregistering" "Registering")
1869                         (length articles)
1870                         (if specific-articles "specific" "")
1871                         classification
1872                         backend)
1873           (funcall run-function articles)
1874           ;; now log all the registrations (or undo them, depending on
1875           ;; unregister)
1876           (dolist (article articles)
1877             (funcall log-function
1878                      (spam-fetch-field-message-id-fast article)
1879                      'process
1880                      classification
1881                      backend
1882                      gnus-newsgroup-name))))
1883       ;; return the number of articles processed
1884       (length articles))))
1885
1886 ;;; log a ham- or spam-processor invocation to the registry
1887 (defun spam-log-processing-to-registry (id type classification backend group)
1888   (when spam-log-to-registry
1889     (if (and (stringp id)
1890              (stringp group)
1891              (spam-process-type-valid-p type)
1892              (spam-classification-valid-p classification)
1893              (spam-backend-valid-p backend))
1894         (let ((cell-list (gnus-registry-get-id-key id type))
1895               (cell (list classification backend group)))
1896           (push cell cell-list)
1897           (gnus-registry-set-id-key id type cell-list))
1898
1899       (gnus-error
1900        7
1901        (format
1902         "%s call with bad ID, type, classification, spam-backend, or group"
1903         "spam-log-processing-to-registry")))))
1904
1905 ;;; check if a ham- or spam-processor registration has been done
1906 (defun spam-log-registered-p (id type)
1907   (when spam-log-to-registry
1908     (if (and (stringp id)
1909              (spam-process-type-valid-p type))
1910         (gnus-registry-get-id-key id type)
1911       (progn
1912         (gnus-error
1913          7
1914          (format "%s called with bad ID, type, classification, or spam-backend"
1915                  "spam-log-registered-p"))
1916         nil))))
1917
1918 ;;; check what a ham- or spam-processor registration says
1919 ;;; returns nil if conflicting registrations are found
1920 (defun spam-log-registration-type (id type)
1921   (let ((count 0)
1922         decision)
1923     (dolist (reg (spam-log-registered-p id type))
1924       (let ((classification (nth 0 reg)))
1925         (when (spam-classification-valid-p classification)
1926           (when (and decision
1927                      (not (eq classification decision)))
1928             (setq count (+ 1 count)))
1929           (setq decision classification))))
1930     (if (< 0 count)
1931         nil
1932       decision)))
1933
1934
1935 ;;; check if a ham- or spam-processor registration needs to be undone
1936 (defun spam-log-unregistration-needed-p (id type classification backend)
1937   (when spam-log-to-registry
1938     (if (and (stringp id)
1939              (spam-process-type-valid-p type)
1940              (spam-classification-valid-p classification)
1941              (spam-backend-valid-p backend))
1942         (let ((cell-list (gnus-registry-get-id-key id type))
1943               found)
1944           (dolist (cell cell-list)
1945             (unless found
1946               (when (and (eq classification (nth 0 cell))
1947                          (eq backend (nth 1 cell)))
1948                 (setq found t))))
1949           found)
1950       (progn
1951         (gnus-error
1952          7
1953          (format "%s called with bad ID, type, classification, or spam-backend"
1954                  "spam-log-unregistration-needed-p"))
1955         nil))))
1956
1957
1958 ;;; undo a ham- or spam-processor registration (the group is not used)
1959 (defun spam-log-undo-registration (id type classification backend
1960                                       &optional group)
1961   (when (and spam-log-to-registry
1962              (spam-log-unregistration-needed-p id type classification backend))
1963     (if (and (stringp id)
1964              (spam-process-type-valid-p type)
1965              (spam-classification-valid-p classification)
1966              (spam-backend-valid-p backend))
1967         (let ((cell-list (gnus-registry-get-id-key id type))
1968               new-cell-list found)
1969           (dolist (cell cell-list)
1970             (unless (and (eq classification (nth 0 cell))
1971                          (eq backend (nth 1 cell)))
1972               (push cell new-cell-list)))
1973           (gnus-registry-set-id-key id type new-cell-list))
1974       (progn
1975         (gnus-error 7 (format
1976                        "%s call with bad ID, type, spam-backend, or group"
1977                        "spam-log-undo-registration"))
1978         nil))))
1979
1980 ;;}}}
1981
1982 ;;{{{ backend functions
1983
1984 ;;{{{ Gmane xrefs
1985 (defun spam-check-gmane-xref ()
1986   (let ((header (or
1987                  (message-fetch-field "Xref")
1988                  (message-fetch-field "Newsgroups"))))
1989     (when header                        ; return nil when no header
1990       (when (string-match spam-gmane-xref-spam-group
1991                           header)
1992           spam-split-group))))
1993
1994 ;;}}}
1995
1996 ;;{{{ Regex body
1997
1998 (defun spam-check-regex-body ()
1999   (let ((spam-regex-headers-ham spam-regex-body-ham)
2000         (spam-regex-headers-spam spam-regex-body-spam))
2001     (spam-check-regex-headers t)))
2002
2003 ;;}}}
2004
2005 ;;{{{ Regex headers
2006
2007 (defun spam-check-regex-headers (&optional body)
2008   (let ((type (if body "body" "header"))
2009         ret found)
2010     (dolist (h-regex spam-regex-headers-ham)
2011       (unless found
2012         (goto-char (point-min))
2013         (when (re-search-forward h-regex nil t)
2014           (message "Ham regex %s search positive." type)
2015           (setq found t))))
2016     (dolist (s-regex spam-regex-headers-spam)
2017       (unless found
2018         (goto-char (point-min))
2019         (when (re-search-forward s-regex nil t)
2020           (message "Spam regex %s search positive." type)
2021           (setq found t)
2022           (setq ret spam-split-group))))
2023     ret))
2024
2025 ;;}}}
2026
2027 ;;{{{ Blackholes.
2028
2029 (defun spam-reverse-ip-string (ip)
2030   (when (stringp ip)
2031     (mapconcat 'identity
2032                (nreverse (split-string ip "\\."))
2033                ".")))
2034
2035 (defun spam-check-blackholes ()
2036   "Check the Received headers for blackholed relays."
2037   (let ((headers (message-fetch-field "received"))
2038         ips matches)
2039     (when headers
2040       (with-temp-buffer
2041         (insert headers)
2042         (goto-char (point-min))
2043         (gnus-message 6 "Checking headers for relay addresses")
2044         (while (re-search-forward
2045                 "\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\)" nil t)
2046           (gnus-message 9 "Blackhole search found host IP %s." (match-string 1))
2047           (push (spam-reverse-ip-string (match-string 1))
2048                 ips)))
2049       (dolist (server spam-blackhole-servers)
2050         (dolist (ip ips)
2051           (unless (and spam-blackhole-good-server-regex
2052                        ;; match against the reversed (again) IP string
2053                        (string-match
2054                         spam-blackhole-good-server-regex
2055                         (spam-reverse-ip-string ip)))
2056             (unless matches
2057               (let ((query-string (concat ip "." server)))
2058                 (if spam-use-dig
2059                     (let ((query-result (query-dig query-string)))
2060                       (when query-result
2061                         (gnus-message 6 "(DIG): positive blackhole check '%s'"
2062                                       query-result)
2063                         (push (list ip server query-result)
2064                               matches)))
2065                   ;; else, if not using dig.el
2066                   (when (dns-query query-string)
2067                     (gnus-message 6 "positive blackhole check")
2068                     (push (list ip server (dns-query query-string 'TXT))
2069                           matches)))))))))
2070     (when matches
2071       spam-split-group)))
2072 ;;}}}
2073
2074 ;;{{{ Hashcash.
2075
2076 (defun spam-check-hashcash ()
2077   "Check the headers for hashcash payments."
2078   (ignore-errors (mail-check-payment)))  ;mail-check-payment returns a boolean
2079
2080 ;;}}}
2081
2082 ;;{{{ BBDB
2083
2084 ;;; original idea for spam-check-BBDB from Alexander Kotelnikov
2085 ;;; <sacha@giotto.sj.ru>
2086
2087 ;; all this is done inside a condition-case to trap errors
2088
2089 ;; Autoloaded in message, which we require.
2090 (declare-function gnus-extract-address-components "gnus-util" (from))
2091
2092 (eval-and-compile
2093   (condition-case nil
2094       (progn
2095         (require 'bbdb)
2096         (require 'bbdb-com))
2097     (file-error
2098      ;; `bbdb-records' should not be bound as an autoload function
2099      ;; before loading bbdb because of `bbdb-hashtable-size'.
2100      (defalias 'bbdb-buffer 'ignore)
2101      (defalias 'bbdb-create-internal 'ignore)
2102      (defalias 'bbdb-records 'ignore)
2103      (defalias 'spam-BBDB-register-routine 'ignore)
2104      (defalias 'spam-enter-ham-BBDB 'ignore)
2105      (defalias 'spam-exists-in-BBDB-p 'ignore)
2106      (defalias 'bbdb-gethash 'ignore)
2107      nil)))
2108
2109 (eval-and-compile
2110   (when (featurep 'bbdb-com)
2111     ;; when the BBDB changes, we want to clear out our cache
2112     (defun spam-clear-cache-BBDB (&rest immaterial)
2113       (spam-clear-cache 'spam-use-BBDB))
2114
2115     (add-hook 'bbdb-change-hook 'spam-clear-cache-BBDB)
2116
2117     (defun spam-enter-ham-BBDB (addresses &optional remove)
2118       "Enter an address into the BBDB; implies ham (non-spam) sender"
2119       (dolist (from addresses)
2120         (when (stringp from)
2121           (let* ((parsed-address (gnus-extract-address-components from))
2122                  (name (or (nth 0 parsed-address) "Ham Sender"))
2123                  (remove-function (if remove
2124                                       'bbdb-delete-record-internal
2125                                     'ignore))
2126                  (net-address (nth 1 parsed-address))
2127                  (record (and net-address
2128                               (spam-exists-in-BBDB-p net-address))))
2129             (when net-address
2130               (gnus-message 6 "%s address %s %s BBDB"
2131                             (if remove "Deleting" "Adding")
2132                             from
2133                             (if remove "from" "to"))
2134               (if record
2135                   (funcall remove-function record)
2136                 (bbdb-create-internal name nil net-address nil nil
2137                                       "ham sender added by spam.el")))))))
2138
2139     (defun spam-BBDB-register-routine (articles &optional unregister)
2140       (let (addresses)
2141         (dolist (article articles)
2142           (when (stringp (spam-fetch-field-from-fast article))
2143             (push (spam-fetch-field-from-fast article) addresses)))
2144         ;; now do the register/unregister action
2145         (spam-enter-ham-BBDB addresses unregister)))
2146
2147     (defun spam-BBDB-unregister-routine (articles)
2148       (spam-BBDB-register-routine articles t))
2149
2150     (defsubst spam-exists-in-BBDB-p (net)
2151       (when (and (stringp net) (not (zerop (length net))))
2152         (bbdb-records)
2153         (bbdb-gethash (downcase net))))
2154
2155     (defun spam-check-BBDB ()
2156       "Mail from people in the BBDB is classified as ham or non-spam"
2157       (let ((net (message-fetch-field "from")))
2158         (when net
2159           (setq net (nth 1 (gnus-extract-address-components net)))
2160           (if (spam-exists-in-BBDB-p net)
2161               t
2162             (if spam-use-BBDB-exclusive
2163                 spam-split-group
2164               nil)))))))
2165
2166 ;;}}}
2167
2168 ;;{{{ ifile
2169
2170 ;;; check the ifile backend; return nil if the mail was NOT classified
2171 ;;; as spam
2172
2173
2174 (defun spam-get-ifile-database-parameter ()
2175   "Return the command-line parameter for ifile's database.
2176 See `spam-ifile-database'."
2177   (if spam-ifile-database
2178       (format "--db-file=%s" spam-ifile-database)
2179     nil))
2180
2181 (defun spam-check-ifile ()
2182   "Check the ifile backend for the classification of this message."
2183   (let ((article-buffer-name (buffer-name))
2184         category return)
2185     (with-temp-buffer
2186       (let ((temp-buffer-name (buffer-name))
2187             (db-param (spam-get-ifile-database-parameter)))
2188         (with-current-buffer article-buffer-name
2189           (apply 'call-process-region
2190                  (point-min) (point-max) spam-ifile-program
2191                  nil temp-buffer-name nil "-c"
2192                  (if db-param `(,db-param "-q") `("-q"))))
2193         ;; check the return now (we're back in the temp buffer)
2194         (goto-char (point-min))
2195         (if (not (eobp))
2196             (setq category (buffer-substring (point) (point-at-eol))))
2197         (when (not (zerop (length category))) ; we need a category here
2198           (if spam-ifile-all-categories
2199               (setq return category)
2200             ;; else, if spam-ifile-all-categories is not set...
2201             (when (string-equal spam-ifile-spam-category category)
2202               (setq return spam-split-group)))))) ; note return is nil otherwise
2203     return))
2204
2205 (defun spam-ifile-register-with-ifile (articles category &optional unregister)
2206   "Register an article, given as a string, with a category.
2207 Uses `gnus-newsgroup-name' if category is nil (for ham registration)."
2208   (let ((category (or category gnus-newsgroup-name))
2209         (add-or-delete-option (if unregister "-d" "-i"))
2210         (db (spam-get-ifile-database-parameter))
2211         parameters)
2212     (with-temp-buffer
2213       (dolist (article articles)
2214         (let ((article-string (spam-get-article-as-string article)))
2215           (when (stringp article-string)
2216             (insert article-string))))
2217       (apply 'call-process-region
2218              (point-min) (point-max) spam-ifile-program
2219              nil nil nil
2220              add-or-delete-option category
2221              (if db `(,db "-h") `("-h"))))))
2222
2223 (defun spam-ifile-register-spam-routine (articles &optional unregister)
2224   (spam-ifile-register-with-ifile articles spam-ifile-spam-category unregister))
2225
2226 (defun spam-ifile-unregister-spam-routine (articles)
2227   (spam-ifile-register-spam-routine articles t))
2228
2229 (defun spam-ifile-register-ham-routine (articles &optional unregister)
2230   (spam-ifile-register-with-ifile articles spam-ifile-ham-category unregister))
2231
2232 (defun spam-ifile-unregister-ham-routine (articles)
2233   (spam-ifile-register-ham-routine articles t))
2234
2235 ;;}}}
2236
2237 ;;{{{ spam-stat
2238
2239 (eval-when-compile
2240   (autoload 'spam-stat-buffer-change-to-non-spam "spam-stat")
2241   (autoload 'spam-stat-buffer-change-to-spam "spam-stat")
2242   (autoload 'spam-stat-buffer-is-non-spam "spam-stat")
2243   (autoload 'spam-stat-buffer-is-spam "spam-stat")
2244   (autoload 'spam-stat-load "spam-stat")
2245   (autoload 'spam-stat-save "spam-stat")
2246   (autoload 'spam-stat-split-fancy "spam-stat"))
2247
2248 (require 'spam-stat)
2249
2250 (defun spam-check-stat ()
2251   "Check the spam-stat backend for the classification of this message"
2252   (let ((spam-stat-split-fancy-spam-group spam-split-group) ; override
2253         (spam-stat-buffer (buffer-name)) ; stat the current buffer
2254         category return)
2255     (spam-stat-split-fancy)))
2256
2257 (defun spam-stat-register-spam-routine (articles &optional unregister)
2258   (dolist (article articles)
2259     (let ((article-string (spam-get-article-as-string article)))
2260       (with-temp-buffer
2261         (insert article-string)
2262         (if unregister
2263             (spam-stat-buffer-change-to-non-spam)
2264           (spam-stat-buffer-is-spam))))))
2265
2266 (defun spam-stat-unregister-spam-routine (articles)
2267   (spam-stat-register-spam-routine articles t))
2268
2269 (defun spam-stat-register-ham-routine (articles &optional unregister)
2270   (dolist (article articles)
2271     (let ((article-string (spam-get-article-as-string article)))
2272       (with-temp-buffer
2273         (insert article-string)
2274         (if unregister
2275             (spam-stat-buffer-change-to-spam)
2276           (spam-stat-buffer-is-non-spam))))))
2277
2278 (defun spam-stat-unregister-ham-routine (articles)
2279   (spam-stat-register-ham-routine articles t))
2280
2281 (defun spam-maybe-spam-stat-load ()
2282   (when spam-use-stat (spam-stat-load)))
2283
2284 (defun spam-maybe-spam-stat-save ()
2285   (when spam-use-stat (spam-stat-save)))
2286
2287 ;;}}}
2288
2289 ;;{{{ Blacklists and whitelists.
2290
2291 (defvar spam-whitelist-cache nil)
2292 (defvar spam-blacklist-cache nil)
2293
2294 (defun spam-kill-whole-line ()
2295   (beginning-of-line)
2296   (let ((kill-whole-line t))
2297     (kill-line)))
2298
2299 ;;; address can be a list, too
2300 (defun spam-enter-whitelist (address &optional remove)
2301   "Enter ADDRESS (list or single) into the whitelist.
2302 With a non-nil REMOVE, remove them."
2303   (interactive "sAddress: ")
2304   (spam-enter-list address spam-whitelist remove)
2305   (setq spam-whitelist-cache nil)
2306   (spam-clear-cache 'spam-use-whitelist))
2307
2308 ;;; address can be a list, too
2309 (defun spam-enter-blacklist (address &optional remove)
2310   "Enter ADDRESS (list or single) into the blacklist.
2311 With a non-nil REMOVE, remove them."
2312   (interactive "sAddress: ")
2313   (spam-enter-list address spam-blacklist remove)
2314   (setq spam-blacklist-cache nil)
2315   (spam-clear-cache 'spam-use-whitelist))
2316
2317 (defun spam-enter-list (addresses file &optional remove)
2318   "Enter ADDRESSES into the given FILE.
2319 Either the whitelist or the blacklist files can be used.
2320 With a non-nil REMOVE, remove the ADDRESSES."
2321   (if (stringp addresses)
2322       (spam-enter-list (list addresses) file remove)
2323     ;; else, we have a list of addresses here
2324     (unless (file-exists-p (file-name-directory file))
2325       (make-directory (file-name-directory file) t))
2326     (with-current-buffer
2327        (find-file-noselect file)
2328       (dolist (a addresses)
2329         (when (stringp a)
2330           (goto-char (point-min))
2331           (if (re-search-forward (regexp-quote a) nil t)
2332               ;; found the address
2333               (when remove
2334                 (spam-kill-whole-line))
2335             ;; else, the address was not found
2336             (unless remove
2337               (goto-char (point-max))
2338               (unless (bobp)
2339                 (insert "\n"))
2340               (insert a "\n")))))
2341       (save-buffer))))
2342
2343 (defun spam-filelist-build-cache (type)
2344   (let ((cache (if (eq type 'spam-use-blacklist)
2345                    spam-blacklist-cache
2346                  spam-whitelist-cache))
2347         parsed-cache)
2348     (unless (gethash type spam-caches)
2349       (while cache
2350         (let ((address (pop cache)))
2351           (unless (zerop (length address)) ; 0 for a nil address too
2352             (setq address (regexp-quote address))
2353             ;; fix regexp-quote's treatment of user-intended regexes
2354             (while (string-match "\\\\\\*" address)
2355               (setq address (replace-match ".*" t t address))))
2356           (push address parsed-cache)))
2357       (puthash type parsed-cache spam-caches))))
2358
2359 (defun spam-filelist-check-cache (type from)
2360   (when (stringp from)
2361     (spam-filelist-build-cache type)
2362     (let (found)
2363       (dolist (address (gethash type spam-caches))
2364         (when (and address (string-match address from))
2365           (setq found t)
2366           (return)))
2367       found)))
2368
2369 ;;; returns t if the sender is in the whitelist, nil or
2370 ;;; spam-split-group otherwise
2371 (defun spam-check-whitelist ()
2372   ;; FIXME!  Should it detect when file timestamps change?
2373   (unless spam-whitelist-cache
2374     (setq spam-whitelist-cache (spam-parse-list spam-whitelist)))
2375   (if (spam-from-listed-p 'spam-use-whitelist)
2376       t
2377     (if spam-use-whitelist-exclusive
2378         spam-split-group
2379       nil)))
2380
2381 (defun spam-check-blacklist ()
2382   ;; FIXME!  Should it detect when file timestamps change?
2383   (unless spam-blacklist-cache
2384     (setq spam-blacklist-cache (spam-parse-list spam-blacklist)))
2385   (and (spam-from-listed-p 'spam-use-blacklist)
2386        spam-split-group))
2387
2388 (defun spam-parse-list (file)
2389   (when (file-readable-p file)
2390     (let (contents address)
2391       (with-temp-buffer
2392         (insert-file-contents file)
2393         (while (not (eobp))
2394           (setq address (buffer-substring (point) (point-at-eol)))
2395           (forward-line 1)
2396           ;; insert the e-mail address if detected, otherwise the raw data
2397           (unless (zerop (length address))
2398             (let ((pure-address
2399                    (nth 1 (gnus-extract-address-components address))))
2400               (push (or pure-address address) contents)))))
2401       (nreverse contents))))
2402
2403 (defun spam-from-listed-p (type)
2404   (let ((from (message-fetch-field "from"))
2405         found)
2406     (spam-filelist-check-cache type from)))
2407
2408 (defun spam-filelist-register-routine (articles blacklist &optional unregister)
2409   (let ((de-symbol (if blacklist 'spam-use-whitelist 'spam-use-blacklist))
2410         (declassification (if blacklist 'ham 'spam))
2411         (enter-function
2412          (if blacklist 'spam-enter-blacklist 'spam-enter-whitelist))
2413         (remove-function
2414          (if blacklist 'spam-enter-whitelist 'spam-enter-blacklist))
2415         from addresses unregister-list article-unregister-list)
2416     (dolist (article articles)
2417       (let ((from (spam-fetch-field-from-fast article))
2418             (id (spam-fetch-field-message-id-fast article))
2419             sender-ignored)
2420         (when (stringp from)
2421           (dolist (ignore-regex spam-blacklist-ignored-regexes)
2422             (when (and (not sender-ignored)
2423                        (stringp ignore-regex)
2424                        (string-match ignore-regex from))
2425               (setq sender-ignored t)))
2426           ;; remember the messages we need to unregister, unless remove is set
2427           (when (and
2428                  (null unregister)
2429                  (spam-log-unregistration-needed-p
2430                   id 'process declassification de-symbol))
2431             (push article article-unregister-list)
2432             (push from unregister-list))
2433           (unless sender-ignored
2434             (push from addresses)))))
2435
2436     (if unregister
2437         (funcall enter-function addresses t) ; unregister all these addresses
2438       ;; else, register normally and unregister what we need to
2439       (funcall remove-function unregister-list t)
2440       (dolist (article article-unregister-list)
2441         (spam-log-undo-registration
2442          (spam-fetch-field-message-id-fast article)
2443          'process
2444          declassification
2445          de-symbol))
2446       (funcall enter-function addresses nil))))
2447
2448 (defun spam-blacklist-unregister-routine (articles)
2449   (spam-blacklist-register-routine articles t))
2450
2451 (defun spam-blacklist-register-routine (articles &optional unregister)
2452   (spam-filelist-register-routine articles t unregister))
2453
2454 (defun spam-whitelist-unregister-routine (articles)
2455   (spam-whitelist-register-routine articles t))
2456
2457 (defun spam-whitelist-register-routine (articles &optional unregister)
2458   (spam-filelist-register-routine articles nil unregister))
2459
2460 ;;}}}
2461
2462 ;;{{{ Spam-report glue (gmane and resend reporting)
2463 (defun spam-report-gmane-register-routine (articles)
2464   (when articles
2465     (apply 'spam-report-gmane-spam articles)))
2466
2467 (defun spam-report-gmane-unregister-routine (articles)
2468   (when articles
2469     (apply 'spam-report-gmane-ham articles)))
2470
2471 (defun spam-report-resend-register-ham-routine (articles)
2472   (spam-report-resend-register-routine articles t))
2473
2474 (defvar spam-report-resend-to)
2475
2476 (defun spam-report-resend-register-routine (articles &optional ham)
2477   (require 'spam-report)
2478   (let* ((resend-to-gp
2479           (if ham
2480               (gnus-parameter-ham-resend-to gnus-newsgroup-name)
2481             (gnus-parameter-spam-resend-to gnus-newsgroup-name)))
2482          (spam-report-resend-to (or (car-safe resend-to-gp)
2483                                     spam-report-resend-to)))
2484     (spam-report-resend articles ham)))
2485
2486 ;;}}}
2487
2488 ;;{{{ Bogofilter
2489 (defun spam-check-bogofilter-headers (&optional score)
2490   (let ((header (message-fetch-field spam-bogofilter-header)))
2491     (when header                        ; return nil when no header
2492       (if score                         ; scoring mode
2493           (if (string-match "spamicity=\\([0-9.]+\\)" header)
2494               (match-string 1 header)
2495             "0")
2496         ;; spam detection mode
2497         (when (string-match spam-bogofilter-bogosity-positive-spam-header
2498                             header)
2499           spam-split-group)))))
2500
2501 ;; return something sensible if the score can't be determined
2502 (defun spam-bogofilter-score (&optional recheck)
2503   "Get the Bogofilter spamicity score."
2504   (interactive "P")
2505   (save-window-excursion
2506     (gnus-summary-show-article t)
2507     (set-buffer gnus-article-buffer)
2508     (let ((score (or (unless recheck
2509                        (spam-check-bogofilter-headers t))
2510                      (spam-check-bogofilter t))))
2511       (gnus-summary-show-article)
2512       (message "Spamicity score %s" score)
2513       (or score "0"))))
2514
2515 (defun spam-verify-bogofilter ()
2516   "Verify the Bogofilter version is sufficient."
2517   (when (eq spam-bogofilter-valid 'unknown)
2518     (setq spam-bogofilter-valid
2519           (not (string-match "^bogofilter version 0\\.\\([0-9]\\|1[01]\\)\\."
2520                              (shell-command-to-string
2521                               (format "%s -V" spam-bogofilter-program))))))
2522   spam-bogofilter-valid)
2523
2524 (defun spam-check-bogofilter (&optional score)
2525   "Check the Bogofilter backend for the classification of this message."
2526   (if (spam-verify-bogofilter)
2527       (let ((article-buffer-name (buffer-name))
2528             (db spam-bogofilter-database-directory)
2529             return)
2530         (with-temp-buffer
2531           (let ((temp-buffer-name (buffer-name)))
2532             (with-current-buffer article-buffer-name
2533               (apply 'call-process-region
2534                      (point-min) (point-max)
2535                      spam-bogofilter-program
2536                      nil temp-buffer-name nil
2537                      (if db `("-d" ,db "-v") `("-v"))))
2538             (setq return (spam-check-bogofilter-headers score))))
2539         return)
2540     (gnus-error 5 "`spam.el' doesn't support obsolete bogofilter versions")))
2541
2542 (defun spam-bogofilter-register-with-bogofilter (articles
2543                                                  spam
2544                                                  &optional unregister)
2545   "Register an article, given as a string, as spam or non-spam."
2546   (if (spam-verify-bogofilter)
2547       (dolist (article articles)
2548         (let ((article-string (spam-get-article-as-string article))
2549               (db spam-bogofilter-database-directory)
2550               (switch (if unregister
2551                           (if spam
2552                               spam-bogofilter-spam-strong-switch
2553                             spam-bogofilter-ham-strong-switch)
2554                         (if spam
2555                             spam-bogofilter-spam-switch
2556                           spam-bogofilter-ham-switch))))
2557           (when (stringp article-string)
2558             (with-temp-buffer
2559               (insert article-string)
2560
2561               (apply 'call-process-region
2562                      (point-min) (point-max)
2563                      spam-bogofilter-program
2564                      nil nil nil switch
2565                      (if db `("-d" ,db "-v") `("-v")))))))
2566     (gnus-error 5 "`spam.el' doesn't support obsolete bogofilter versions")))
2567
2568 (defun spam-bogofilter-register-spam-routine (articles &optional unregister)
2569   (spam-bogofilter-register-with-bogofilter articles t unregister))
2570
2571 (defun spam-bogofilter-unregister-spam-routine (articles)
2572   (spam-bogofilter-register-spam-routine articles t))
2573
2574 (defun spam-bogofilter-register-ham-routine (articles &optional unregister)
2575   (spam-bogofilter-register-with-bogofilter articles nil unregister))
2576
2577 (defun spam-bogofilter-unregister-ham-routine (articles)
2578   (spam-bogofilter-register-ham-routine articles t))
2579
2580
2581 ;;}}}
2582
2583 ;;{{{ spamoracle
2584 (defun spam-check-spamoracle ()
2585   "Run spamoracle on an article to determine whether it's spam."
2586   (let ((article-buffer-name (buffer-name)))
2587     (with-temp-buffer
2588       (let ((temp-buffer-name (buffer-name)))
2589         (with-current-buffer article-buffer-name
2590           (let ((status
2591                  (apply 'call-process-region
2592                         (point-min) (point-max)
2593                         spam-spamoracle-binary
2594                         nil temp-buffer-name nil
2595                         (if spam-spamoracle-database
2596                             `("-f" ,spam-spamoracle-database "mark")
2597                           '("mark")))))
2598             (if (eq 0 status)
2599                 (progn
2600                   (set-buffer temp-buffer-name)
2601                   (goto-char (point-min))
2602                   (when (re-search-forward "^X-Spam: yes;" nil t)
2603                     spam-split-group))
2604               (error "Error running spamoracle: %s" status))))))))
2605
2606 (defun spam-spamoracle-learn (articles article-is-spam-p &optional unregister)
2607   "Run spamoracle in training mode."
2608   (with-temp-buffer
2609     (let ((temp-buffer-name (buffer-name)))
2610       (save-excursion
2611         (goto-char (point-min))
2612         (dolist (article articles)
2613           (insert (spam-get-article-as-string article)))
2614         (let* ((arg (if (spam-xor unregister article-is-spam-p)
2615                         "-spam"
2616                       "-good"))
2617                (status
2618                 (apply 'call-process-region
2619                        (point-min) (point-max)
2620                        spam-spamoracle-binary
2621                        nil temp-buffer-name nil
2622                        (if spam-spamoracle-database
2623                            `("-f" ,spam-spamoracle-database
2624                              "add" ,arg)
2625                          `("add" ,arg)))))
2626           (unless (eq 0 status)
2627             (error "Error running spamoracle: %s" status)))))))
2628
2629 (defun spam-spamoracle-learn-ham (articles &optional unregister)
2630   (spam-spamoracle-learn articles nil unregister))
2631
2632 (defun spam-spamoracle-unlearn-ham (articles &optional unregister)
2633   (spam-spamoracle-learn-ham articles t))
2634
2635 (defun spam-spamoracle-learn-spam (articles &optional unregister)
2636   (spam-spamoracle-learn articles t unregister))
2637
2638 (defun spam-spamoracle-unlearn-spam (articles &optional unregister)
2639   (spam-spamoracle-learn-spam articles t))
2640
2641 ;;}}}
2642
2643 ;;{{{ SpamAssassin
2644 ;;; based mostly on the bogofilter code
2645 (defun spam-check-spamassassin-headers (&optional score)
2646   "Check the SpamAssassin headers for the classification of this message."
2647   (if score                             ; scoring mode
2648       (let ((header (message-fetch-field spam-spamassassin-spam-status-header)))
2649         (when header
2650           (if (string-match spam-spamassassin-score-regexp header)
2651               (match-string 1 header)
2652             "0")))
2653     ;; spam detection mode
2654     (let ((header (message-fetch-field spam-spamassassin-spam-flag-header)))
2655           (when header                  ; return nil when no header
2656             (when (string-match spam-spamassassin-positive-spam-flag-header
2657                                 header)
2658               spam-split-group)))))
2659
2660 (defun spam-check-spamassassin (&optional score)
2661   "Check the SpamAssassin backend for the classification of this message."
2662   (let ((article-buffer-name (buffer-name)))
2663     (with-temp-buffer
2664       (let ((temp-buffer-name (buffer-name)))
2665         (with-current-buffer article-buffer-name
2666           (apply 'call-process-region
2667                  (point-min) (point-max) spam-assassin-program
2668                  nil temp-buffer-name nil spam-spamassassin-arguments))
2669         ;; check the return now (we're back in the temp buffer)
2670         (goto-char (point-min))
2671         (spam-check-spamassassin-headers score)))))
2672
2673 ;; return something sensible if the score can't be determined
2674 (defun spam-spamassassin-score (&optional recheck)
2675   "Get the SpamAssassin score"
2676   (interactive "P")
2677   (save-window-excursion
2678     (gnus-summary-show-article t)
2679     (set-buffer gnus-article-buffer)
2680     (let ((score (or (unless recheck
2681                        (spam-check-spamassassin-headers t))
2682                      (spam-check-spamassassin t))))
2683       (gnus-summary-show-article)
2684       (message "SpamAssassin score %s" score)
2685       (or score "0"))))
2686
2687 (defun spam-spamassassin-register-with-sa-learn (articles spam
2688                                                  &optional unregister)
2689   "Register articles with spamassassin's sa-learn as spam or non-spam."
2690   (if articles
2691       (let ((action (if unregister spam-sa-learn-unregister-switch
2692                       (if spam spam-sa-learn-spam-switch
2693                         spam-sa-learn-ham-switch)))
2694             (summary-buffer-name (buffer-name)))
2695         (with-temp-buffer
2696           ;; group the articles into mbox format
2697           (dolist (article articles)
2698             (let (article-string)
2699               (with-current-buffer summary-buffer-name
2700                 (setq article-string (spam-get-article-as-string article)))
2701               (when (stringp article-string)
2702                 ;; mbox separator
2703                 (insert (concat "From nobody " (current-time-string) "\n"))
2704                 (insert article-string)
2705                 (insert "\n"))))
2706           ;; call sa-learn on all messages at the same time
2707           (apply 'call-process-region
2708                  (point-min) (point-max)
2709                  spam-sa-learn-program
2710                  nil nil nil "--mbox"
2711                  (if spam-sa-learn-rebuild
2712                      (list action)
2713                    `("--no-rebuild" ,action)))))))
2714
2715 (defun spam-spamassassin-register-spam-routine (articles &optional unregister)
2716   (spam-spamassassin-register-with-sa-learn articles t unregister))
2717
2718 (defun spam-spamassassin-register-ham-routine (articles &optional unregister)
2719   (spam-spamassassin-register-with-sa-learn articles nil unregister))
2720
2721 (defun spam-spamassassin-unregister-spam-routine (articles)
2722   (spam-spamassassin-register-with-sa-learn articles t t))
2723
2724 (defun spam-spamassassin-unregister-ham-routine (articles)
2725   (spam-spamassassin-register-with-sa-learn articles nil t))
2726
2727 ;;}}}
2728
2729 ;;{{{ Bsfilter
2730 ;;; based mostly on the bogofilter code
2731 (defun spam-check-bsfilter-headers (&optional score)
2732   (if score
2733       (or (nnmail-fetch-field spam-bsfilter-probability-header)
2734           "0")
2735     (let ((header (nnmail-fetch-field spam-bsfilter-header)))
2736       (when header ; return nil when no header
2737         (when (string-match "YES" header)
2738           spam-split-group)))))
2739
2740 ;; return something sensible if the score can't be determined
2741 (defun spam-bsfilter-score (&optional recheck)
2742   "Get the Bsfilter spamicity score."
2743   (interactive "P")
2744   (save-window-excursion
2745     (gnus-summary-show-article t)
2746     (set-buffer gnus-article-buffer)
2747     (let ((score (or (unless recheck
2748                        (spam-check-bsfilter-headers t))
2749                      (spam-check-bsfilter t))))
2750       (gnus-summary-show-article)
2751       (message "Spamicity score %s" score)
2752       (or score "0"))))
2753
2754 (defun spam-check-bsfilter (&optional score)
2755   "Check the Bsfilter backend for the classification of this message."
2756   (let ((article-buffer-name (buffer-name))
2757         (dir spam-bsfilter-database-directory)
2758         return)
2759     (with-temp-buffer
2760       (let ((temp-buffer-name (buffer-name)))
2761         (with-current-buffer article-buffer-name
2762           (apply 'call-process-region
2763                  (point-min) (point-max)
2764                  spam-bsfilter-program
2765                  nil temp-buffer-name nil
2766                  "--pipe"
2767                  "--insert-flag"
2768                  "--insert-probability"
2769                  (when dir
2770                    (list "--homedir" dir))))
2771         (setq return (spam-check-bsfilter-headers score))))
2772     return))
2773
2774 (defun spam-bsfilter-register-with-bsfilter (articles
2775                                              spam
2776                                              &optional unregister)
2777   "Register an article, given as a string, as spam or non-spam."
2778   (dolist (article articles)
2779     (let ((article-string (spam-get-article-as-string article))
2780           (switch (if unregister
2781                       (if spam
2782                           spam-bsfilter-spam-strong-switch
2783                         spam-bsfilter-ham-strong-switch)
2784                     (if spam
2785                         spam-bsfilter-spam-switch
2786                       spam-bsfilter-ham-switch))))
2787       (when (stringp article-string)
2788         (with-temp-buffer
2789           (insert article-string)
2790           (apply 'call-process-region
2791                  (point-min) (point-max)
2792                  spam-bsfilter-program
2793                  nil nil nil switch
2794                  "--update"
2795                  (when spam-bsfilter-database-directory
2796                    (list "--homedir"
2797                          spam-bsfilter-database-directory))))))))
2798
2799 (defun spam-bsfilter-register-spam-routine (articles &optional unregister)
2800   (spam-bsfilter-register-with-bsfilter articles t unregister))
2801
2802 (defun spam-bsfilter-unregister-spam-routine (articles)
2803   (spam-bsfilter-register-spam-routine articles t))
2804
2805 (defun spam-bsfilter-register-ham-routine (articles &optional unregister)
2806   (spam-bsfilter-register-with-bsfilter articles nil unregister))
2807
2808 (defun spam-bsfilter-unregister-ham-routine (articles)
2809   (spam-bsfilter-register-ham-routine articles t))
2810
2811 ;;}}}
2812
2813 ;;{{{ CRM114 Mailfilter
2814 (defun spam-check-crm114-headers (&optional score)
2815   (let ((header (message-fetch-field spam-crm114-header)))
2816     (when header                        ; return nil when no header
2817       (if score                         ; scoring mode
2818           (if (string-match "( pR: \\([0-9.-]+\\)" header)
2819               (match-string 1 header)
2820             "0")
2821         ;; spam detection mode
2822         (when (string-match spam-crm114-positive-spam-header
2823                             header)
2824           spam-split-group)))))
2825
2826 ;; return something sensible if the score can't be determined
2827 (defun spam-crm114-score ()
2828   "Get the CRM114 Mailfilter pR."
2829   (interactive)
2830   (save-window-excursion
2831     (gnus-summary-show-article t)
2832     (set-buffer gnus-article-buffer)
2833     (let ((score (or (spam-check-crm114-headers t)
2834                      (spam-check-crm114 t))))
2835       (gnus-summary-show-article)
2836       (message "pR: %s" score)
2837       (or score "0"))))
2838
2839 (defun spam-check-crm114 (&optional score)
2840   "Check the CRM114 Mailfilter backend for the classification of this message."
2841   (let ((article-buffer-name (buffer-name))
2842         (db spam-crm114-database-directory)
2843         return)
2844     (with-temp-buffer
2845       (let ((temp-buffer-name (buffer-name)))
2846         (with-current-buffer article-buffer-name
2847           (apply 'call-process-region
2848                  (point-min) (point-max)
2849                  spam-crm114-program
2850                  nil temp-buffer-name nil
2851                  (when db (list (concat "--fileprefix=" db)))))
2852         (setq return (spam-check-crm114-headers score))))
2853     return))
2854
2855 (defun spam-crm114-register-with-crm114 (articles
2856                                          spam
2857                                          &optional unregister)
2858   "Register an article, given as a string, as spam or non-spam."
2859   (dolist (article articles)
2860     (let ((article-string (spam-get-article-as-string article))
2861           (db spam-crm114-database-directory)
2862           (switch (if unregister
2863                       (if spam
2864                           spam-crm114-spam-strong-switch
2865                         spam-crm114-ham-strong-switch)
2866                     (if spam
2867                         spam-crm114-spam-switch
2868                       spam-crm114-ham-switch))))
2869       (when (stringp article-string)
2870         (with-temp-buffer
2871           (insert article-string)
2872
2873           (apply 'call-process-region
2874                  (point-min) (point-max)
2875                  spam-crm114-program
2876                  nil nil nil
2877                  (when db (list switch (concat "--fileprefix=" db)))))))))
2878
2879 (defun spam-crm114-register-spam-routine (articles &optional unregister)
2880   (spam-crm114-register-with-crm114 articles t unregister))
2881
2882 (defun spam-crm114-unregister-spam-routine (articles)
2883   (spam-crm114-register-spam-routine articles t))
2884
2885 (defun spam-crm114-register-ham-routine (articles &optional unregister)
2886   (spam-crm114-register-with-crm114 articles nil unregister))
2887
2888 (defun spam-crm114-unregister-ham-routine (articles)
2889   (spam-crm114-register-ham-routine articles t))
2890
2891 ;;}}}
2892
2893 ;;}}}
2894
2895 ;;{{{ Hooks
2896
2897 ;;;###autoload
2898 (defun spam-initialize (&rest symbols)
2899   "Install the spam.el hooks and do other initialization.
2900 When SYMBOLS is given, set those variables to t.  This is so you
2901 can call `spam-initialize' before you set spam-use-* variables on
2902 explicitly, and matters only if you need the extra headers
2903 installed through `spam-necessary-extra-headers'."
2904   (interactive)
2905
2906   (dolist (var symbols)
2907     (set var t))
2908
2909   (dolist (header (spam-necessary-extra-headers))
2910     (add-to-list 'nnmail-extra-headers header)
2911     (add-to-list 'gnus-extra-headers header))
2912
2913   (setq spam-install-hooks t)
2914   ;; TODO: How do we redo this every time the `spam' face is customized?
2915   (push '((eq mark gnus-spam-mark) . spam)
2916         gnus-summary-highlight)
2917   ;; Add hooks for loading and saving the spam stats
2918   (add-hook 'gnus-save-newsrc-hook 'spam-maybe-spam-stat-save)
2919   (add-hook 'gnus-get-top-new-news-hook 'spam-maybe-spam-stat-load)
2920   (add-hook 'gnus-startup-hook 'spam-maybe-spam-stat-load)
2921   (add-hook 'gnus-summary-prepare-exit-hook 'spam-summary-prepare-exit)
2922   (add-hook 'gnus-summary-prepare-hook 'spam-summary-prepare)
2923   (add-hook 'gnus-get-new-news-hook 'spam-setup-widening)
2924   (add-hook 'gnus-summary-prepared-hook 'spam-find-spam))
2925
2926 (defun spam-unload-hook ()
2927   "Uninstall the spam.el hooks."
2928   (interactive)
2929   (remove-hook 'gnus-save-newsrc-hook 'spam-maybe-spam-stat-save)
2930   (remove-hook 'gnus-get-top-new-news-hook 'spam-maybe-spam-stat-load)
2931   (remove-hook 'gnus-startup-hook 'spam-maybe-spam-stat-load)
2932   (remove-hook 'gnus-summary-prepare-exit-hook 'spam-summary-prepare-exit)
2933   (remove-hook 'gnus-summary-prepare-hook 'spam-summary-prepare)
2934   (remove-hook 'gnus-get-new-news-hook 'spam-setup-widening)
2935   (remove-hook 'gnus-summary-prepare-hook 'spam-find-spam))
2936
2937 (add-hook 'spam-unload-hook 'spam-unload-hook)
2938
2939 (when spam-install-hooks
2940   (spam-initialize))
2941 ;;}}}
2942
2943 (provide 'spam)
2944
2945 ;;; spam.el ends here