X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fspam.el;h=664ac53a76f5b99449ecc9c91cbfcc950cc82440;hp=3bce27625d067417fff025b8264b18537729530d;hb=54b3844ec0d9b1fd25b4f00f927853ff72ba5274;hpb=6a153e9d3c93691db6134c28a29bbc3b1353a906 diff --git a/lisp/spam.el b/lisp/spam.el index 3bce27625..664ac53a7 100644 --- a/lisp/spam.el +++ b/lisp/spam.el @@ -1,7 +1,6 @@ ;;; spam.el --- Identifying spam -;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 -;; Free Software Foundation, Inc. +;; Copyright (C) 2002-2014 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Maintainer: Ted Zlatanov @@ -39,10 +38,6 @@ ;;{{{ compilation directives and autoloads/requires -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) - (eval-when-compile (require 'cl)) (require 'message) ;for the message-fetch-field functions @@ -51,7 +46,6 @@ ;;; for the definitions of group content classification and spam processors (require 'gnus) -(eval-when-compile (require 'spam-report)) (eval-when-compile (require 'hashcash)) ;; for nnimap-split-download-body-default @@ -61,17 +55,16 @@ (autoload 'query-dig "dig") ;; autoload spam-report -(eval-and-compile - (autoload 'spam-report-gmane "spam-report") - (autoload 'spam-report-gmane-spam "spam-report") - (autoload 'spam-report-gmane-ham "spam-report") - (autoload 'spam-report-resend "spam-report")) +(autoload 'spam-report-gmane "spam-report") +(autoload 'spam-report-gmane-spam "spam-report") +(autoload 'spam-report-gmane-ham "spam-report") +(autoload 'spam-report-resend "spam-report") ;; autoload gnus-registry (autoload 'gnus-registry-group-count "gnus-registry") -(autoload 'gnus-registry-add-group "gnus-registry") -(autoload 'gnus-registry-store-extra-entry "gnus-registry") -(autoload 'gnus-registry-fetch-extra "gnus-registry") +(autoload 'gnus-registry-get-id-key "gnus-registry") +(autoload 'gnus-registry-set-id-key "gnus-registry") +(autoload 'gnus-registry-handle-action "gnus-registry") ;; autoload dns-query (autoload 'dns-query "dns") @@ -95,14 +88,14 @@ Note that setting the `spam-use-move' or `spam-use-copy' backends on a group through group/topic parameters overrides this mechanism." :type '(choice (const - 'default - :tag "Move spam out of all groups and ham out of spam groups.") + :tag "Move spam out of all groups and ham out of spam groups" + default) (const - 'move-all - :tag "Move spam out of all groups and ham out of all groups.") + :tag "Move spam out of all groups and ham out of all groups" + move-all) (const - 'move-none - :tag "Never move spam or ham out of any groups.")) + :tag "Never move spam or ham out of any groups" + move-none)) :group 'spam) (defcustom spam-directory (nnheader-concat gnus-directory "spam/") @@ -157,7 +150,7 @@ last rule in your split configuration." :group 'spam) (defcustom spam-autodetect-recheck-messages nil - "Should spam.el recheck all meessages when autodetecting? + "Should spam.el recheck all messages when autodetecting? Normally this is nil, so only unseen messages will be checked." :type 'boolean :group 'spam) @@ -1582,31 +1575,31 @@ to find it out)." (when (numberp article) (let* ((data-header (or prepared-data-header (spam-fetch-article-header article)))) - (if (arrayp data-header) - (cond - ((equal field 'number) - (mail-header-number data-header)) - ((equal field 'from) - (mail-header-from data-header)) - ((equal field 'message-id) - (mail-header-message-id data-header)) - ((equal field 'subject) - (mail-header-subject data-header)) - ((equal field 'references) - (mail-header-references data-header)) - ((equal field 'date) - (mail-header-date data-header)) - ((equal field 'xref) - (mail-header-xref data-header)) - ((equal field 'extra) - (mail-header-extra data-header)) - (t - (gnus-error - 5 - "spam-fetch-field-fast: unknown field %s requested" - field) - nil)) - (gnus-message 6 "Article %d has a nil data header" article))))) + (cond + ((not (arrayp data-header)) + (gnus-message 6 "Article %d has a nil data header" article)) + ((equal field 'number) + (mail-header-number data-header)) + ((equal field 'from) + (mail-header-from data-header)) + ((equal field 'message-id) + (mail-header-message-id data-header)) + ((equal field 'subject) + (mail-header-subject data-header)) + ((equal field 'references) + (mail-header-references data-header)) + ((equal field 'date) + (mail-header-date data-header)) + ((equal field 'xref) + (mail-header-xref data-header)) + ((equal field 'extra) + (mail-header-extra data-header)) + (t + (gnus-error + 5 + "spam-fetch-field-fast: unknown field %s requested" + field) + nil))))) (defun spam-fetch-field-from-fast (article &optional prepared-data-header) (spam-fetch-field-fast article 'from prepared-data-header)) @@ -1765,8 +1758,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (when (and id split-return spam-log-to-registry) (when (zerop (gnus-registry-group-count id)) - (gnus-registry-add-group - id group subject sender)) + (gnus-registry-handle-action id nil group subject sender)) (unless registry-lookup (spam-log-processing-to-registry @@ -1895,13 +1887,10 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (spam-process-type-valid-p type) (spam-classification-valid-p classification) (spam-backend-valid-p backend)) - (let ((cell-list (cdr-safe (gnus-registry-fetch-extra id type))) + (let ((cell-list (gnus-registry-get-id-key id type)) (cell (list classification backend group))) (push cell cell-list) - (gnus-registry-store-extra-entry - id - type - cell-list)) + (gnus-registry-set-id-key id type cell-list)) (gnus-error 7 @@ -1914,7 +1903,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (when spam-log-to-registry (if (and (stringp id) (spam-process-type-valid-p type)) - (cdr-safe (gnus-registry-fetch-extra id type)) + (gnus-registry-get-id-key id type) (progn (gnus-error 7 @@ -1946,7 +1935,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (spam-process-type-valid-p type) (spam-classification-valid-p classification) (spam-backend-valid-p backend)) - (let ((cell-list (cdr-safe (gnus-registry-fetch-extra id type))) + (let ((cell-list (gnus-registry-get-id-key id type)) found) (dolist (cell cell-list) (unless found @@ -1971,16 +1960,13 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (spam-process-type-valid-p type) (spam-classification-valid-p classification) (spam-backend-valid-p backend)) - (let ((cell-list (cdr-safe (gnus-registry-fetch-extra id type))) + (let ((cell-list (gnus-registry-get-id-key id type)) new-cell-list found) (dolist (cell cell-list) (unless (and (eq classification (nth 0 cell)) (eq backend (nth 1 cell))) (push cell new-cell-list))) - (gnus-registry-store-extra-entry - id - type - new-cell-list)) + (gnus-registry-set-id-key id type new-cell-list)) (progn (gnus-error 7 (format "%s call with bad ID, type, spam-backend, or group" @@ -2096,27 +2082,28 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." ;; all this is done inside a condition-case to trap errors -(eval-when-compile - (autoload 'bbdb-buffer "bbdb") - (autoload 'bbdb-create-internal "bbdb") - (autoload 'bbdb-search-simple "bbdb")) - ;; Autoloaded in message, which we require. (declare-function gnus-extract-address-components "gnus-util" (from)) (eval-and-compile - (when (condition-case nil - (progn - (require 'bbdb) - (require 'bbdb-com)) - (file-error - ;; `bbdb-records' should not be bound as an autoload function - ;; before loading bbdb because of `bbdb-hashtable-size'. - (defalias 'bbdb-records 'ignore) - (defalias 'spam-BBDB-register-routine 'ignore) - (defalias 'spam-enter-ham-BBDB 'ignore) - nil)) + (condition-case nil + (progn + (require 'bbdb) + (require 'bbdb-com)) + (file-error + ;; `bbdb-records' should not be bound as an autoload function + ;; before loading bbdb because of `bbdb-hashtable-size'. + (defalias 'bbdb-buffer 'ignore) + (defalias 'bbdb-create-internal 'ignore) + (defalias 'bbdb-records 'ignore) + (defalias 'spam-BBDB-register-routine 'ignore) + (defalias 'spam-enter-ham-BBDB 'ignore) + (defalias 'spam-exists-in-BBDB-p 'ignore) + (defalias 'bbdb-gethash 'ignore) + nil))) +(eval-and-compile + (when (featurep 'bbdb-com) ;; when the BBDB changes, we want to clear out our cache (defun spam-clear-cache-BBDB (&rest immaterial) (spam-clear-cache 'spam-use-BBDB)) @@ -2134,7 +2121,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." 'ignore)) (net-address (nth 1 parsed-address)) (record (and net-address - (bbdb-search-simple nil net-address)))) + (spam-exists-in-BBDB-p net-address)))) (when net-address (gnus-message 6 "%s address %s %s BBDB" (if remove "Deleting" "Adding") @@ -2156,31 +2143,17 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (defun spam-BBDB-unregister-routine (articles) (spam-BBDB-register-routine articles t)) + (defsubst spam-exists-in-BBDB-p (net) + (when (and (stringp net) (not (zerop (length net)))) + (bbdb-records) + (bbdb-gethash (downcase net)))) + (defun spam-check-BBDB () "Mail from people in the BBDB is classified as ham or non-spam" - (let ((who (message-fetch-field "from")) - bbdb-cache bbdb-hashtable) - (when spam-cache-lookups - (setq bbdb-cache (gethash 'spam-use-BBDB spam-caches)) - (unless bbdb-cache - (setq bbdb-cache (make-vector 17 0)) ; a good starting hash value - ;; this is based on the expanded (bbdb-hashtable) macro - ;; without the debugging support - (with-current-buffer (bbdb-buffer) - (save-excursion - (save-window-excursion - (bbdb-records nil t) - (mapatoms - (lambda (symbol) - (intern (downcase (symbol-name symbol)) bbdb-cache)) - bbdb-hashtable)))) - (puthash 'spam-use-BBDB bbdb-cache spam-caches))) - (when who - (setq who (nth 1 (gnus-extract-address-components who))) - (if - (if spam-cache-lookups - (intern-soft (downcase who) bbdb-cache) - (bbdb-search-simple nil who)) + (let ((net (message-fetch-field "from"))) + (when net + (setq net (nth 1 (gnus-extract-address-components net))) + (if (spam-exists-in-BBDB-p net) t (if spam-use-BBDB-exclusive spam-split-group @@ -2268,51 +2241,44 @@ Uses `gnus-newsgroup-name' if category is nil (for ham registration)." (autoload 'spam-stat-save "spam-stat") (autoload 'spam-stat-split-fancy "spam-stat")) -(eval-and-compile - (when (condition-case nil - (let ((spam-stat-install-hooks nil)) - (require 'spam-stat)) - (file-error - (defalias 'spam-stat-register-ham-routine 'ignore) - (defalias 'spam-stat-register-spam-routine 'ignore) - nil)) - - (defun spam-check-stat () - "Check the spam-stat backend for the classification of this message" - (let ((spam-stat-split-fancy-spam-group spam-split-group) ; override - (spam-stat-buffer (buffer-name)) ; stat the current buffer - category return) - (spam-stat-split-fancy))) - - (defun spam-stat-register-spam-routine (articles &optional unregister) - (dolist (article articles) - (let ((article-string (spam-get-article-as-string article))) - (with-temp-buffer - (insert article-string) - (if unregister - (spam-stat-buffer-change-to-non-spam) - (spam-stat-buffer-is-spam)))))) +(require 'spam-stat) - (defun spam-stat-unregister-spam-routine (articles) - (spam-stat-register-spam-routine articles t)) +(defun spam-check-stat () + "Check the spam-stat backend for the classification of this message" + (let ((spam-stat-split-fancy-spam-group spam-split-group) ; override + (spam-stat-buffer (buffer-name)) ; stat the current buffer + category return) + (spam-stat-split-fancy))) - (defun spam-stat-register-ham-routine (articles &optional unregister) - (dolist (article articles) - (let ((article-string (spam-get-article-as-string article))) - (with-temp-buffer - (insert article-string) - (if unregister - (spam-stat-buffer-change-to-spam) - (spam-stat-buffer-is-non-spam)))))) +(defun spam-stat-register-spam-routine (articles &optional unregister) + (dolist (article articles) + (let ((article-string (spam-get-article-as-string article))) + (with-temp-buffer + (insert article-string) + (if unregister + (spam-stat-buffer-change-to-non-spam) + (spam-stat-buffer-is-spam)))))) - (defun spam-stat-unregister-ham-routine (articles) - (spam-stat-register-ham-routine articles t)) +(defun spam-stat-unregister-spam-routine (articles) + (spam-stat-register-spam-routine articles t)) - (defun spam-maybe-spam-stat-load () - (when spam-use-stat (spam-stat-load))) +(defun spam-stat-register-ham-routine (articles &optional unregister) + (dolist (article articles) + (let ((article-string (spam-get-article-as-string article))) + (with-temp-buffer + (insert article-string) + (if unregister + (spam-stat-buffer-change-to-spam) + (spam-stat-buffer-is-non-spam)))))) - (defun spam-maybe-spam-stat-save () - (when spam-use-stat (spam-stat-save))))) +(defun spam-stat-unregister-ham-routine (articles) + (spam-stat-register-ham-routine articles t)) + +(defun spam-maybe-spam-stat-load () + (when spam-use-stat (spam-stat-load))) + +(defun spam-maybe-spam-stat-save () + (when spam-use-stat (spam-stat-save))) ;;}}} @@ -2501,7 +2467,10 @@ With a non-nil REMOVE, remove the ADDRESSES." (defun spam-report-resend-register-ham-routine (articles) (spam-report-resend-register-routine articles t)) +(defvar spam-report-resend-to) + (defun spam-report-resend-register-routine (articles &optional ham) + (require 'spam-report) (let* ((resend-to-gp (if ham (gnus-parameter-ham-resend-to gnus-newsgroup-name) @@ -2930,25 +2899,27 @@ explicitly, and matters only if you need the extra headers installed through `spam-necessary-extra-headers'." (interactive) - (dolist (var symbols) - (set var t)) - - (dolist (header (spam-necessary-extra-headers)) - (add-to-list 'nnmail-extra-headers header) - (add-to-list 'gnus-extra-headers header)) - - (setq spam-install-hooks t) - ;; TODO: How do we redo this every time the `spam' face is customized? - (push '((eq mark gnus-spam-mark) . spam) - gnus-summary-highlight) - ;; Add hooks for loading and saving the spam stats - (add-hook 'gnus-save-newsrc-hook 'spam-maybe-spam-stat-save) - (add-hook 'gnus-get-top-new-news-hook 'spam-maybe-spam-stat-load) - (add-hook 'gnus-startup-hook 'spam-maybe-spam-stat-load) - (add-hook 'gnus-summary-prepare-exit-hook 'spam-summary-prepare-exit) - (add-hook 'gnus-summary-prepare-hook 'spam-summary-prepare) - (add-hook 'gnus-get-new-news-hook 'spam-setup-widening) - (add-hook 'gnus-summary-prepared-hook 'spam-find-spam)) + (when spam-install-hooks + (dolist (var symbols) + (set var t)) + + (dolist (header (spam-necessary-extra-headers)) + (add-to-list 'nnmail-extra-headers header) + (add-to-list 'gnus-extra-headers header)) + + ;; TODO: How do we redo this every time the `spam' face is customized? + (push '((eq mark gnus-spam-mark) . spam) + gnus-summary-highlight) + ;; Add hooks for loading and saving the spam stats + (add-hook 'gnus-save-newsrc-hook 'spam-maybe-spam-stat-save) + (add-hook 'gnus-get-top-new-news-hook 'spam-maybe-spam-stat-load) + (add-hook 'gnus-startup-hook 'spam-maybe-spam-stat-load) + (add-hook 'gnus-summary-prepare-exit-hook 'spam-summary-prepare-exit) + (add-hook 'gnus-summary-prepare-hook 'spam-summary-prepare) + (add-hook 'gnus-get-new-news-hook 'spam-setup-widening) + (add-hook 'gnus-summary-prepared-hook 'spam-find-spam) + ;; Don't install things more than once. + (setq spam-install-hooks nil))) (defun spam-unload-hook () "Uninstall the spam.el hooks." @@ -2963,8 +2934,6 @@ installed through `spam-necessary-extra-headers'." (add-hook 'spam-unload-hook 'spam-unload-hook) -(when spam-install-hooks - (spam-initialize)) ;;}}} (provide 'spam)