From 9be4f41b4254c029fc328b10ecef4e71cd2ca024 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sat, 30 Jan 2021 16:45:25 -0500 Subject: [PATCH] * lisp/gnus: Misc simplifications found during conversion to lexical * lisp/gnus/nnoo.el (noo-import-1, nnoo-define-skeleton-1): Use `dolist`. (noo-map-functions, nnoo-define-basics): Directly emit the code rather than going through an intermediate function; this also avoids the use of `eval`. (noo-map-functions-1, nnoo-define-basics-1): Delete functions, folded into their corresponding macro. * lisp/gnus/gmm-utils.el (gmm-tool-bar-from-list): Demote `eval` to `symbol-value`. * lisp/gnus/gnus-art.el (gnus-button-handle-describe-key): Avoid `eval` since `kbd` is a function nowadays. (gnus-treat-part-number): Rename from `part-number`. (gnus-treat-total-parts): Rename from `total-parts`. (gnus-treat-article, gnus-treat-predicate): Adjust accordingly. * lisp/gnus/gnus-cache.el (gnus-agent-load-alist): Use `declare-function`. * lisp/gnus/gnus-group.el (gnus-cache-active-hashtb): Use `defvar`. (gnus-group-iterate): Make it a normal function since lexical scoping avoids the risk of name capture anyway. (gnus-group-delete-articles): Actually use the `oldp` arg. * lisp/gnus/gnus-html.el (gnus-html-wash-images): Fix debug message so it's emitted after the `url` var it prints is actually initialized. And avoid `setq` while we're at it. * lisp/gnus/gnus-msg.el (gnus-group-mail, gnus-group-news) (gnus-summary-mail-other-window, gnus-summary-news-other-window): Merge `let`s using `let*`. * lisp/gnus/gnus-spec.el (gnus-update-format-specifications): Tighten the scope of `buffer`, and tighten a regexp. (gnus-parse-simple-format): Reduce code duplication. * lisp/gnus/gnus-start.el (gnus-child-mode): Don't `defvar` it since we never use that variable and accordingly don't define it as a minor mode. * lisp/gnus/gnus-util.el (gnus-byte-compile): Simplify so it obeys `gnus-use-byte-compile` not just on the first call. (iswitchb-minibuffer-setup): Declare. * lisp/gnus/mail-source.el (mail-source-bind-1) (mail-source-bind-common-1): Use `mapcar`. (mail-source-set-common-1): Use `dolist`. (display-time-event-handler): Declare. * lisp/gnus/mml-smime.el (mml-smime-epg-verify): Reduce code duplication. * lisp/gnus/mml.el (mml-parse-1): Reduce code duplication. * lisp/gnus/mml2015.el (mml2015-epg-verify): Reduce code duplication. * lisp/gnus/nnmail.el (nnmail-get-split-group): Tighten regexp. (nnmail-split-it): Reduce code duplication. * lisp/gnus/nnweb.el (nnweb-request-article): Avoid `setq`. * lisp/gnus/spam.el (BBDB): Use the `noerror` arg of `require`, and define all the functions for BBDB regardless if the require succeeded. (spam-exists-in-BBDB-p): Don't inline, not worth it. --- lisp/gnus/gmm-utils.el | 2 +- lisp/gnus/gnus-agent.el | 2 +- lisp/gnus/gnus-art.el | 14 ++-- lisp/gnus/gnus-cache.el | 6 +- lisp/gnus/gnus-group.el | 50 +++++------- lisp/gnus/gnus-html.el | 116 +++++++++++++-------------- lisp/gnus/gnus-msg.el | 122 ++++++++++++++-------------- lisp/gnus/gnus-spec.el | 38 ++++----- lisp/gnus/gnus-start.el | 9 +-- lisp/gnus/gnus-util.el | 17 ++-- lisp/gnus/gnus-uu.el | 1 + lisp/gnus/mail-source.el | 34 ++++---- lisp/gnus/mm-partial.el | 5 +- lisp/gnus/mm-util.el | 6 +- lisp/gnus/mml-smime.el | 8 +- lisp/gnus/mml.el | 32 ++++---- lisp/gnus/mml2015.el | 6 +- lisp/gnus/nnbabyl.el | 3 +- lisp/gnus/nnmail.el | 15 ++-- lisp/gnus/nnmairix.el | 6 +- lisp/gnus/nnoo.el | 103 ++++++++++++------------ lisp/gnus/nnweb.el | 10 +-- lisp/gnus/spam.el | 167 ++++++++++++++++++--------------------- 23 files changed, 374 insertions(+), 398 deletions(-) diff --git a/lisp/gnus/gmm-utils.el b/lisp/gnus/gmm-utils.el index c64bfea7caf..3542587319d 100644 --- a/lisp/gnus/gmm-utils.el +++ b/lisp/gnus/gmm-utils.el @@ -231,7 +231,7 @@ DEFAULT-MAP specifies the default key map for ICON-LIST." props))) t)) (if (symbolp icon-list) - (eval icon-list) + (symbol-value icon-list) icon-list)) map)) diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el index cb679b849f5..9af19bd02ca 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -735,7 +735,7 @@ be a select method." (interactive "P") (unless gnus-plugged (error "Groups can't be fetched when Gnus is unplugged")) - (gnus-group-iterate n 'gnus-agent-fetch-group)) + (gnus-group-iterate n #'gnus-agent-fetch-group)) (defun gnus-agent-fetch-group (&optional group) "Put all new articles in GROUP into the Agent." diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 7e5439a217e..4034d362af4 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -7617,7 +7617,7 @@ Calls `describe-variable' or `describe-function'." "Call `describe-key' when pushing the corresponding URL button." (let* ((key-string (replace-regexp-in-string gnus-button-handle-describe-prefix "" url)) - (keys (ignore-errors (eval `(kbd ,key-string))))) + (keys (ignore-errors (kbd key-string)))) (if keys (describe-key keys) (gnus-message 3 "Invalid key sequence in button: %s" key-string)))) @@ -8516,8 +8516,8 @@ For example: (defvar gnus-inhibit-article-treatments nil) ;; Dynamic variables. -(defvar part-number) ;FIXME: Lacks a "gnus-" prefix. -(defvar total-parts) ;FIXME: Lacks a "gnus-" prefix. +(defvar gnus-treat-part-number) +(defvar gnus-treat-total-parts) (defvar gnus-treat-type) (defvar gnus-treat-condition) (defvar gnus-treat-length) @@ -8525,8 +8525,8 @@ For example: (defun gnus-treat-article (condition &optional part-num total type) (let ((gnus-treat-condition condition) - (part-number part-num) - (total-parts total) + (gnus-treat-part-number part-num) + (gnus-treat-total-parts total) (gnus-treat-type type) (gnus-treat-length (- (point-max) (point-min))) (alist gnus-treatment-function-alist) @@ -8586,9 +8586,9 @@ For example: ((eq val 'head) nil) ((eq val 'first) - (eq part-number 1)) + (eq gnus-treat-part-number 1)) ((eq val 'last) - (eq part-number total-parts)) + (eq gnus-treat-part-number gnus-treat-total-parts)) ((numberp val) (< gnus-treat-length val)) (t diff --git a/lisp/gnus/gnus-cache.el b/lisp/gnus/gnus-cache.el index bea3d3bf03f..b17a11276c2 100644 --- a/lisp/gnus/gnus-cache.el +++ b/lisp/gnus/gnus-cache.el @@ -29,9 +29,7 @@ (require 'gnus) (require 'gnus-sum) -(eval-when-compile - (unless (fboundp 'gnus-agent-load-alist) - (defun gnus-agent-load-alist (group)))) +(declare-function gnus-agent-load-alist "gnus-agent" (group)) (defcustom gnus-cache-active-file (expand-file-name "active" gnus-cache-directory) @@ -55,7 +53,7 @@ If you only want to cache your nntp groups, you could set this variable to \"^nntp\". -If a group matches both gnus-cacheable-groups and gnus-uncacheable-groups +If a group matches both `gnus-cacheable-groups' and `gnus-uncacheable-groups' it's not cached." :group 'gnus-cache :type '(choice (const :tag "off" nil) diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index a165752881a..0444b05450b 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -40,9 +40,9 @@ (require 'mm-url) (require 'subr-x) (let ((features (cons 'gnus-group features))) - (require 'gnus-sum)) - (unless (boundp 'gnus-cache-active-hashtb) - (defvar gnus-cache-active-hashtb nil))) + (require 'gnus-sum))) + +(defvar gnus-cache-active-hashtb) (defvar tool-bar-mode) @@ -505,7 +505,8 @@ simple manner." (+ number (gnus-range-length (cdr (assq 'dormant gnus-tmp-marked))) (gnus-range-length (cdr (assq 'tick gnus-tmp-marked)))))) - (t number)) ?s) + (t number)) + ?s) (?R gnus-tmp-number-of-read ?s) (?U (if (gnus-active gnus-tmp-group) (gnus-number-of-unseen-articles-in-group gnus-tmp-group) @@ -516,7 +517,8 @@ simple manner." (?I (gnus-range-length (cdr (assq 'dormant gnus-tmp-marked))) ?d) (?T (gnus-range-length (cdr (assq 'tick gnus-tmp-marked))) ?d) (?i (+ (gnus-range-length (cdr (assq 'dormant gnus-tmp-marked))) - (gnus-range-length (cdr (assq 'tick gnus-tmp-marked)))) ?d) + (gnus-range-length (cdr (assq 'tick gnus-tmp-marked)))) + ?d) (?g gnus-tmp-group ?s) (?G gnus-tmp-qualified-group ?s) (?c (gnus-short-group-name gnus-tmp-group) @@ -1541,7 +1543,8 @@ if it is a string, only list groups matching REGEXP." (gnus-tmp-news-method-string (if gnus-tmp-method (format "(%s:%s)" (car gnus-tmp-method) - (cadr gnus-tmp-method)) "")) + (cadr gnus-tmp-method)) + "")) (gnus-tmp-marked-mark (if (and (numberp number) (zerop number) @@ -1985,31 +1988,18 @@ Take into consideration N (the prefix) and the list of marked groups." (let ((group (gnus-group-group-name))) (and group (list group)))))) -;;; !!!Surely gnus-group-iterate should be a macro instead? I can't -;;; imagine why I went through these contortions... -(eval-and-compile - (let ((function (make-symbol "gnus-group-iterate-function")) - (window (make-symbol "gnus-group-iterate-window")) - (groups (make-symbol "gnus-group-iterate-groups")) - (group (make-symbol "gnus-group-iterate-group"))) - (eval - `(defun gnus-group-iterate (arg ,function) - "Iterate FUNCTION over all process/prefixed groups. +(defun gnus-group-iterate (arg function) + "Iterate FUNCTION over all process/prefixed groups. FUNCTION will be called with the group name as the parameter and with point over the group in question." - (let ((,groups (gnus-group-process-prefix arg)) - (,window (selected-window)) - ,group) - (while ,groups - (setq ,group (car ,groups) - ,groups (cdr ,groups)) - (select-window ,window) - (gnus-group-remove-mark ,group) - (save-selected-window - (save-excursion - (funcall ,function ,group))))))))) - -(put 'gnus-group-iterate 'lisp-indent-function 1) + (declare (indent 1)) + (let ((window (selected-window))) + (dolist (group (gnus-group-process-prefix arg)) + (select-window window) + (gnus-group-remove-mark group) + (save-selected-window + (save-excursion + (funcall function group)))))) ;; Selecting groups. @@ -2807,7 +2797,7 @@ not-expirable articles, too." (format "Do you really want to delete these %d articles forever? " (length articles))) (gnus-request-expire-articles articles group - (if current-prefix-arg + (if oldp nil 'force))))) diff --git a/lisp/gnus/gnus-html.el b/lisp/gnus/gnus-html.el index 855d085c3a9..6a0cc0b47dc 100644 --- a/lisp/gnus/gnus-html.el +++ b/lisp/gnus/gnus-html.el @@ -151,7 +151,7 @@ fit these criteria." (defun gnus-html-wash-images () "Run through current buffer and replace img tags by images." - (let (tag parameters string start end images url alt-text + (let (tag parameters string start end images inhibit-images blocked-images) (if (buffer-live-p gnus-summary-buffer) (with-current-buffer gnus-summary-buffer @@ -169,65 +169,65 @@ fit these criteria." (delete-region (match-beginning 0) (match-end 0))) (setq end (point)) (when (string-match "src=\"\\([^\"]+\\)" parameters) - (gnus-message 8 "gnus-html-wash-tags: fetching image URL %s" url) - (setq url (gnus-html-encode-url (match-string 1 parameters)) - alt-text (when (string-match "\\(alt\\|title\\)=\"\\([^\"]+\\)" - parameters) - (xml-substitute-special (match-string 2 parameters)))) - (add-text-properties - start end - (list 'image-url url - 'image-displayer `(lambda (url start end) - (gnus-html-display-image url start end - ,alt-text)) - 'help-echo alt-text - 'button t - 'keymap gnus-html-image-map - 'gnus-image (list url start end alt-text))) - (if (string-match "\\`cid:" url) - ;; URLs with cid: have their content stashed in other - ;; parts of the MIME structure, so just insert them - ;; immediately. - (let* ((handle (mm-get-content-id (substring url (match-end 0)))) - (image (when (and handle - (not inhibit-images)) - (gnus-create-image - (mm-with-part handle (buffer-string)) - nil t)))) - (if image - (gnus-add-image - 'cid - (gnus-put-image - (gnus-rescale-image - image (gnus-html-maximum-image-size)) - (gnus-string-or (prog1 - (buffer-substring start end) - (delete-region start end)) - "*") - 'cid)) + (let ((url (gnus-html-encode-url (match-string 1 parameters))) + (alt-text (when (string-match "\\(alt\\|title\\)=\"\\([^\"]+\\)" + parameters) + (xml-substitute-special (match-string 2 parameters))))) + (gnus-message 8 "gnus-html-wash-tags: fetching image URL %s" url) + (add-text-properties + start end + (list 'image-url url + 'image-displayer `(lambda (url start end) + (gnus-html-display-image url start end + ,alt-text)) + 'help-echo alt-text + 'button t + 'keymap gnus-html-image-map + 'gnus-image (list url start end alt-text))) + (if (string-match "\\`cid:" url) + ;; URLs with cid: have their content stashed in other + ;; parts of the MIME structure, so just insert them + ;; immediately. + (let* ((handle (mm-get-content-id (substring url (match-end 0)))) + (image (when (and handle + (not inhibit-images)) + (gnus-create-image + (mm-with-part handle (buffer-string)) + nil t)))) + (if image + (gnus-add-image + 'cid + (gnus-put-image + (gnus-rescale-image + image (gnus-html-maximum-image-size)) + (gnus-string-or (prog1 + (buffer-substring start end) + (delete-region start end)) + "*") + 'cid)) + (make-text-button start end + 'help-echo url + 'keymap gnus-html-image-map))) + ;; Normal, external URL. + (if (or inhibit-images + (gnus-html-image-url-blocked-p url blocked-images)) (make-text-button start end 'help-echo url - 'keymap gnus-html-image-map))) - ;; Normal, external URL. - (if (or inhibit-images - (gnus-html-image-url-blocked-p url blocked-images)) - (make-text-button start end - 'help-echo url - 'keymap gnus-html-image-map) - ;; Non-blocked url - (let ((width - (when (string-match "width=\"?\\([0-9]+\\)" parameters) - (string-to-number (match-string 1 parameters)))) - (height - (when (string-match "height=\"?\\([0-9]+\\)" parameters) - (string-to-number (match-string 1 parameters))))) - ;; Don't fetch images that are really small. They're - ;; probably tracking pictures. - (when (and (or (null height) - (> height 4)) - (or (null width) - (> width 4))) - (gnus-html-display-image url start end alt-text))))))))) + 'keymap gnus-html-image-map) + ;; Non-blocked url + (let ((width + (when (string-match "width=\"?\\([0-9]+\\)" parameters) + (string-to-number (match-string 1 parameters)))) + (height + (when (string-match "height=\"?\\([0-9]+\\)" parameters) + (string-to-number (match-string 1 parameters))))) + ;; Don't fetch images that are really small. They're + ;; probably tracking pictures. + (when (and (or (null height) + (> height 4)) + (or (null width) + (> width 4))) + (gnus-html-display-image url start end alt-text)))))))))) (defun gnus-html-display-image (url start end &optional alt-text) "Display image at URL on text from START to END. diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el index 9ca82f881a8..49be7047855 100644 --- a/lisp/gnus/gnus-msg.el +++ b/lisp/gnus/gnus-msg.el @@ -610,19 +610,19 @@ If ARG is 1, prompt for a group name to find the posting style." (interactive "P") ;; We can't `let' gnus-newsgroup-name here, since that leads ;; to local variables leaking. - (let ((group gnus-newsgroup-name) - ;; make sure last viewed article doesn't affect posting styles: - (gnus-article-copy) - (buffer (current-buffer))) - (let ((gnus-newsgroup-name - (if arg - (if (= 1 (prefix-numeric-value arg)) - (gnus-group-completing-read - "Use posting style of group" - nil (gnus-read-active-file-p)) - (gnus-group-group-name)) - ""))) - (gnus-setup-message 'message (message-mail))))) + (let* ((group gnus-newsgroup-name) + ;; make sure last viewed article doesn't affect posting styles: + (gnus-article-copy) + (buffer (current-buffer)) + (gnus-newsgroup-name + (if arg + (if (= 1 (prefix-numeric-value arg)) + (gnus-group-completing-read + "Use posting style of group" + nil (gnus-read-active-file-p)) + (gnus-group-group-name)) + ""))) + (gnus-setup-message 'message (message-mail)))) (defun gnus-group-news (&optional arg) "Start composing a news. @@ -635,21 +635,21 @@ network. The corresponding back end must have a `request-post' method." (interactive "P") ;; We can't `let' gnus-newsgroup-name here, since that leads ;; to local variables leaking. - (let ((group gnus-newsgroup-name) - ;; make sure last viewed article doesn't affect posting styles: - (gnus-article-copy) - (buffer (current-buffer))) - (let ((gnus-newsgroup-name - (if arg - (if (= 1 (prefix-numeric-value arg)) - (gnus-group-completing-read "Use group" - nil - (gnus-read-active-file-p)) - (gnus-group-group-name)) - ""))) - (gnus-setup-message - 'message - (message-news (gnus-group-real-name gnus-newsgroup-name)))))) + (let* ((group gnus-newsgroup-name) + ;; make sure last viewed article doesn't affect posting styles: + (gnus-article-copy) + (buffer (current-buffer)) + (gnus-newsgroup-name + (if arg + (if (= 1 (prefix-numeric-value arg)) + (gnus-group-completing-read "Use group" + nil + (gnus-read-active-file-p)) + (gnus-group-group-name)) + ""))) + (gnus-setup-message + 'message + (message-news (gnus-group-real-name gnus-newsgroup-name))))) (defun gnus-group-post-news (&optional arg) "Start composing a message (a news by default). @@ -678,19 +678,19 @@ posting style." (interactive "P") ;; We can't `let' gnus-newsgroup-name here, since that leads ;; to local variables leaking. - (let ((group gnus-newsgroup-name) - ;; make sure last viewed article doesn't affect posting styles: - (gnus-article-copy) - (buffer (current-buffer))) - (let ((gnus-newsgroup-name - (if arg - (if (= 1 (prefix-numeric-value arg)) - (gnus-group-completing-read "Use group" - nil - (gnus-read-active-file-p)) - "") - gnus-newsgroup-name))) - (gnus-setup-message 'message (message-mail))))) + (let* ((group gnus-newsgroup-name) + ;; make sure last viewed article doesn't affect posting styles: + (gnus-article-copy) + (buffer (current-buffer)) + (gnus-newsgroup-name + (if arg + (if (= 1 (prefix-numeric-value arg)) + (gnus-group-completing-read "Use group" + nil + (gnus-read-active-file-p)) + "") + gnus-newsgroup-name))) + (gnus-setup-message 'message (message-mail)))) (defun gnus-summary-news-other-window (&optional arg) "Start composing a news in another window. @@ -703,26 +703,26 @@ network. The corresponding back end must have a `request-post' method." (interactive "P") ;; We can't `let' gnus-newsgroup-name here, since that leads ;; to local variables leaking. - (let ((group gnus-newsgroup-name) - ;; make sure last viewed article doesn't affect posting styles: - (gnus-article-copy) - (buffer (current-buffer))) - (let ((gnus-newsgroup-name - (if arg - (if (= 1 (prefix-numeric-value arg)) - (gnus-group-completing-read "Use group" - nil - (gnus-read-active-file-p)) - "") - gnus-newsgroup-name))) - (gnus-setup-message - 'message - (progn - (message-news (gnus-group-real-name gnus-newsgroup-name)) - (setq-local gnus-discouraged-post-methods - (remove - (car (gnus-find-method-for-group gnus-newsgroup-name)) - gnus-discouraged-post-methods))))))) + (let* ((group gnus-newsgroup-name) + ;; make sure last viewed article doesn't affect posting styles: + (gnus-article-copy) + (buffer (current-buffer)) + (gnus-newsgroup-name + (if arg + (if (= 1 (prefix-numeric-value arg)) + (gnus-group-completing-read "Use group" + nil + (gnus-read-active-file-p)) + "") + gnus-newsgroup-name))) + (gnus-setup-message + 'message + (progn + (message-news (gnus-group-real-name gnus-newsgroup-name)) + (setq-local gnus-discouraged-post-methods + (remove + (car (gnus-find-method-for-group gnus-newsgroup-name)) + gnus-discouraged-post-methods)))))) (defun gnus-summary-post-news (&optional arg) "Start composing a message. Post to the current group by default. diff --git a/lisp/gnus/gnus-spec.el b/lisp/gnus/gnus-spec.el index 0dfa9f99d35..a50d9f3a5f4 100644 --- a/lisp/gnus/gnus-spec.el +++ b/lisp/gnus/gnus-spec.el @@ -151,9 +151,9 @@ Return a list of updated types." (when (and (boundp buffer) (setq val (symbol-value buffer)) (gnus-buffer-live-p val)) - (set-buffer val)) - (setq new-format (symbol-value - (intern (format "gnus-%s-line-format" type))))) + (set-buffer val))) + (setq new-format (symbol-value + (intern (format "gnus-%s-line-format" type)))) (setq entry (cdr (assq type gnus-format-specs))) (if (and (car entry) (equal (car entry) new-format)) @@ -170,7 +170,7 @@ Return a list of updated types." new-format (symbol-value (intern (format "gnus-%s-line-format-alist" type))) - (not (string-match "mode$" (symbol-name type)))))) + (not (string-match "mode\\'" (symbol-name type)))))) ;; Enter the new format spec into the list. (if entry (progn @@ -526,13 +526,13 @@ or to characters when given a pad value." (if (eq spec ?%) ;; "%%" just results in a "%". (insert "%") - (cond - ;; Do tilde forms. - ((eq spec ?@) - (setq elem (list tilde-form ?s))) - ;; Treat user defined format specifiers specially. - (user-defined - (setq elem + (setq elem + (cond + ;; Do tilde forms. + ((eq spec ?@) + (list tilde-form ?s)) + ;; Treat user defined format specifiers specially. + (user-defined (list (list (intern (format (if (stringp user-defined) @@ -540,14 +540,14 @@ or to characters when given a pad value." "gnus-user-format-function-%c") user-defined)) 'gnus-tmp-header) - ?s))) - ;; Find the specification from `spec-alist'. - ((setq elem (cdr (assq (or extended-spec spec) spec-alist)))) - ;; We used to use "%l" for displaying the grouplens score. - ((eq spec ?l) - (setq elem '("" ?s))) - (t - (setq elem '("*" ?s)))) + ?s)) + ;; Find the specification from `spec-alist'. + ((cdr (assq (or extended-spec spec) spec-alist))) + ;; We used to use "%l" for displaying the grouplens score. + ((eq spec ?l) + '("" ?s)) + (t + '("*" ?s)))) (setq elem-type (cadr elem)) ;; Insert the new format elements. (when pad-width diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el index a3159595c45..1554635a3f2 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el @@ -2337,7 +2337,7 @@ If FORCE is non-nil, the .newsrc file is read." gnus-newsrc-file-version gnus-version))))))) (defun gnus-convert-mark-converter-prompt (converter no-prompt) - "Indicate whether CONVERTER requires gnus-convert-old-newsrc to + "Indicate whether CONVERTER requires `gnus-convert-old-newsrc' to display the conversion prompt. NO-PROMPT may be nil (prompt), t (no prompt), or any form that can be called as a function. The form should return either t or nil." @@ -2989,13 +2989,12 @@ SPECIFIC-VARIABLES, or those in `gnus-variable-list'." ;;; Child functions. ;;; -(defvar gnus-child-mode nil) +;; (defvar gnus-child-mode nil) (defun gnus-child-mode () "Minor mode for child Gnusae." - ;; FIXME: gnus-child-mode appears to never be set (i.e. it'll always be nil): - ;; Remove, or fix and use define-minor-mode. - (add-minor-mode 'gnus-child-mode " Child" (make-sparse-keymap)) + ;; FIXME: gnus-child-mode appears to never be set (i.e. it'll always be nil). + ;; (add-minor-mode 'gnus-child-mode " Child" (make-sparse-keymap)) (gnus-run-hooks 'gnus-child-mode-hook)) (define-obsolete-function-alias 'gnus-slave-mode #'gnus-child-mode "28.1") diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index b8451028d1e..408293f1a16 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -1203,9 +1203,7 @@ ARG is passed to the first function." (string-equal (downcase x) (downcase y))))) (defcustom gnus-use-byte-compile t - "If non-nil, byte-compile crucial run-time code. -Setting it to nil has no effect after the first time `gnus-byte-compile' -is run." + "If non-nil, byte-compile crucial run-time code." :type 'boolean :version "22.1" :group 'gnus-various) @@ -1213,13 +1211,8 @@ is run." (defun gnus-byte-compile (form) "Byte-compile FORM if `gnus-use-byte-compile' is non-nil." (if gnus-use-byte-compile - (progn - (require 'bytecomp) - (defalias 'gnus-byte-compile - (lambda (form) - (let ((byte-compile-warnings '(unresolved callargs redefine))) - (byte-compile form)))) - (gnus-byte-compile form)) + (let ((byte-compile-warnings '(unresolved callargs redefine))) + (byte-compile form)) form)) (defun gnus-remassoc (key alist) @@ -1385,6 +1378,7 @@ SPEC is a predicate specifier that contains stuff like `or', `and', (declare-function iswitchb-read-buffer "iswitchb" (prompt &optional default require-match _predicate start matches-set)) +(declare-function iswitchb-minibuffer-setup "iswitchb") (defvar iswitchb-temp-buflist) (defvar iswitchb-mode) @@ -1449,7 +1443,8 @@ CHOICE is a list of the choice char and help message at IDX." prompt (concat (mapconcat (lambda (s) (char-to-string (car s))) - choice ", ") ", ?")) + choice ", ") + ", ?")) (setq tchar (read-char)) (when (not (assq tchar choice)) (setq tchar nil) diff --git a/lisp/gnus/gnus-uu.el b/lisp/gnus/gnus-uu.el index 2bc1f864deb..e4aaf92c89c 100644 --- a/lisp/gnus/gnus-uu.el +++ b/lisp/gnus/gnus-uu.el @@ -1949,6 +1949,7 @@ The user will be asked for a file name." (gnus-uu-choose-action file-name gnus-uu-ext-to-mime-list) file-name)) (insert (format "Content-Transfer-Encoding: %s\n\n" encoding)) + ;; FIXME: Shouldn't we set-buffer before saving the restriction? --Stef (save-restriction (set-buffer gnus-message-buffer) (goto-char (point-min)) diff --git a/lisp/gnus/mail-source.el b/lisp/gnus/mail-source.el index 212657aec26..4f02d86f441 100644 --- a/lisp/gnus/mail-source.el +++ b/lisp/gnus/mail-source.el @@ -380,13 +380,10 @@ All keywords that can be used must be listed here.")) ;; suitable for usage in a `let' form (eval-and-compile (defun mail-source-bind-1 (type) - (let* ((defaults (cdr (assq type mail-source-keyword-map))) - default bind) - (while (setq default (pop defaults)) - (push (list (mail-source-strip-keyword (car default)) - nil) - bind)) - bind))) + (mapcar (lambda (default) + (list (mail-source-strip-keyword (car default)) + nil)) + (cdr (assq type mail-source-keyword-map))))) (defmacro mail-source-bind (type-source &rest body) "Return a `let' form that binds all variables in source TYPE. @@ -476,20 +473,16 @@ the `mail-source-keyword-map' variable." (eval-and-compile (defun mail-source-bind-common-1 () - (let* ((defaults mail-source-common-keyword-map) - default bind) - (while (setq default (pop defaults)) - (push (list (mail-source-strip-keyword (car default)) - nil) - bind)) - bind))) + (mapcar (lambda (default) + (list (mail-source-strip-keyword (car default)) + nil)) + mail-source-common-keyword-map))) (defun mail-source-set-common-1 (source) (let* ((type (pop source)) - (defaults mail-source-common-keyword-map) (defaults-1 (cdr (assq type mail-source-keyword-map))) - default value keyword) - (while (setq default (pop defaults)) + value keyword) + (dolist (default mail-source-common-keyword-map) (set (mail-source-strip-keyword (setq keyword (car default))) (if (setq value (plist-get source keyword)) (mail-source-value value) @@ -919,7 +912,7 @@ authentication. To do that, you need to set the `message-send-mail-function' variable as `message-smtpmail-send-it' and put the following line in your ~/.gnus.el file: -\(add-hook \\='message-send-mail-hook \\='mail-source-touch-pop) +\(add-hook \\='message-send-mail-hook #\\='mail-source-touch-pop) See the Gnus manual for details." (let ((sources (if mail-source-primary-source @@ -963,6 +956,8 @@ See the Gnus manual for details." ;; (element 0 of the vector is nil if the timer is active). (aset mail-source-report-new-mail-idle-timer 0 nil))) +(declare-function display-time-event-handler "time" ()) + (defun mail-source-report-new-mail (arg) "Toggle whether to report when new mail is available. This only works when `display-time' is enabled." @@ -1075,7 +1070,8 @@ This only works when `display-time' is enabled." (if (and (imap-open server port stream authentication buf) (imap-authenticate user (or (cdr (assoc from mail-source-password-cache)) - password) buf)) + password) + buf)) (let ((mailbox-list (if (listp mailbox) mailbox (list mailbox)))) (dolist (mailbox mailbox-list) (when (imap-mailbox-select mailbox nil buf) diff --git a/lisp/gnus/mm-partial.el b/lisp/gnus/mm-partial.el index 165c19139ce..8d4913e6fbd 100644 --- a/lisp/gnus/mm-partial.el +++ b/lisp/gnus/mm-partial.el @@ -39,7 +39,8 @@ gnus-newsgroup-name) (when (search-forward id nil t) (let ((nhandles (mm-dissect-buffer - nil gnus-article-loose-mime)) nid) + nil gnus-article-loose-mime)) + nid) (if (consp (car nhandles)) (mm-destroy-parts nhandles) (setq nid (cdr (assq 'id @@ -90,7 +91,7 @@ If NO-DISPLAY is nil, display it. Otherwise, do nothing after replacing." (if ntotal (if total (unless (eq total ntotal) - (error "The numbers of total are different")) + (error "The numbers of total are different")) (setq total ntotal))) (unless (< nn n) (unless (eq nn n) diff --git a/lisp/gnus/mm-util.el b/lisp/gnus/mm-util.el index 329b9e8884d..be279b6cf1f 100644 --- a/lisp/gnus/mm-util.el +++ b/lisp/gnus/mm-util.el @@ -144,9 +144,9 @@ is not available." ;; on there being some coding system matching each `mime-charset' ;; property defined, as there should be.) ((and (mm-coding-system-p charset) -;;; Doing this would potentially weed out incorrect charsets. -;;; charset -;;; (eq charset (coding-system-get charset 'mime-charset)) + ;; Doing this would potentially weed out incorrect charsets. + ;; charset + ;; (eq charset (coding-system-get charset 'mime-charset)) ) charset) ;; Use coding system Emacs knows. diff --git a/lisp/gnus/mml-smime.el b/lisp/gnus/mml-smime.el index e97e3e9a06e..eabb56b3038 100644 --- a/lisp/gnus/mml-smime.el +++ b/lisp/gnus/mml-smime.el @@ -369,7 +369,7 @@ Content-Disposition: attachment; filename=smime.p7s (goto-char (point-max))))) (defun mml-smime-epg-encrypt (cont) - (let* ((inhibit-redisplay t) + (let* ((inhibit-redisplay t) ;FIXME: Why? (boundary (mml-compute-boundary cont)) (cipher (mml-secure-epg-encrypt 'CMS cont))) (delete-region (point-min) (point-max)) @@ -410,9 +410,9 @@ Content-Disposition: attachment; filename=smime.p7m (setq plain (epg-verify-string context (mm-get-part signature) part)) (error (mm-sec-error 'gnus-info "Failed") - (if (eq (car error) 'quit) - (mm-sec-status 'gnus-details "Quit.") - (mm-sec-status 'gnus-details (format "%S" error))) + (mm-sec-status 'gnus-details (if (eq (car error) 'quit) + "Quit." + (format "%S" error))) (throw 'error handle))) (mm-sec-status 'gnus-info diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el index acde958c05b..54f8715baf0 100644 --- a/lisp/gnus/mml.el +++ b/lisp/gnus/mml.el @@ -241,22 +241,24 @@ part. This is for the internal use, you should never modify the value.") (method (cdr (assq 'method taginfo))) tags) (save-excursion - (if (re-search-forward - "<#/?\\(multipart\\|part\\|external\\|mml\\)." nil t) - (setq secure-mode "multipart") - (setq secure-mode "part"))) + (setq secure-mode + (if (re-search-forward + "<#/?\\(multipart\\|part\\|external\\|mml\\)." + nil t) + "multipart" + "part"))) (save-excursion (goto-char location) (re-search-forward "<#secure[^\n]*>\n")) (delete-region (match-beginning 0) (match-end 0)) - (cond ((string= mode "sign") - (setq tags (list "sign" method))) - ((string= mode "encrypt") - (setq tags (list "encrypt" method))) - ((string= mode "signencrypt") - (setq tags (list "sign" method "encrypt" method))) - (t - (error "Unknown secure mode %s" mode))) + (setq tags (cond ((string= mode "sign") + (list "sign" method)) + ((string= mode "encrypt") + (list "encrypt" method)) + ((string= mode "signencrypt") + (list "sign" method "encrypt" method)) + (t + (error "Unknown secure mode %s" mode)))) (eval `(mml-insert-tag ,secure-mode ,@tags ,(if keyfile "keyfile") @@ -1598,7 +1600,8 @@ or the `pop-to-buffer' function." (interactive "P") (setq mml-preview-buffer (generate-new-buffer (concat (if raw "*Raw MIME preview of " - "*MIME preview of ") (buffer-name)))) + "*MIME preview of ") + (buffer-name)))) (require 'gnus-msg) ; for gnus-setup-posting-charset (save-excursion (let* ((buf (current-buffer)) @@ -1655,7 +1658,8 @@ or the `pop-to-buffer' function." (use-local-map nil) (add-hook 'kill-buffer-hook (lambda () - (mm-destroy-parts gnus-article-mime-handles)) nil t) + (mm-destroy-parts gnus-article-mime-handles)) + nil t) (setq buffer-read-only t) (local-set-key "q" (lambda () (interactive) (kill-buffer nil))) (local-set-key "=" (lambda () (interactive) (delete-other-windows))) diff --git a/lisp/gnus/mml2015.el b/lisp/gnus/mml2015.el index 8eda59372fb..53454bf16d8 100644 --- a/lisp/gnus/mml2015.el +++ b/lisp/gnus/mml2015.el @@ -869,9 +869,9 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." (setq plain (epg-verify-string context signature part)) (error (mm-sec-error 'gnus-info "Failed") - (if (eq (car error) 'quit) - (mm-sec-status 'gnus-details "Quit.") - (mm-sec-status 'gnus-details (mml2015-format-error error))) + (mm-sec-status 'gnus-details (if (eq (car error) 'quit) + "Quit." + (mml2015-format-error error))) (throw 'error handle))) (mm-sec-status 'gnus-info (mml2015-epg-verify-result-to-string diff --git a/lisp/gnus/nnbabyl.el b/lisp/gnus/nnbabyl.el index 5149acc0e72..41f7f62fae6 100644 --- a/lisp/gnus/nnbabyl.el +++ b/lisp/gnus/nnbabyl.el @@ -263,7 +263,8 @@ (nnmail-expired-article-p newsgroup (buffer-substring - (point) (progn (end-of-line) (point))) force)) + (point) (progn (end-of-line) (point))) + force)) (progn (unless (eq nnmail-expiry-target 'delete) (with-temp-buffer diff --git a/lisp/gnus/nnmail.el b/lisp/gnus/nnmail.el index 59d61379f14..251ae657bbf 100644 --- a/lisp/gnus/nnmail.el +++ b/lisp/gnus/nnmail.el @@ -712,7 +712,7 @@ If SOURCE is a directory spec, try to return the group name component." (if (eq (car source) 'directory) (let ((file (file-name-nondirectory file))) (mail-source-bind (directory source) - (if (string-match (concat (regexp-quote suffix) "$") file) + (if (string-match (concat (regexp-quote suffix) "\\'") file) (substring file 0 (match-beginning 0)) nil))) nil)) @@ -1339,7 +1339,8 @@ to actually put the message in the right group." (let ((success t)) (dolist (mbx (message-unquote-tokens (message-tokenize-header - (message-fetch-field "Newsgroups") ", ")) success) + (message-fetch-field "Newsgroups") ", ")) + success) (let ((to-newsgroup (gnus-group-prefixed-name mbx gnus-command-method))) (or (gnus-active to-newsgroup) (gnus-activate-group to-newsgroup) @@ -1433,11 +1434,11 @@ See the documentation for the variable `nnmail-split-fancy' for details." ;; we do not exclude foo.list just because ;; the header is: ``To: x-foo, foo'' (goto-char end) - (if (and (re-search-backward (cadr split-rest) - after-header-name t) - (> (match-end 0) start-of-value)) - (setq split-rest nil) - (setq split-rest (cddr split-rest)))) + (setq split-rest + (unless (and (re-search-backward (cadr split-rest) + after-header-name t) + (> (match-end 0) start-of-value)) + (cddr split-rest)))) (when split-rest (goto-char end) ;; Someone might want to do a \N sub on this match, so diff --git a/lisp/gnus/nnmairix.el b/lisp/gnus/nnmairix.el index 5e8ad4fa9ae..8b3ab40e225 100644 --- a/lisp/gnus/nnmairix.el +++ b/lisp/gnus/nnmairix.el @@ -676,9 +676,9 @@ Other back ends might or might not work.") (autoload 'nnimap-request-update-info-internal "nnimap") (deffoo nnmairix-request-marks (group info &optional server) -;; propagate info from underlying IMAP folder to nnmairix group -;; This is currently experimental and must be explicitly activated -;; with nnmairix-propagate-marks-to-nnmairix-group + ;; propagate info from underlying IMAP folder to nnmairix group + ;; This is currently experimental and must be explicitly activated + ;; with nnmairix-propagate-marks-to-nnmairix-group (when server (nnmairix-open-server server)) (let* ((qualgroup (gnus-group-prefixed-name diff --git a/lisp/gnus/nnoo.el b/lisp/gnus/nnoo.el index cd0a5e6de99..39469d140d9 100644 --- a/lisp/gnus/nnoo.el +++ b/lisp/gnus/nnoo.el @@ -85,20 +85,14 @@ (defun nnoo-import-1 (backend imports) (let ((call-function - (if (symbolp (car imports)) (pop imports) 'nnoo-parent-function)) - imp functions function) - (while (setq imp (pop imports)) - (setq functions - (or (cdr imp) - (nnoo-functions (car imp)))) - (while functions - (unless (fboundp - (setq function - (nnoo-symbol backend - (nnoo-rest-symbol (car functions))))) - (eval `(deffoo ,function (&rest args) - (,call-function ',backend ',(car functions) args)))) - (pop functions))))) + (if (symbolp (car imports)) (pop imports) #'nnoo-parent-function))) + (dolist (imp imports) + (dolist (fun (or (cdr imp) (nnoo-functions (car imp)))) + (let ((function (nnoo-symbol backend (nnoo-rest-symbol fun)))) + (unless (fboundp function) + ;; FIXME: Use `defalias' and closures to avoid `eval'. + (eval `(deffoo ,function (&rest args) + (,call-function ',backend ',fun args))))))))) (defun nnoo-parent-function (backend function args) (let ((pbackend (nnoo-backend function)) @@ -131,22 +125,21 @@ (defmacro nnoo-map-functions (backend &rest maps) (declare (indent 1)) - `(nnoo-map-functions-1 ',backend ',maps)) - -(defun nnoo-map-functions-1 (backend maps) - (let (m margs i) - (while (setq m (pop maps)) - (setq i 0 - margs nil) - (while (< i (length (cdr m))) - (if (numberp (nth i (cdr m))) - (push `(nth ,i args) margs) - (push (nth i (cdr m)) margs)) - (cl-incf i)) - (eval `(deffoo ,(nnoo-symbol backend (nnoo-rest-symbol (car m))) + `(progn + ,@(mapcar + (lambda (m) + (let ((margs nil)) + (dotimes (i (length (cdr m))) + (push (if (numberp (nth i (cdr m))) + `(nth ,i args) + (nth i (cdr m))) + margs)) + `(deffoo ,(nnoo-symbol backend (nnoo-rest-symbol (car m))) (&rest args) + (ignore args) ;; Not always used! (nnoo-parent-function ',backend ',(car m) - ,(cons 'list (nreverse margs)))))))) + ,(cons 'list (nreverse margs)))))) + maps))) (defun nnoo-backend (symbol) (string-match "^[^-]+-" (symbol-name symbol)) @@ -273,19 +266,27 @@ (defmacro nnoo-define-basics (backend) "Define `close-server', `server-opened' and `status-message'." - `(eval-and-compile - (nnoo-define-basics-1 ',backend))) - -(defun nnoo-define-basics-1 (backend) - (dolist (function '(server-opened status-message)) - (eval `(deffoo ,(nnoo-symbol backend function) (&optional server) - (,(nnoo-symbol 'nnoo function) ',backend server)))) - (dolist (function '(close-server)) - (eval `(deffoo ,(nnoo-symbol backend function) (&optional server defs) - (,(nnoo-symbol 'nnoo function) ',backend server)))) - (eval `(deffoo ,(nnoo-symbol backend 'open-server) - (server &optional defs) - (nnoo-change-server ',backend server defs)))) + (let ((form + ;; We wrap the definitions in `when t' here so that a subsequent + ;; "real" definition of one those doesn't trigger a "defined multiple + ;; times" warning. + `(when t + ,@(mapcar (lambda (fun) + `(deffoo ,(nnoo-symbol backend fun) (&optional server) + (,(nnoo-symbol 'nnoo fun) ',backend server))) + '(server-opened status-message)) + (deffoo ,(nnoo-symbol backend 'close-server) (&optional server _defs) + (,(nnoo-symbol 'nnoo 'close-server) ',backend server)) + (deffoo ,(nnoo-symbol backend 'open-server) (server &optional defs) + (nnoo-change-server ',backend server defs))))) + ;; Wrapping with `when' has the downside that the compiler now doesn't + ;; "know" that these functions are defined, so to avoid "not known to be + ;; defined" warnings we eagerly define them during the compilation. + ;; This is fairly nasty since it will override previous "real" definitions + ;; (e.g. when compiling this in an Emacs instance that's running Gnus), but + ;; that's also what the previous code did, so it sucks but is not worse. + (eval form t) + form)) (defmacro nnoo-define-skeleton (backend) "Define all required backend functions for BACKEND. @@ -294,17 +295,17 @@ All functions will return nil and report an error." (nnoo-define-skeleton-1 ',backend))) (defun nnoo-define-skeleton-1 (backend) - (let ((functions '(retrieve-headers - request-close request-article - request-group close-group - request-list request-post request-list-newsgroups)) - function fun) - (while (setq function (pop functions)) - (when (not (fboundp (setq fun (nnoo-symbol backend function)))) + (dolist (op '(retrieve-headers + request-close request-article + request-group close-group + request-list request-post request-list-newsgroups)) + (let ((fun (nnoo-symbol backend op))) + (unless (fboundp fun) + ;; FIXME: Use `defalias' and closures to avoid `eval'. (eval `(deffoo ,fun - (&rest args) - (nnheader-report ',backend ,(format "%s-%s not implemented" - backend function)))))))) + (&rest _args) + (nnheader-report ',backend ,(format "%s-%s not implemented" + backend op)))))))) (defun nnoo-set (server &rest args) (let ((parents (nnoo-parents (car server))) diff --git a/lisp/gnus/nnweb.el b/lisp/gnus/nnweb.el index 2a948254717..dd71bea72e2 100644 --- a/lisp/gnus/nnweb.el +++ b/lisp/gnus/nnweb.el @@ -154,17 +154,17 @@ Valid types include `google', `dejanews', and `gmane'.") (and (stringp article) (nnweb-definition 'id t) (let ((fetch (nnweb-definition 'id)) - art active) - (when (string-match "^<\\(.*\\)>$" article) - (setq art (match-string 1 article))) + (art (when (string-match "^<\\(.*\\)>$" article) + (match-string 1 article))) + active) (when (and fetch art) (setq url (format fetch (mm-url-form-encode-xwfu art))) (mm-url-insert url) (if (nnweb-definition 'reference t) (setq article - (funcall (nnweb-definition - 'reference) article))))))) + (funcall (nnweb-definition 'reference) + article))))))) (unless nnheader-callback-function (funcall (nnweb-definition 'article))) (nnheader-report 'nnweb "Fetched article %s" article) diff --git a/lisp/gnus/spam.el b/lisp/gnus/spam.el index 3f4fd3614ee..00dcd00ceab 100644 --- a/lisp/gnus/spam.el +++ b/lisp/gnus/spam.el @@ -321,8 +321,8 @@ Default to t if one of the spam-use-* variables is set." :type 'string :group 'spam) -;;; TODO: deprecate this variable, it's confusing since it's a list of strings, -;;; not regular expressions +;; TODO: deprecate this variable, it's confusing since it's a list of strings, +;; not regular expressions (defcustom spam-junk-mailgroups (cons spam-split-group '("mail.junk" "poste.pourriel")) @@ -1836,7 +1836,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." ;; return the number of articles processed (length articles)))) -;;; log a ham- or spam-processor invocation to the registry +;; log a ham- or spam-processor invocation to the registry (defun spam-log-processing-to-registry (id type classification backend group) (when spam-log-to-registry (if (and (stringp id) @@ -1855,7 +1855,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." "%s call with bad ID, type, classification, spam-backend, or group" "spam-log-processing-to-registry"))))) -;;; check if a ham- or spam-processor registration has been done +;; check if a ham- or spam-processor registration has been done (defun spam-log-registered-p (id type) (when spam-log-to-registry (if (and (stringp id) @@ -1868,8 +1868,8 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." "spam-log-registered-p")) nil)))) -;;; check what a ham- or spam-processor registration says -;;; returns nil if conflicting registrations are found +;; check what a ham- or spam-processor registration says +;; returns nil if conflicting registrations are found (defun spam-log-registration-type (id type) (let ((count 0) decision) @@ -1885,7 +1885,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." decision))) -;;; check if a ham- or spam-processor registration needs to be undone +;; check if a ham- or spam-processor registration needs to be undone (defun spam-log-unregistration-needed-p (id type classification backend) (when spam-log-to-registry (if (and (stringp id) @@ -1908,7 +1908,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." nil)))) -;;; undo a ham- or spam-processor registration (the group is not used) +;; undo a ham- or spam-processor registration (the group is not used) (defun spam-log-undo-registration (id type classification backend &optional group) (when (and spam-log-to-registry @@ -2034,94 +2034,83 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." ;;{{{ BBDB -;;; original idea for spam-check-BBDB from Alexander Kotelnikov -;;; +;; original idea for spam-check-BBDB from Alexander Kotelnikov +;; ;; all this is done inside a condition-case to trap errors ;; Autoloaded in message, which we require. (declare-function gnus-extract-address-components "gnus-util" (from)) -(eval-and-compile - (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)) - - (add-hook 'bbdb-change-hook 'spam-clear-cache-BBDB) - - (defun spam-enter-ham-BBDB (addresses &optional remove) - "Enter an address into the BBDB; implies ham (non-spam) sender" - (dolist (from addresses) - (when (stringp from) - (let* ((parsed-address (gnus-extract-address-components from)) - (name (or (nth 0 parsed-address) "Ham Sender")) - (remove-function (if remove - 'bbdb-delete-record-internal - 'ignore)) - (net-address (nth 1 parsed-address)) - (record (and net-address - (spam-exists-in-BBDB-p net-address)))) - (when net-address - (gnus-message 6 "%s address %s %s BBDB" - (if remove "Deleting" "Adding") - from - (if remove "from" "to")) - (if record - (funcall remove-function record) - (bbdb-create-internal name nil net-address nil nil - "ham sender added by spam.el"))))))) - - (defun spam-BBDB-register-routine (articles &optional unregister) - (let (addresses) - (dolist (article articles) - (when (stringp (spam-fetch-field-from-fast article)) - (push (spam-fetch-field-from-fast article) addresses))) - ;; now do the register/unregister action - (spam-enter-ham-BBDB addresses unregister))) - - (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 ((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 - nil))))))) +(require 'bbdb nil 'noerror) +(require 'bbdb-com nil 'noerror) + +(declare-function bbdb-records "bbdb" ()) +(declare-function bbdb-gethash "bbdb" (key &optional predicate)) +(declare-function bbdb-create-internal "bbdb-com" (&rest spec)) + +;; when the BBDB changes, we want to clear out our cache +(defun spam-clear-cache-BBDB (&rest immaterial) + (spam-clear-cache 'spam-use-BBDB)) + +(when (featurep 'bbdb-com) + (add-hook 'bbdb-change-hook #'spam-clear-cache-BBDB)) + +(defun spam-enter-ham-BBDB (addresses &optional remove) + "Enter an address into the BBDB; implies ham (non-spam) sender" + (dolist (from addresses) + (when (stringp from) + (let* ((parsed-address (gnus-extract-address-components from)) + (name (or (nth 0 parsed-address) "Ham Sender")) + (remove-function (if remove + 'bbdb-delete-record-internal + 'ignore)) + (net-address (nth 1 parsed-address)) + (record (and net-address + (spam-exists-in-BBDB-p net-address)))) + (when net-address + (gnus-message 6 "%s address %s %s BBDB" + (if remove "Deleting" "Adding") + from + (if remove "from" "to")) + (if record + (funcall remove-function record) + (bbdb-create-internal name nil net-address nil nil + "ham sender added by spam.el"))))))) + +(defun spam-BBDB-register-routine (articles &optional unregister) + (let (addresses) + (dolist (article articles) + (when (stringp (spam-fetch-field-from-fast article)) + (push (spam-fetch-field-from-fast article) addresses))) + ;; now do the register/unregister action + (spam-enter-ham-BBDB addresses unregister))) + +(defun spam-BBDB-unregister-routine (articles) + (spam-BBDB-register-routine articles t)) + +(defun 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 ((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 + nil))))) ;;}}} ;;{{{ ifile -;;; check the ifile backend; return nil if the mail was NOT classified -;;; as spam +;; check the ifile backend; return nil if the mail was NOT classified +;; as spam (defun spam-get-ifile-database-parameter () @@ -2240,7 +2229,7 @@ Uses `gnus-newsgroup-name' if category is nil (for ham registration)." (let ((kill-whole-line t)) (kill-line))) -;;; address can be a list, too +;; address can be a list, too (defun spam-enter-whitelist (address &optional remove) "Enter ADDRESS (list or single) into the whitelist. With a non-nil REMOVE, remove them." @@ -2249,7 +2238,7 @@ With a non-nil REMOVE, remove them." (setq spam-whitelist-cache nil) (spam-clear-cache 'spam-use-whitelist)) -;;; address can be a list, too +;; address can be a list, too (defun spam-enter-blacklist (address &optional remove) "Enter ADDRESS (list or single) into the blacklist. With a non-nil REMOVE, remove them." @@ -2310,8 +2299,8 @@ With a non-nil REMOVE, remove the ADDRESSES." (cl-return))) found))) -;;; returns t if the sender is in the whitelist, nil or -;;; spam-split-group otherwise +;; returns t if the sender is in the whitelist, nil or +;; spam-split-group otherwise (defun spam-check-whitelist () ;; FIXME! Should it detect when file timestamps change? (unless spam-whitelist-cache -- 2.39.2