diff options
Diffstat (limited to 'lisp/gnus')
82 files changed, 1284 insertions, 1619 deletions
diff --git a/lisp/gnus/canlock.el b/lisp/gnus/canlock.el index 7c657ead78d..0bd47cdde9a 100644 --- a/lisp/gnus/canlock.el +++ b/lisp/gnus/canlock.el @@ -41,9 +41,6 @@ ;;; Code: -(eval-when-compile - (require 'cl)) - (require 'sha1) (defvar mail-header-separator) diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el index c69d64546c5..532fd7e7b8e 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -31,8 +31,7 @@ (require 'gnus-srvr) (require 'gnus-util) (require 'timer) -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (autoload 'gnus-server-update-server "gnus-srvr") (autoload 'gnus-agent-customize-category "gnus-cus") @@ -332,9 +331,9 @@ manipulated as follows: `(progn (defmacro ,name (category) (list 'cdr (list 'assq '',prop-name category))) - (defsetf ,name (category) (value) - (list 'gnus-agent-cat-set-property - category '',prop-name value)))) + (gv-define-setter ,name (value category) + (list 'gnus-agent-cat-set-property + category '',prop-name value)))) ) (defmacro gnus-agent-cat-name (category) @@ -361,11 +360,7 @@ manipulated as follows: (gnus-agent-cat-defaccessor gnus-agent-cat-enable-undownloaded-faces agent-enable-undownloaded-faces) - -;; This form may expand to code that uses CL functions at run-time, -;; but that's OK since those functions will only ever be called from -;; something like `setf', so only when CL is loaded anyway. -(defsetf gnus-agent-cat-groups gnus-agent-set-cat-groups) +(gv-define-simple-setter gnus-agent-cat-groups gnus-agent-set-cat-groups) (defun gnus-agent-set-cat-groups (category groups) (unless (eq groups 'ignore) @@ -1108,7 +1103,7 @@ downloadable." gnus-newsgroup-cached) (setq articles (gnus-sorted-ndifference (gnus-sorted-ndifference - (gnus-copy-sequence articles) + (copy-tree articles) gnus-newsgroup-downloadable) gnus-newsgroup-cached))) @@ -1123,7 +1118,7 @@ downloadable." (when gnus-newsgroup-processable (setq gnus-newsgroup-downloadable (let* ((dl gnus-newsgroup-downloadable) - (processable (sort (gnus-copy-sequence gnus-newsgroup-processable) '<)) + (processable (sort (copy-tree gnus-newsgroup-processable) '<)) (gnus-newsgroup-downloadable processable)) (gnus-agent-summary-fetch-group) @@ -1513,7 +1508,7 @@ downloaded into the agent." (let* ((fetched-articles (list nil)) (tail-fetched-articles fetched-articles) (dir (gnus-agent-group-pathname group)) - (date (time-to-days (current-time))) + (date (time-to-days nil)) (case-fold-search t) pos crosses (file-name-coding-system nnmail-pathname-coding-system)) @@ -2180,7 +2175,7 @@ article counts for each of the method's subscribed groups." 'gnus-agent-file-loading-local 'gnus-agent-read-and-cache-local)) (when gnus-agent-article-local-times - (incf gnus-agent-article-local-times))) + (cl-incf gnus-agent-article-local-times))) gnus-agent-article-local)) (defun gnus-agent-read-and-cache-local (file) @@ -2833,7 +2828,7 @@ The following commands are available: "Copy the current category." (interactive (list (gnus-category-name) (intern (read-string "New name: ")))) (let ((info (assq category gnus-category-alist))) - (push (let ((newcat (gnus-copy-sequence info))) + (push (let ((newcat (copy-tree info))) (setf (gnus-agent-cat-name newcat) to) (setf (gnus-agent-cat-groups newcat) nil) newcat) @@ -3089,7 +3084,7 @@ FORCE is equivalent to setting the expiration predicates to true." (nov-entries-deleted 0) (info (gnus-get-info group)) (alist gnus-agent-article-alist) - (day (- (time-to-days (current-time)) + (day (- (time-to-days nil) (gnus-agent-find-parameter group 'agent-days-until-old))) (specials (if (and alist (not force)) @@ -3353,9 +3348,9 @@ missing NOV entry. Run gnus-agent-regenerate-group to restore it."))) (let* ((file-name (nnheader-concat dir (number-to-string article-number))) (size (float (nth 7 (file-attributes file-name))))) - (incf bytes-freed size) - (incf size-files-deleted size) - (incf files-deleted) + (cl-incf bytes-freed size) + (cl-incf size-files-deleted size) + (cl-incf files-deleted) (delete-file file-name)) (push "expired cached article" actions)) (setf (nth 1 entry) nil) @@ -3368,13 +3363,13 @@ missing NOV entry. Run gnus-agent-regenerate-group to restore it."))) marker (- marker position-offset))) - (incf nov-entries-deleted) + (cl-incf nov-entries-deleted) (let* ((from (point-at-bol)) (to (progn (forward-line 1) (point))) (freed (- to from))) - (incf bytes-freed freed) - (incf position-offset freed) + (cl-incf bytes-freed freed) + (cl-incf position-offset freed) (delete-region from to))) ;; If considering all articles is set, I can only @@ -3431,9 +3426,9 @@ expiration tests failed." decoded article-number) (when (boundp 'gnus-agent-expire-stats) (let ((stats gnus-agent-expire-stats)) - (incf (nth 2 stats) bytes-freed) - (incf (nth 1 stats) files-deleted) - (incf (nth 0 stats) nov-entries-deleted))) + (cl-incf (nth 2 stats) bytes-freed) + (cl-incf (nth 1 stats) files-deleted) + (cl-incf (nth 0 stats) nov-entries-deleted))) (gnus-agent-update-files-total-fetched-for group (- size-files-deleted))))))) @@ -3824,7 +3819,7 @@ has been fetched." ;; be expired later. (gnus-agent-load-alist group) (gnus-agent-save-alist group (list article) - (time-to-days (current-time)))))) + (time-to-days nil))))) (defun gnus-agent-regenerate-group (group &optional reread) "Regenerate GROUP. @@ -4110,7 +4105,7 @@ agent has fetched." (let ((sum 0.0) file) (while (setq file (pop delta)) - (incf sum (float (or (nth 7 (file-attributes + (cl-incf sum (float (or (nth 7 (file-attributes (nnheader-concat path (if (numberp file) @@ -4122,11 +4117,11 @@ agent has fetched." path nil "^-?[0-9]+$" t)) file) (while (setq file (pop info)) - (incf sum (float (or (nth 8 file) 0)))) + (cl-incf sum (float (or (nth 8 file) 0)))) (setq delta sum)))) (setq gnus-agent-need-update-total-fetched-for t) - (incf (nth 2 entry) delta)))))) + (cl-incf (nth 2 entry) delta)))))) (defun gnus-agent-update-view-total-fetched-for (group agent-over &optional method path) diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 15e88a34227..055f02fb1ab 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -24,8 +24,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defvar tool-bar-map) (defvar w3m-minor-mode-map) @@ -199,9 +198,9 @@ Possible values in this list are: `newsgroups' Newsgroup identical to Gnus group. `to-address' To identical to To-address. `to-list' To identical to To-list. - `cc-list' CC identical to To-list. - `followup-to' Followup-to identical to Newsgroups. - `reply-to' Reply-to identical to From. + `cc-list' Cc identical to To-list. + `followup-to' Followup-To identical to Newsgroups. + `reply-to' Reply-To identical to From. `date' Date less than four days old. `long-to' To and/or Cc longer than 1024 characters. `many-to' Multiple To and/or Cc." @@ -209,9 +208,9 @@ Possible values in this list are: (const :tag "Newsgroups identical to Gnus group." newsgroups) (const :tag "To identical to To-address." to-address) (const :tag "To identical to To-list." to-list) - (const :tag "CC identical to To-list." cc-list) - (const :tag "Followup-to identical to Newsgroups." followup-to) - (const :tag "Reply-to identical to From." reply-to) + (const :tag "Cc identical to To-list." cc-list) + (const :tag "Followup-To identical to Newsgroups." followup-to) + (const :tag "Reply-To identical to From." reply-to) (const :tag "Date less than four days old." date) (const :tag "To and/or Cc longer than 1024 characters." long-to) (const :tag "Multiple To and/or Cc headers." many-to)) @@ -761,9 +760,6 @@ Obsolete; use the face `gnus-signature' for customizations instead." "Face used for highlighting a signature in the article buffer." :group 'gnus-article-highlight :group 'gnus-article-signature) -;; backward-compatibility alias -(put 'gnus-signature-face 'face-alias 'gnus-signature) -(put 'gnus-signature-face 'obsolete-face "22.1") (defface gnus-header-from '((((class color) @@ -777,9 +773,6 @@ Obsolete; use the face `gnus-signature' for customizations instead." "Face used for displaying from headers." :group 'gnus-article-headers :group 'gnus-article-highlight) -;; backward-compatibility alias -(put 'gnus-header-from-face 'face-alias 'gnus-header-from) -(put 'gnus-header-from-face 'obsolete-face "22.1") (defface gnus-header-subject '((((class color) @@ -793,9 +786,6 @@ Obsolete; use the face `gnus-signature' for customizations instead." "Face used for displaying subject headers." :group 'gnus-article-headers :group 'gnus-article-highlight) -;; backward-compatibility alias -(put 'gnus-header-subject-face 'face-alias 'gnus-header-subject) -(put 'gnus-header-subject-face 'obsolete-face "22.1") (defface gnus-header-newsgroups '((((class color) @@ -811,9 +801,6 @@ In the default setup this face is only used for crossposted articles." :group 'gnus-article-headers :group 'gnus-article-highlight) -;; backward-compatibility alias -(put 'gnus-header-newsgroups-face 'face-alias 'gnus-header-newsgroups) -(put 'gnus-header-newsgroups-face 'obsolete-face "22.1") (defface gnus-header-name '((((class color) @@ -827,9 +814,6 @@ articles." "Face used for displaying header names." :group 'gnus-article-headers :group 'gnus-article-highlight) -;; backward-compatibility alias -(put 'gnus-header-name-face 'face-alias 'gnus-header-name) -(put 'gnus-header-name-face 'obsolete-face "22.1") (defface gnus-header-content '((((class color) @@ -842,9 +826,6 @@ articles." (:italic t))) "Face used for displaying header content." :group 'gnus-article-headers :group 'gnus-article-highlight) -;; backward-compatibility alias -(put 'gnus-header-content-face 'face-alias 'gnus-header-content) -(put 'gnus-header-content-face 'obsolete-face "22.1") (defcustom gnus-header-face-alist '(("From" nil gnus-header-from) @@ -1826,7 +1807,7 @@ Initialized from `text-mode-syntax-table'.") (if (looking-at (car list)) (setq list nil) (setq list (cdr list)) - (incf i))) + (cl-incf i))) i)) (defun article-hide-headers (&optional _arg _delete) @@ -1966,7 +1947,7 @@ always hide." (when (and cc to-list (ignore-errors (gnus-string-equal - ;; only one address in CC + ;; only one address in Cc (nth 1 (mail-extract-address-components cc)) to-list))) (gnus-article-hide-header "cc")))) @@ -2236,7 +2217,7 @@ unfolded." (dolist (elem gnus-article-image-alist) (gnus-delete-images (car elem)))))) -(autoload 'w3m-toggle-inline-images "w3m") +(declare-function w3m-toggle-inline-images "w3m") (defun gnus-article-show-images () "Show any images that are in the HTML-rendered article buffer. @@ -2246,10 +2227,12 @@ This only works if the article in question is HTML." (save-restriction (widen) (if (eq mm-text-html-renderer 'w3m) - (w3m-toggle-inline-images) + (progn + (require 'w3m) + (w3m-toggle-inline-images)) (dolist (region (gnus-find-text-property-region (point-min) (point-max) 'image-displayer)) - (destructuring-bind (start end function) region + (cl-destructuring-bind (start end function) region (funcall function (get-text-property start 'image-url) start end))))))) @@ -2948,7 +2931,8 @@ message header will be added to the bodies of the \"text/html\" parts." (encode-coding-string title coding)) body content)) - (setq eheader (string-as-unibyte (buffer-string)) + (setq eheader (encode-coding-string + (buffer-string) 'utf-8) body content))) (erase-buffer) (mm-disable-multibyte) @@ -3031,9 +3015,6 @@ articles to verify whether you have read the message. As browser without eliminating these \"web bugs\" you should only use it for mails from trusted senders. -If you always want to display HTML parts in the browser, set -`mm-text-html-renderer' to nil. - This command creates temporary files to pass HTML contents including images if any to the browser, and deletes them when exiting the group \(if you want)." @@ -3638,8 +3619,7 @@ possible values." (defun article-lapsed-string (time &optional max-segments) ;; If the date is seriously mangled, the timezone functions are ;; liable to bug out, so we ignore all errors. - (let* ((now (current-time)) - (real-time (time-subtract now time)) + (let* ((real-time (time-subtract nil time)) (real-sec (and real-time (+ (* (float (car real-time)) 65536) (cadr real-time)))) @@ -4727,6 +4707,11 @@ If ALL-HEADERS is non-nil, no headers are hidden." (forward-line -1)) (set-window-point (get-buffer-window (current-buffer)) (point)) (gnus-configure-windows 'article) + ;; Make sure the article begins with the top of the header. + (let ((window (get-buffer-window gnus-article-buffer))) + (when window + (with-current-buffer (window-buffer window) + (set-window-point window (point-min))))) (gnus-run-hooks 'gnus-article-prepare-hook) t)))))) @@ -5230,7 +5215,7 @@ available media-types." (gnus-completing-read "View as MIME type" (if pred - (gnus-remove-if-not pred (mailcap-mime-types)) + (seq-filter pred (mailcap-mime-types)) (mailcap-mime-types)) nil nil nil (car default))))) @@ -6698,7 +6683,7 @@ not have a face in `gnus-article-boring-faces'." (interactive "P") (gnus-article-check-buffer) (let ((nosaves - '("q" "Q" "c" "r" "\C-c\C-f" "m" "a" "f" "WDD" "WDW" + '("q" "Q" "r" "\C-c\C-f" "m" "a" "f" "WDD" "WDW" "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP" "=" "^" "\M-^" "|")) (nosave-but-article @@ -6764,7 +6749,8 @@ not have a face in `gnus-article-boring-faces'." ;; We disable the pick minor mode commands. (setq func (let (gnus-pick-mode) (key-binding keys t))) - (when (get func 'disabled) + (when (and (symbolp func) + (get func 'disabled)) (error "Function %s disabled" func)) (if (and func (functionp func) @@ -7062,9 +7048,8 @@ If given a prefix, show the hidden text instead." ;; equivalent of string-make-multibyte which amount to decoding ;; with locale-coding-system, causing failure of ;; subsequent decoding. - (insert (string-to-multibyte - (with-current-buffer gnus-original-article-buffer - (buffer-substring (point-min) (point-max))))) + (insert (with-current-buffer gnus-original-article-buffer + (buffer-substring (point-min) (point-max)))) 'article) ;; Check the backlog. ((and gnus-keep-backlog @@ -8240,7 +8225,7 @@ url is put as the `gnus-button-url' overlay property on the button." (defun gnus-button-handle-news (url) "Fetch a news URL." - (destructuring-bind (_scheme server port group message-id _articles) + (cl-destructuring-bind (_scheme server port group message-id _articles) (gnus-parse-news-url url) (cond (message-id diff --git a/lisp/gnus/gnus-async.el b/lisp/gnus/gnus-async.el index 7003aef24f7..ad25f805ca1 100644 --- a/lisp/gnus/gnus-async.el +++ b/lisp/gnus/gnus-async.el @@ -24,7 +24,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gnus) (require 'gnus-sum) @@ -183,7 +183,7 @@ that was fetched." d) (while (and (setq d (pop data)) (if (numberp n) - (natnump (decf n)) + (natnump (cl-decf n)) n)) (unless (or (gnus-async-prefetched-article-entry group (setq article (gnus-data-number d))) @@ -290,7 +290,7 @@ that was fetched." ;; should check time-since-last-output, which ;; needs to be done in nntp.el. (while (eq article gnus-async-current-prefetch-article) - (incf tries) + (cl-incf tries) (when (nntp-accept-process-output proc) (setq tries 0)) (when (and (not nntp-have-messaged) diff --git a/lisp/gnus/gnus-bcklg.el b/lisp/gnus/gnus-bcklg.el index 8afc31327d7..95cb1ca5ecc 100644 --- a/lisp/gnus/gnus-bcklg.el +++ b/lisp/gnus/gnus-bcklg.el @@ -24,8 +24,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - (require 'gnus) ;;; diff --git a/lisp/gnus/gnus-cache.el b/lisp/gnus/gnus-cache.el index c3e77ca59b0..6afc52c0fce 100644 --- a/lisp/gnus/gnus-cache.el +++ b/lisp/gnus/gnus-cache.el @@ -24,7 +24,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gnus) (require 'gnus-sum) @@ -735,7 +735,7 @@ If LOW, update the lower bound instead." ;; `gnus-cache-unified-group-names' needless. (gnus-sethash (or (cdr (assoc group gnus-cache-unified-group-names)) group) - (cons (car nums) (gnus-last-element nums)) + (cons (car nums) (car (last nums))) gnus-cache-active-hashtb)) ;; Go through all the other files. (dolist (file alphs) @@ -863,11 +863,11 @@ supported." (while (setq file (pop files)) (setq attrs (file-attributes file)) (unless (nth 0 attrs) - (incf size (float (nth 7 attrs))))))) + (cl-incf size (float (nth 7 attrs))))))) (setq gnus-cache-need-update-total-fetched-for t) - (incf (nth 1 entry) (if subtract (- size) size)))))) + (cl-incf (nth 1 entry) (if subtract (- size) size)))))) (defun gnus-cache-update-overview-total-fetched-for (group file) (when gnus-cache-total-fetched-hashtb diff --git a/lisp/gnus/gnus-cite.el b/lisp/gnus/gnus-cite.el index 386593be026..bbf9e527db7 100644 --- a/lisp/gnus/gnus-cite.el +++ b/lisp/gnus/gnus-cite.el @@ -23,8 +23,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - (require 'gnus) (require 'gnus-range) (require 'gnus-art) @@ -136,9 +134,6 @@ the envelope From line." (defface gnus-cite-attribution '((t (:italic t))) "Face used for attribution lines." :group 'gnus-cite) -;; backward-compatibility alias -(put 'gnus-cite-attribution-face 'face-alias 'gnus-cite-attribution) -(put 'gnus-cite-attribution-face 'obsolete-face "22.1") (defcustom gnus-cite-attribution-face 'gnus-cite-attribution "Face used for attribution lines. @@ -157,9 +152,6 @@ It is merged with the face for the cited text belonging to the attribution." (:italic t))) "Citation face." :group 'gnus-cite) -;; backward-compatibility alias -(put 'gnus-cite-face-1 'face-alias 'gnus-cite-1) -(put 'gnus-cite-face-1 'obsolete-face "22.1") (defface gnus-cite-2 '((((class color) (background dark)) @@ -171,9 +163,6 @@ It is merged with the face for the cited text belonging to the attribution." (:italic t))) "Citation face." :group 'gnus-cite) -;; backward-compatibility alias -(put 'gnus-cite-face-2 'face-alias 'gnus-cite-2) -(put 'gnus-cite-face-2 'obsolete-face "22.1") (defface gnus-cite-3 '((((class color) (background dark)) @@ -185,9 +174,6 @@ It is merged with the face for the cited text belonging to the attribution." (:italic t))) "Citation face." :group 'gnus-cite) -;; backward-compatibility alias -(put 'gnus-cite-face-3 'face-alias 'gnus-cite-3) -(put 'gnus-cite-face-3 'obsolete-face "22.1") (defface gnus-cite-4 '((((class color) (background dark)) @@ -199,9 +185,6 @@ It is merged with the face for the cited text belonging to the attribution." (:italic t))) "Citation face." :group 'gnus-cite) -;; backward-compatibility alias -(put 'gnus-cite-face-4 'face-alias 'gnus-cite-4) -(put 'gnus-cite-face-4 'obsolete-face "22.1") (defface gnus-cite-5 '((((class color) (background dark)) @@ -213,9 +196,6 @@ It is merged with the face for the cited text belonging to the attribution." (:italic t))) "Citation face." :group 'gnus-cite) -;; backward-compatibility alias -(put 'gnus-cite-face-5 'face-alias 'gnus-cite-5) -(put 'gnus-cite-face-5 'obsolete-face "22.1") (defface gnus-cite-6 '((((class color) (background dark)) @@ -227,9 +207,6 @@ It is merged with the face for the cited text belonging to the attribution." (:italic t))) "Citation face." :group 'gnus-cite) -;; backward-compatibility alias -(put 'gnus-cite-face-6 'face-alias 'gnus-cite-6) -(put 'gnus-cite-face-6 'obsolete-face "22.1") (defface gnus-cite-7 '((((class color) (background dark)) @@ -241,9 +218,6 @@ It is merged with the face for the cited text belonging to the attribution." (:italic t))) "Citation face." :group 'gnus-cite) -;; backward-compatibility alias -(put 'gnus-cite-face-7 'face-alias 'gnus-cite-7) -(put 'gnus-cite-face-7 'obsolete-face "22.1") (defface gnus-cite-8 '((((class color) (background dark)) @@ -255,9 +229,6 @@ It is merged with the face for the cited text belonging to the attribution." (:italic t))) "Citation face." :group 'gnus-cite) -;; backward-compatibility alias -(put 'gnus-cite-face-8 'face-alias 'gnus-cite-8) -(put 'gnus-cite-face-8 'obsolete-face "22.1") (defface gnus-cite-9 '((((class color) (background dark)) @@ -269,9 +240,6 @@ It is merged with the face for the cited text belonging to the attribution." (:italic t))) "Citation face." :group 'gnus-cite) -;; backward-compatibility alias -(put 'gnus-cite-face-9 'face-alias 'gnus-cite-9) -(put 'gnus-cite-face-9 'obsolete-face "22.1") (defface gnus-cite-10 '((((class color) (background dark)) @@ -283,9 +251,6 @@ It is merged with the face for the cited text belonging to the attribution." (:italic t))) "Citation face." :group 'gnus-cite) -;; backward-compatibility alias -(put 'gnus-cite-face-10 'face-alias 'gnus-cite-10) -(put 'gnus-cite-face-10 'obsolete-face "22.1") (defface gnus-cite-11 '((((class color) (background dark)) @@ -297,9 +262,6 @@ It is merged with the face for the cited text belonging to the attribution." (:italic t))) "Citation face." :group 'gnus-cite) -;; backward-compatibility alias -(put 'gnus-cite-face-11 'face-alias 'gnus-cite-11) -(put 'gnus-cite-face-11 'obsolete-face "22.1") (defcustom gnus-cite-face-list '(gnus-cite-1 gnus-cite-2 gnus-cite-3 gnus-cite-4 gnus-cite-5 gnus-cite-6 @@ -519,8 +481,13 @@ Lines matching `gnus-cite-attribution-suffix' and perhaps (defun gnus-article-fill-cited-article (&optional width long-lines) "Do word wrapping in the current article. If WIDTH (the numerical prefix), use that text width when -filling. If LONG-LINES, only fill sections that have lines -longer than the frame width." +filling. + +If LONG-LINES, only fill sections that have lines longer than the +frame width. + +Sections that are heuristically interpreted as not being +text (i.e., computer code and the like) will not be folded." (interactive "P") (with-current-buffer gnus-article-buffer (let ((buffer-read-only nil) @@ -540,8 +507,6 @@ longer than the frame width." use-hard-newlines) (unless do-fill (setq do-fill (gnus-article-foldable-buffer (cdar marks)))) - ;; Note: the XEmacs version of `fill-region' inserts a newline - ;; unless the region ends with a newline. (when do-fill (if (not long-lines) (fill-region (point-min) (point-max)) diff --git a/lisp/gnus/gnus-cloud.el b/lisp/gnus/gnus-cloud.el index d5970f31265..16bd80dbfa1 100644 --- a/lisp/gnus/gnus-cloud.el +++ b/lisp/gnus/gnus-cloud.el @@ -28,7 +28,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (require 'parse-time) (require 'nnimap) @@ -80,7 +79,7 @@ against the basename of files in said directory." (defcustom gnus-cloud-method nil "The IMAP select method used to store the cloud data. -See also `gnus-server-toggle-cloud-method-server' for an +See also `gnus-server-set-cloud-method-server' for an easy interactive way to set this from the Server buffer." :group 'gnus-cloud :type '(radio (const :tag "Not set" nil) @@ -229,7 +228,7 @@ easy interactive way to set this from the Server buffer." Use old data if FORCE-OLDER is not nil." (let* ((contents (plist-get elem :contents)) (date (or (plist-get elem :timestamp) "0")) - (now (gnus-cloud-timestamp (current-time))) + (now (gnus-cloud-timestamp nil)) (newer (string-lessp date now)) (group-info (gnus-get-info group))) (if (and contents @@ -368,6 +367,8 @@ Use old data if FORCE-OLDER is not nil." (interactive) (gnus-cloud-upload-data t)) +(autoload 'gnus-group-refresh-group "gnus-group") + (defun gnus-cloud-upload-data (&optional full) "Upload data (newsrc and files) to the Gnus Cloud. When FULL is t, upload everything, not just a difference from the last full." @@ -498,7 +499,7 @@ Otherwise, returns the Gnus Cloud data chunks." (gnus-method-to-server (gnus-find-method-for-group (gnus-info-group info)))) - (push `(:type :newsrc-data :name ,(gnus-info-group info) :contents ,info :timestamp ,(gnus-cloud-timestamp (current-time))) + (push `(:type :newsrc-data :name ,(gnus-info-group info) :contents ,info :timestamp ,(gnus-cloud-timestamp nil)) infos))) infos)) diff --git a/lisp/gnus/gnus-cus.el b/lisp/gnus/gnus-cus.el index 0bac2cb1ada..f4c0aa73327 100644 --- a/lisp/gnus/gnus-cus.el +++ b/lisp/gnus/gnus-cus.el @@ -406,7 +406,7 @@ category.")) ;; every duplicate ends up being displayed. So, rather than ;; display them, remove them from the list. - (let ((tmp (setq values (gnus-copy-sequence values))) + (let ((tmp (setq values (copy-tree values))) elem) (while (cdr tmp) (while (setq elem (assq (caar tmp) (cdr tmp))) diff --git a/lisp/gnus/gnus-demon.el b/lisp/gnus/gnus-demon.el index 72b0f5cecff..2405c705651 100644 --- a/lisp/gnus/gnus-demon.el +++ b/lisp/gnus/gnus-demon.el @@ -24,7 +24,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gnus) (require 'gnus-int) @@ -101,7 +101,7 @@ If not, and a TIME is given, restart a new idle timer, so FUNC can be called at the next opportunity. Such a special idle run is marked with SPECIAL." (unless gnus-inhibit-demon - (block run-callback + (cl-block run-callback (when (eq idle t) (setq idle 0.001)) (cond (special @@ -117,7 +117,7 @@ marked with SPECIAL." (run-with-idle-timer idle nil 'gnus-demon-run-callback func idle time t)))) - (return-from run-callback))) + (cl-return-from run-callback))) (with-local-quit (ignore-errors (funcall func)))))) diff --git a/lisp/gnus/gnus-draft.el b/lisp/gnus/gnus-draft.el index 7a37a86fb6f..7d4be47e41b 100644 --- a/lisp/gnus/gnus-draft.el +++ b/lisp/gnus/gnus-draft.el @@ -30,7 +30,6 @@ (require 'gnus-msg) (require 'nndraft) (require 'gnus-agent) -(eval-when-compile (require 'cl)) ;;; Draft minor mode diff --git a/lisp/gnus/gnus-dup.el b/lisp/gnus/gnus-dup.el index d1335fc8c16..a03c6c140cd 100644 --- a/lisp/gnus/gnus-dup.el +++ b/lisp/gnus/gnus-dup.el @@ -29,8 +29,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - (require 'gnus) (require 'gnus-art) diff --git a/lisp/gnus/gnus-fun.el b/lisp/gnus/gnus-fun.el index 40c6d511115..f1fd51d5509 100644 --- a/lisp/gnus/gnus-fun.el +++ b/lisp/gnus/gnus-fun.el @@ -24,9 +24,6 @@ ;;; Code: -(eval-when-compile - (require 'cl)) - (require 'mm-util) (require 'gnus-util) (require 'gnus) diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index fea09ea21a5..6af27afbfaa 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -24,10 +24,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) -(defvar tool-bar-mode) - +(require 'cl-lib) (require 'gnus) (require 'gnus-start) (require 'nnmail) @@ -46,6 +43,8 @@ (unless (boundp 'gnus-cache-active-hashtb) (defvar gnus-cache-active-hashtb nil))) +(defvar tool-bar-mode) + (autoload 'gnus-agent-total-fetched-for "gnus-agent") (autoload 'gnus-cache-total-fetched-for "gnus-cache") @@ -1086,6 +1085,8 @@ See `gmm-tool-bar-from-list' for the format of the list." (defvar image-load-path) (defvar tool-bar-map) +(declare-function image-load-path-for-library "image" + (library image &optional path no-error)) (defun gnus-group-make-tool-bar (&optional force) "Make a group mode tool bar from `gnus-group-tool-bar'. @@ -1152,7 +1153,7 @@ The following commands are available: (goto-char (point-min)) (setq gnus-group-mark-positions (list (cons 'process (and (search-forward - (string-to-multibyte "\200") nil t) + (string gnus-process-mark) nil t) (- (point) (point-min) 1)))))))) (defun gnus-mouse-pick-group (e) @@ -1359,6 +1360,8 @@ if it is a string, only list groups matching REGEXP." (and gnus-permanently-visible-groups (string-match gnus-permanently-visible-groups group)) + ;; Marked groups are always visible. + (member group gnus-group-marked) (memq 'visible params) (cdr (assq 'visible params))))))) (gnus-group-insert-group-line @@ -1898,7 +1901,7 @@ If FIRST-TOO, the current line is also eligible as a target." (insert-char gnus-process-mark 1 t))) (unless no-advance (gnus-group-next-group 1)) - (decf n)) + (cl-decf n)) (gnus-group-position-point) n)) @@ -2548,65 +2551,70 @@ If PROMPT (the prefix) is a number, use the prompt specified in (when (equal group "") (error "Empty group name")) - (unless (gnus-ephemeral-group-p group) - ;; Either go to the line in the group buffer... - (unless (gnus-group-goto-group group) - ;; ... or insert the line. - (gnus-group-update-group group) - (gnus-group-goto-group group))) - ;; Adjust cursor point. - (gnus-group-position-point)) + (prog1 + (unless (gnus-ephemeral-group-p group) + ;; Either go to the line in the group buffer... + (unless (gnus-group-goto-group group) + ;; ... or insert the line. + (gnus-group-update-group group) + (gnus-group-goto-group group))) + ;; Adjust cursor point. + (gnus-group-position-point))) (defun gnus-group-goto-group (group &optional far test-marked) "Goto to newsgroup GROUP. If FAR, it is likely that the group is not on the current line. If TEST-MARKED, the line must be marked." (when group - (beginning-of-line) - (cond - ;; It's quite likely that we are on the right line, so - ;; we check the current line first. - ((and (not far) - (eq (get-text-property (point) 'gnus-group) - (gnus-intern-safe group gnus-active-hashtb)) - (or (not test-marked) (gnus-group-mark-line-p))) - (point)) - ;; Previous and next line are also likely, so we check them as well. - ((and (not far) - (save-excursion - (forward-line -1) - (and (eq (get-text-property (point) 'gnus-group) - (gnus-intern-safe group gnus-active-hashtb)) - (or (not test-marked) (gnus-group-mark-line-p))))) - (forward-line -1) - (point)) - ((and (not far) - (save-excursion - (forward-line 1) - (and (eq (get-text-property (point) 'gnus-group) - (gnus-intern-safe group gnus-active-hashtb)) - (or (not test-marked) (gnus-group-mark-line-p))))) - (forward-line 1) - (point)) - (test-marked - (goto-char (point-min)) - (let (found) - (while (and (not found) - (gnus-goto-char - (text-property-any - (point) (point-max) - 'gnus-group - (gnus-intern-safe group gnus-active-hashtb)))) - (if (gnus-group-mark-line-p) - (setq found t) - (forward-line 1))) - found)) - (t - ;; Search through the entire buffer. - (gnus-goto-char - (text-property-any - (point-min) (point-max) - 'gnus-group (gnus-intern-safe group gnus-active-hashtb))))))) + (let ((start (point))) + (beginning-of-line) + (cond + ;; It's quite likely that we are on the right line, so + ;; we check the current line first. + ((and (not far) + (eq (get-text-property (point) 'gnus-group) + (gnus-intern-safe group gnus-active-hashtb)) + (or (not test-marked) (gnus-group-mark-line-p))) + (point)) + ;; Previous and next line are also likely, so we check them as well. + ((and (not far) + (save-excursion + (forward-line -1) + (and (eq (get-text-property (point) 'gnus-group) + (gnus-intern-safe group gnus-active-hashtb)) + (or (not test-marked) (gnus-group-mark-line-p))))) + (forward-line -1) + (point)) + ((and (not far) + (save-excursion + (forward-line 1) + (and (eq (get-text-property (point) 'gnus-group) + (gnus-intern-safe group gnus-active-hashtb)) + (or (not test-marked) (gnus-group-mark-line-p))))) + (forward-line 1) + (point)) + (test-marked + (goto-char (point-min)) + (let (found) + (while (and (not found) + (gnus-goto-char + (text-property-any + (point) (point-max) + 'gnus-group + (gnus-intern-safe group gnus-active-hashtb)))) + (if (gnus-group-mark-line-p) + (setq found t) + (forward-line 1))) + found)) + (t + ;; Search through the entire buffer. + (if (gnus-goto-char + (text-property-any + (point-min) (point-max) + 'gnus-group (gnus-intern-safe group gnus-active-hashtb))) + (point) + (goto-char start) + nil)))))) (defun gnus-group-next-group (n &optional silent) "Go to next N'th newsgroup. @@ -2998,7 +3006,7 @@ and NEW-NAME will be prompted for." ;; Set the info. (if (not (and info new-group)) (gnus-group-set-info form (or new-group group) part) - (setq info (gnus-copy-sequence info)) + (setq info (copy-tree info)) (setcar info new-group) (unless (gnus-server-equal method "native") (unless (nthcdr 3 info) @@ -3021,7 +3029,7 @@ and NEW-NAME will be prompted for." ;; Don't use `caddr' here since macros within the `interactive' ;; form won't be expanded. (car (cddr entry))))) - (setq method (gnus-copy-sequence method)) + (setq method (copy-tree method)) (let (entry) (while (setq entry (memq (assq 'eval method) method)) (setcar entry (eval (cadar entry))))) @@ -3553,7 +3561,7 @@ Obeys the process/prefix convention." (gnus-request-set-mark ,group ',action) (gnus-info-set-marks ',info ',(gnus-info-marks info) t) (gnus-info-set-read ',info ',(gnus-info-read info)) - (when (gnus-group-goto-group ,group) + (when (gnus-group-jump-to-group ,group) (gnus-get-unread-articles-in-group ',info ',(gnus-active group) t) (gnus-group-update-group-line)))) (setq action (mapcar (lambda (el) (list (nth 0 el) 'del (nth 2 el))) @@ -3921,7 +3929,7 @@ yanked) a list of yanked groups is returned." (interactive "p") (setq arg (or arg 1)) (let (info group prev out) - (while (>= (decf arg) 0) + (while (>= (cl-decf arg) 0) (when (not (setq info (pop gnus-list-of-killed-groups))) (error "No more newsgroups to yank")) (push (setq group (nth 1 info)) out) @@ -4102,9 +4110,14 @@ If DONT-SCAN is non-nil, scan non-activated groups as well." (gnus-group-remove-mark group) ;; Bypass any previous denials from the server. (gnus-remove-denial (setq method (gnus-find-method-for-group group))) - (if (or (and (not dont-scan) - (gnus-request-group-scan group (gnus-get-info group))) - (gnus-activate-group group (if dont-scan nil 'scan) nil method)) + (if (if (and (not dont-scan) + ;; Prefer request-group-scan if the backend supports it. + (gnus-check-backend-function 'request-group-scan group)) + (progn + ;; Ensure that the server is already open. + (gnus-activate-group group nil nil method) + (gnus-request-group-scan group (gnus-get-info group))) + (gnus-activate-group group (if dont-scan nil 'scan) nil method)) (let ((info (gnus-get-info group)) (active (gnus-active group))) (when info @@ -4117,6 +4130,7 @@ If DONT-SCAN is non-nil, scan non-activated groups as well." method (gnus-group-real-name group) active)) (gnus-group-update-group group nil t)) (gnus-error 3 "%s error: %s" group (gnus-status-message group)))) + (gnus-run-hooks 'gnus-after-getting-new-news-hook) (when beg (goto-char beg)) (when gnus-goto-next-group-when-activating @@ -4367,6 +4381,9 @@ The hook `gnus-exit-gnus-hook' is called before actually exiting." gnus-expert-user (gnus-y-or-n-p "Are you sure you want to quit reading news? ")) (gnus-run-hooks 'gnus-exit-gnus-hook) + ;; Check whether we have any unsaved Message buffers and offer to + ;; save them. + (gnus--abort-on-unsaved-message-buffers) ;; Offer to save data from non-quitted summary buffers. (gnus-offer-save-summaries) ;; Save the newsrc file(s). @@ -4378,6 +4395,18 @@ The hook `gnus-exit-gnus-hook' is called before actually exiting." ;; Allow the user to do things after cleaning up. (gnus-run-hooks 'gnus-after-exiting-gnus-hook))) +(defun gnus--abort-on-unsaved-message-buffers () + (dolist (buffer (gnus-buffers)) + (when (gnus-buffer-exists-p buffer) + (with-current-buffer buffer + (when (and (derived-mode-p 'message-mode) + (buffer-modified-p) + (not (y-or-n-p + (format "Message buffer %s unsaved, continue exit? " + (buffer-name))))) + (error "Gnus exit aborted due to unsaved %s buffer" + (buffer-name))))))) + (defun gnus-group-quit () "Quit reading news without updating .newsrc.eld or .newsrc. The hook `gnus-exit-gnus-hook' is called before actually exiting." @@ -4565,7 +4594,7 @@ or `gnus-group-catchup-group-hook'." "Return the offset in seconds from the timestamp for GROUP to the current time, as a floating point number." (let* ((time (or (gnus-group-timestamp group) (list 0 0))) - (delta (time-subtract (current-time) time))) + (delta (time-subtract nil time))) (+ (* (nth 0 delta) 65536.0) (nth 1 delta)))) diff --git a/lisp/gnus/gnus-html.el b/lisp/gnus/gnus-html.el index fc0b36b0db1..f097028cb3e 100644 --- a/lisp/gnus/gnus-html.el +++ b/lisp/gnus/gnus-html.el @@ -28,8 +28,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - (require 'gnus-art) (eval-when-compile (require 'mm-decode)) @@ -99,11 +97,7 @@ fit these criteria." (not (file-exists-p (url-cache-create-filename url)))) (t (let ((cache-time (url-is-cached url))) (if cache-time - (time-less-p - (time-add - cache-time - ttl) - (current-time)) + (time-less-p (time-add cache-time ttl) nil) t))))) ;;;###autoload diff --git a/lisp/gnus/gnus-icalendar.el b/lisp/gnus/gnus-icalendar.el index d878e7695a9..3365c826e11 100644 --- a/lisp/gnus/gnus-icalendar.el +++ b/lisp/gnus/gnus-icalendar.el @@ -40,7 +40,7 @@ (require 'gnus-sum) (require 'gnus-art) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defun gnus-icalendar-find-if (pred seq) (catch 'found @@ -169,7 +169,7 @@ (defun gnus-icalendar-event--get-attendee-names (ical) (let* ((event (car (icalendar--all-events ical))) - (attendee-props (gnus-remove-if-not + (attendee-props (seq-filter (lambda (p) (eq (car p) 'ATTENDEE)) (caddr event)))) @@ -180,7 +180,7 @@ (or (plist-get (cadr prop) 'CN) (replace-regexp-in-string "^.*MAILTO:" "" (caddr prop)))) (attendees-by-type (type) - (gnus-remove-if-not + (seq-filter (lambda (p) (string= (attendee-role p) type)) attendee-props)) (attendee-names-by-type @@ -238,7 +238,7 @@ "\\\\n" "\n" (substring-no-properties value)))))) (accumulate-args (mapping) - (destructuring-bind (slot . ical-property) mapping + (cl-destructuring-bind (slot . ical-property) mapping (setq args (append (list (intern (concat ":" (symbol-name slot))) (map-property ical-property)) @@ -443,7 +443,7 @@ Return nil for non-recurring EVENT." ;; A 0:0 - A .:. -> A 0:0-.:. (default 1) ;; A 0:0 - A+n .:. -> A - A+n .:. ((and start-at-midnight - (plusp start-end-date-diff)) (format "<%s>--<%s %s>" start-date end-date end-time)) + (cl-plusp start-end-date-diff)) (format "<%s>--<%s %s>" start-date end-date end-time)) ;; default ;; A .:. - A .:. -> A .:.-.:. ;; A .:. - B .:. diff --git a/lisp/gnus/gnus-int.el b/lisp/gnus/gnus-int.el index a17741b577c..5d5f9ebb670 100644 --- a/lisp/gnus/gnus-int.el +++ b/lisp/gnus/gnus-int.el @@ -24,8 +24,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - (require 'gnus) (require 'message) (require 'gnus-range) diff --git a/lisp/gnus/gnus-kill.el b/lisp/gnus/gnus-kill.el index fd5935b87f8..60732c11d54 100644 --- a/lisp/gnus/gnus-kill.el +++ b/lisp/gnus/gnus-kill.el @@ -25,8 +25,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - (require 'gnus) (require 'gnus-art) (require 'gnus-range) diff --git a/lisp/gnus/gnus-logic.el b/lisp/gnus/gnus-logic.el index e0dba06d397..2076d8aebe7 100644 --- a/lisp/gnus/gnus-logic.el +++ b/lisp/gnus/gnus-logic.el @@ -24,7 +24,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gnus) (require 'gnus-score) diff --git a/lisp/gnus/gnus-ml.el b/lisp/gnus/gnus-ml.el index f78efdee65b..1c67f5ffba0 100644 --- a/lisp/gnus/gnus-ml.el +++ b/lisp/gnus/gnus-ml.el @@ -28,7 +28,6 @@ (require 'gnus) (require 'gnus-msg) -(eval-when-compile (require 'cl)) ;;; Mailing list minor mode diff --git a/lisp/gnus/gnus-mlspl.el b/lisp/gnus/gnus-mlspl.el index eeb65e67e88..599b9c61dcf 100644 --- a/lisp/gnus/gnus-mlspl.el +++ b/lisp/gnus/gnus-mlspl.el @@ -24,7 +24,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (require 'gnus) (require 'gnus-sum) (require 'gnus-group) @@ -183,7 +182,8 @@ Calling (gnus-group-split-fancy nil nil \"mail.others\") returns: (to-list (cdr (assoc 'to-list params))) (extra-aliases (cdr (assoc 'extra-aliases params))) (split-regexp (cdr (assoc 'split-regexp params))) - (split-exclude (cdr (assoc 'split-exclude params)))) + (split-exclude (cdr (assoc 'split-exclude params))) + (match-list (cdr (assoc 'match-list params)))) (when (or to-address to-list extra-aliases split-regexp) ;; regexp-quote to-address, to-list and extra-aliases ;; and add them all to split-regexp @@ -203,16 +203,28 @@ Calling (gnus-group-split-fancy nil nil \"mail.others\") returns: "\\|") "\\)")) ;; Now create the new SPLIT - (push (append - (list 'any split-regexp) + (let ((split-regexp-with-list-ids + (replace-regexp-in-string "@" "[@.]" split-regexp t t)) + (exclude ;; Generate RESTRICTs for SPLIT-EXCLUDEs. (if (listp split-exclude) (apply #'append (mapcar (lambda (arg) (list '- arg)) split-exclude)) - (list '- split-exclude)) - (list group-clean)) - split) + (list '- split-exclude)))) + + (if match-list + ;; Match RFC2919 IDs or mail addresses + (push (append + (list 'list split-regexp-with-list-ids) + exclude + (list group-clean)) + split) + (push (append + (list 'any split-regexp) + exclude + (list group-clean)) + split))) ;; If it matches the empty string, it is a catch-all (when (string-match split-regexp "") (setq catch-all nil))))))))) diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el index effbe2cc5f4..660bdf73cdf 100644 --- a/lisp/gnus/gnus-msg.el +++ b/lisp/gnus/gnus-msg.el @@ -25,7 +25,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gnus) (require 'message) @@ -393,6 +393,7 @@ Thank you for your help in stamping out bugs. "N" gnus-summary-followup-to-mail-with-original "m" gnus-summary-mail-other-window "u" gnus-uu-post-news + "A" gnus-summary-attach-article "\M-c" gnus-summary-mail-crosspost-complaint "Br" gnus-summary-reply-broken-reply-to "BR" gnus-summary-reply-broken-reply-to-with-original @@ -535,7 +536,7 @@ instead." (progn (message "Gnus not running; using plain Message mode") (message-mail to subject other-headers continue - nil yank-action send-actions return-action)) + switch-action yank-action send-actions return-action)) (let ((buf (current-buffer)) ;; Don't use posting styles corresponding to any existing group. (group-name gnus-newsgroup-name) @@ -1037,7 +1038,7 @@ header line with the old Message-ID." (gnus-inews-yank-articles yank)))))) (defun gnus-msg-treat-broken-reply-to (&optional force) - "Remove the Reply-to header if broken-reply-to." + "Remove the Reply-To header if broken-reply-to." (when (or force (gnus-group-find-parameter gnus-newsgroup-name 'broken-reply-to)) @@ -1113,11 +1114,11 @@ If SILENT, don't prompt the user." ((and (eq gnus-post-method 'current) (not (memq (car group-method) gnus-discouraged-post-methods)) (gnus-get-function group-method 'request-post t)) - (assert (not arg)) + (cl-assert (not arg)) group-method) ;; Use gnus-post-method. ((listp gnus-post-method) ;A method... - (assert (not (listp (car gnus-post-method)))) ;... not a list of methods. + (cl-assert (not (listp (car gnus-post-method)))) ;... not a list of methods. gnus-post-method) ;; Use the normal select method (nil or native). (t gnus-select-method)))) @@ -1482,7 +1483,7 @@ See `gnus-summary-mail-forward' for ARG." (not (member group (message-tokenize-header followup-to ", "))))) (if followup-to - (gnus-message 1 "Followup-to restricted") + (gnus-message 1 "Followup-To restricted") (gnus-message 1 "Not a crossposted article")) (set-buffer gnus-summary-buffer) (gnus-summary-reply-with-original 1) @@ -2000,6 +2001,36 @@ this is a reply." (insert "From: " (message-make-from) "\n")))) nil 'local))))) +(defun gnus-summary-attach-article (n) + "Attach the current article(s) to an outgoing Message buffer. +If any current in-progress Message buffers exist, the articles +can be attached to them. If not, a new Message buffer is +created. + +This command uses the process/prefix convention, so if you +process-mark several articles, they will all be attached." + (interactive "P") + (let ((buffers (message-buffers)) + destination) + ;; Set up the destination mail composition buffer. + (if (and buffers + (y-or-n-p "Attach files to existing mail composition buffer? ")) + (setq destination + (if (= (length buffers) 1) + (get-buffer (car buffers)) + (gnus-completing-read "Attach to buffer" + buffers t nil nil (car buffers)))) + (gnus-summary-mail-other-window) + (setq destination (current-buffer))) + (gnus-summary-iterate n + (gnus-summary-select-article) + (set-buffer destination) + ;; Attach at the end of the buffer. + (save-excursion + (goto-char (point-max)) + (message-forward-make-body-mime gnus-original-article-buffer))) + (gnus-configure-windows 'message t))) + (provide 'gnus-msg) ;;; gnus-msg.el ends here diff --git a/lisp/gnus/gnus-picon.el b/lisp/gnus/gnus-picon.el index 8f3efa41675..b6bb5c9c2b7 100644 --- a/lisp/gnus/gnus-picon.el +++ b/lisp/gnus/gnus-picon.el @@ -37,7 +37,7 @@ ;; ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gnus) (require 'gnus-art) @@ -211,7 +211,7 @@ replacement is added." (gnus-article-goto-header header) (mail-header-narrow-to-field) - (case gnus-picon-style + (cl-case gnus-picon-style (right (when (= (length addresses) 1) (setq len (apply '+ (mapcar (lambda (x) diff --git a/lisp/gnus/gnus-range.el b/lisp/gnus/gnus-range.el index c8ba7ae5c15..dd3793593e0 100644 --- a/lisp/gnus/gnus-range.el +++ b/lisp/gnus/gnus-range.el @@ -24,8 +24,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - ;;; List and range functions (defsubst gnus-range-normalize (range) @@ -38,17 +36,9 @@ If RANGE is a single range, return (RANGE). Otherwise, return RANGE." (while (cdr list) (setq list (cdr list))) (car list)) +(make-obsolete 'gnus-last-element "use `car' of `last' instead." "27.1") -(defun gnus-copy-sequence (list) - "Do a complete, total copy of a list." - (let (out) - (while (consp list) - (if (consp (car list)) - (push (gnus-copy-sequence (pop list)) out) - (push (pop list) out))) - (if list - (nconc (nreverse out) list) - (nreverse out)))) +(define-obsolete-function-alias 'gnus-copy-sequence 'copy-tree "27.1") (defun gnus-set-difference (list1 list2) "Return a list of elements of LIST1 that do not appear in LIST2." @@ -455,7 +445,7 @@ modified." (if (or (null range1) (null range2)) range1 (let (out r1 r2 r1_min r1_max r2_min r2_max - (range2 (gnus-copy-sequence range2))) + (range2 (copy-tree range2))) (setq range1 (if (listp (cdr range1)) range1 (list range1)) range2 (sort (if (listp (cdr range2)) range2 (list range2)) (lambda (e1 e2) diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el index 4c0d5218ab8..229d057946e 100644 --- a/lisp/gnus/gnus-registry.el +++ b/lisp/gnus/gnus-registry.el @@ -76,7 +76,8 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'subr-x)) (require 'gnus) (require 'gnus-int) @@ -165,12 +166,7 @@ nnmairix groups are specifically excluded because they are ephemeral." (defvar gnus-registry-misc-menus nil) ; ugly way to keep the menus -(make-obsolete-variable 'gnus-registry-clean-empty nil "23.4") -(make-obsolete-variable 'gnus-registry-use-long-group-names nil "23.4") -(make-obsolete-variable 'gnus-registry-max-track-groups nil "23.4") -(make-obsolete-variable 'gnus-registry-entry-caching nil "23.4") -(make-obsolete-variable 'gnus-registry-trim-articles-without-groups nil "23.4") -;; FIXME it was simply deleted. +;; It was simply deleted. (make-obsolete-variable 'gnus-registry-max-pruned-entries nil "25.1") (defcustom gnus-registry-track-extra '(subject sender recipient) @@ -372,7 +368,7 @@ This is not required after changing `gnus-registry-cache-file'." (grouphashtb (registry-lookup-secondary db 'group)) (old-size (registry-size db))) (registry-reindex db) - (loop for k being the hash-keys of grouphashtb + (cl-loop for k being the hash-keys of grouphashtb using (hash-values v) when (gnus-registry-ignore-group-p k) do (registry-delete db v nil)) @@ -443,14 +439,14 @@ This is not required after changing `gnus-registry-cache-file'." (sender ,sender) (recipient ,@recipients) (subject ,subject))) - (when (second kv) - (let ((new (or (assq (first kv) entry) - (list (first kv))))) + (when (cadr kv) + (let ((new (or (assq (car kv) entry) + (list (car kv))))) (dolist (toadd (cdr kv)) (unless (member toadd new) (setq new (append new (list toadd))))) (setq entry (cons new - (assq-delete-all (first kv) entry)))))) + (assq-delete-all (car kv) entry)))))) (gnus-message 10 "Gnus registry: new entry for %s is %S" id entry) @@ -504,7 +500,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." :subject subject :log-agent "Gnus registry fancy splitting with parent"))) -(defun* gnus-registry--split-fancy-with-parent-internal +(cl-defun gnus-registry--split-fancy-with-parent-internal (&rest spec &key references refstr sender subject recipients log-agent &allow-other-keys) @@ -524,7 +520,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." log-agent refstr) (dolist (reference (nreverse references)) (gnus-message 9 "%s is looking up %s" log-agent reference) - (loop for group in (gnus-registry-get-id-key reference 'group) + (cl-loop for group in (gnus-registry-get-id-key reference 'group) when (gnus-registry-follow-group-p group) do (progn @@ -547,7 +543,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (gnus-registry-get-id-key reference 'group)) (registry-lookup-secondary-value db 'subject subject))))) (setq found - (loop for group in groups + (cl-loop for group in groups when (gnus-registry-follow-group-p group) do (gnus-message ;; warn more if gnus-registry-track-extra @@ -574,7 +570,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (gnus-registry-get-id-key reference 'group)) (registry-lookup-secondary-value db 'sender sender))))) (setq found - (loop for group in groups + (cl-loop for group in groups when (gnus-registry-follow-group-p group) do (gnus-message ;; warn more if gnus-registry-track-extra @@ -604,7 +600,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (registry-lookup-secondary-value db 'recipient recp))))) (setq found - (loop for group in groups + (cl-loop for group in groups when (gnus-registry-follow-group-p group) do (gnus-message ;; warn more if gnus-registry-track-extra @@ -640,7 +636,7 @@ possible. Uses `gnus-registry-split-strategy'." out chosen) ;; the strategy can be nil, in which case chosen is nil (setq chosen - (case gnus-registry-split-strategy + (cl-case gnus-registry-split-strategy ;; default, take only one-element lists into chosen ((nil) (and (= (length groups) 1) @@ -692,7 +688,7 @@ possible. Uses `gnus-registry-split-strategy'." 10 "%s: stripped group %s to %s" log-agent group short-name)) - (pushnew short-name out :test #'equal)) + (cl-pushnew short-name out :test #'equal)) ;; else... (gnus-message 7 @@ -844,21 +840,17 @@ Addresses without a name will say \"noname\"." nil)) (defun gnus-registry-fetch-sender-fast (article) - (gnus-registry-fetch-header-fast "from" article)) + (when-let* ((data (and (numberp article) + (assoc article (gnus-data-list nil))))) + (mail-header-from (gnus-data-header data)))) (defun gnus-registry-fetch-recipients-fast (article) - (gnus-registry-sort-addresses - (or (ignore-errors (gnus-registry-fetch-header-fast "Cc" article)) "") - (or (ignore-errors (gnus-registry-fetch-header-fast "To" article)) ""))) - -(defun gnus-registry-fetch-header-fast (article header) - "Fetch the HEADER quickly, using the internal gnus-data-list function." - (if (and (numberp article) - (assoc article (gnus-data-list nil))) - (gnus-string-remove-all-properties - (cdr (assq header (gnus-data-header - (assoc article (gnus-data-list nil)))))) - nil)) + (when-let* ((data (and (numberp article) + (assoc article (gnus-data-list nil)))) + (extra (mail-header-extra (gnus-data-header data)))) + (gnus-registry-sort-addresses + (or (cdr (assq 'Cc extra)) "") + (or (cdr (assq 'To extra)) "")))) ;; registry marks glue (defun gnus-registry-do-marks (type function) @@ -1089,7 +1081,7 @@ only the last one's marks are returned." (expected (length old)) entry) (while (car-safe old) - (incf count) + (cl-incf count) ;; don't use progress reporters for backwards compatibility (when (and (< 0 expected) (= 0 (mod count 100))) @@ -1099,7 +1091,7 @@ only the last one's marks are returned." old (cdr-safe old)) (let* ((id (car-safe entry)) (rest (cdr-safe entry)) - (groups (loop for p in rest + (groups (cl-loop for p in rest when (stringp p) collect p)) extra-cell key val) @@ -1235,7 +1227,7 @@ from your existing entries." (when extra (let ((db gnus-registry-db)) (registry-reindex db) - (loop for k being the hash-keys of (oref db data) + (cl-loop for k being the hash-keys of (oref db data) using (hash-value v) do (let ((newv (delq nil (mapcar #'(lambda (entry) (unless (member (car entry) extra) diff --git a/lisp/gnus/gnus-salt.el b/lisp/gnus/gnus-salt.el index a80bb5b7037..aff841760ae 100644 --- a/lisp/gnus/gnus-salt.el +++ b/lisp/gnus/gnus-salt.el @@ -24,7 +24,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gnus) (require 'gnus-sum) @@ -131,7 +131,7 @@ It accepts the same format specs that `gnus-summary-line-format' does." (defvar gnus-pick-line-number 1) (defun gnus-pick-line-number () "Return the current line number." - (incf gnus-pick-line-number)) + (cl-incf gnus-pick-line-number)) (defun gnus-pick-start-reading (&optional catch-up) "Start reading the picked articles. @@ -552,7 +552,7 @@ Two predefined functions are available: (not (one-window-p))) (let ((windows 0) tot-win-height) - (walk-windows (lambda (_window) (incf windows))) + (walk-windows (lambda (_window) (cl-incf windows))) (setq tot-win-height (- (frame-height) (* window-min-height (1- windows)) @@ -734,7 +734,7 @@ it in the environment specified by BINDINGS." (insert (make-string len ? ))))) (defsubst gnus-tree-forward-line (n) - (while (>= (decf n) 0) + (while (>= (cl-decf n) 0) (unless (zerop (forward-line 1)) (end-of-line) (insert "\n"))) @@ -784,7 +784,7 @@ it in the environment specified by BINDINGS." (progn (goto-char (point-min)) (end-of-line) - (incf gnus-tmp-indent)) + (cl-incf gnus-tmp-indent)) ;; Recurse downwards in all children of this article. (while thread (gnus-generate-vertical-tree diff --git a/lisp/gnus/gnus-score.el b/lisp/gnus/gnus-score.el index a6536797662..6878aa69c66 100644 --- a/lisp/gnus/gnus-score.el +++ b/lisp/gnus/gnus-score.el @@ -25,7 +25,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gnus) (require 'gnus-sum) @@ -514,7 +514,7 @@ of the last successful match.") "f" gnus-score-edit-file "F" gnus-score-flush-cache "t" gnus-score-find-trace - "w" gnus-score-find-favourite-words) + "w" gnus-score-find-favorite-words) ;; Summary score file commands @@ -921,7 +921,7 @@ EXTRA is the possible non-standard header." (interactive (list (gnus-completing-read "Header" (mapcar 'car - (gnus-remove-if-not + (seq-filter (lambda (x) (fboundp (nth 2 x))) gnus-header-index)) t) @@ -1078,11 +1078,11 @@ EXTRA is the possible non-standard header." "Return the score of the current article. With prefix ARG, return the total score of the current (sub)thread." (interactive "P") - (gnus-message 1 "%s" (if arg - (gnus-thread-total-score - (gnus-id-to-thread - (mail-header-id (gnus-summary-article-header)))) - (gnus-summary-article-score)))) + (message "%s" (if arg + (gnus-thread-total-score + (gnus-id-to-thread + (mail-header-id (gnus-summary-article-header)))) + (gnus-summary-article-score)))) (defun gnus-score-change-score-file (file) "Change current score alist." @@ -1238,7 +1238,7 @@ If FORMAT, also format the current score file." (or (not decay) (gnus-decay-scores alist decay))) (gnus-score-set 'touched '(t) alist) - (gnus-score-set 'decay (list (time-to-days (current-time))) alist)) + (gnus-score-set 'decay (list (time-to-days nil)) alist)) ;; We do not respect eval and files atoms from global score ;; files. (when (and files (not global)) @@ -1751,8 +1751,7 @@ score in `gnus-newsgroup-scored' by SCORE." (mm-display-inline handle) (goto-char (point-max)))))) - (let ( ;(mm-text-html-renderer 'w3m-standalone) - (handles (mm-dissect-buffer t))) + (let ((handles (mm-dissect-buffer t))) (save-excursion (article-goto-body) (delete-region (point) (point-max)) @@ -2318,7 +2317,7 @@ score in `gnus-newsgroup-scored' by SCORE." (when (or (not (listp gnus-newsgroup-adaptive)) (memq 'line gnus-newsgroup-adaptive)) (save-excursion - (let* ((malist (gnus-copy-sequence gnus-adaptive-score-alist)) + (let* ((malist (copy-tree gnus-adaptive-score-alist)) (alist malist) (date (current-time-string)) (data gnus-newsgroup-data) @@ -2517,7 +2516,7 @@ the score file and its full name, including the directory.") (set-buffer gnus-summary-buffer) (setq gnus-newsgroup-scored old-scored))) -(defun gnus-score-find-favourite-words () +(defun gnus-score-find-favorite-words () "List words used in scoring." (interactive) (let ((alists (gnus-score-load-files (gnus-all-score-files))) @@ -2553,6 +2552,9 @@ the score file and its full name, including the directory.") (pop rules)) (goto-char (point-min)) (gnus-configure-windows 'score-words)))) +(define-obsolete-function-alias + 'gnus-score-find-favourite-words + 'gnus-score-find-favorite-words "27.1") (defun gnus-summary-rescore () "Redo the entire scoring process in the current summary." @@ -2731,8 +2733,10 @@ GROUP using BNews sys file syntax." (insert (car sfiles)) (goto-char (point-min)) ;; First remove the suffix itself. - (when (re-search-forward (concat "." score-regexp) nil t) - (replace-match "" t t) + (when (re-search-forward score-regexp nil t) + (unless (= (match-end 0) (match-beginning 0)) ; non-empty suffix + (replace-match "" t t) + (delete-char -1)) ; remove the "." before the suffix (goto-char (point-min)) (if (looking-at (regexp-quote kill-dir)) ;; If the file name was just "SCORE", `klen' is one character @@ -3060,7 +3064,7 @@ If ADAPT, return the home adaptive file instead." (defun gnus-decay-scores (alist day) "Decay non-permanent scores in ALIST." - (let ((times (- (time-to-days (current-time)) day)) + (let ((times (- (time-to-days nil) day)) kill entry updated score n) (unless (zerop times) ;Done decays today already? (while (setq entry (pop alist)) @@ -3072,7 +3076,7 @@ If ADAPT, return the home adaptive file instead." (setq score (or (nth 1 kill) gnus-score-interactive-default-score) n times) - (while (natnump (decf n)) + (while (natnump (cl-decf n)) (setq score (funcall gnus-decay-score-function score))) (setcdr kill (cons score (cdr (cdr kill))))))))) diff --git a/lisp/gnus/gnus-spec.el b/lisp/gnus/gnus-spec.el index 082ebf15529..379a7f2b5c3 100644 --- a/lisp/gnus/gnus-spec.el +++ b/lisp/gnus/gnus-spec.el @@ -24,7 +24,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defvar gnus-newsrc-file-version) (require 'gnus) @@ -285,15 +285,15 @@ Return a list of updated types." ;; Find the start position. (while (and (< seek length) (< wseek start)) - (incf wseek (char-width (aref string seek))) - (incf seek)) + (cl-incf wseek (char-width (aref string seek))) + (cl-incf seek)) (setq wstart seek) ;; Find the end position. (while (and (<= seek length) (or (not end) (<= wseek end))) - (incf wseek (char-width (aref string seek))) - (incf seek)) + (cl-incf wseek (char-width (aref string seek))) + (cl-incf seek)) (setq wend seek) (substring string wstart (1- wend)))) diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el index f9795628cc0..dfca5e9d2cb 100644 --- a/lisp/gnus/gnus-srvr.el +++ b/lisp/gnus/gnus-srvr.el @@ -24,7 +24,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gnus) (require 'gnus-start) @@ -142,7 +142,7 @@ If nil, a faster, but more primitive, buffer is used instead." ["Offline" gnus-server-offline-server t] ["Deny" gnus-server-deny-server t] ["Toggle Cloud Sync for this server" gnus-server-toggle-cloud-server t] - ["Toggle Cloud Sync Host" gnus-server-toggle-cloud-method-server t] + ["Toggle Cloud Sync Host" gnus-server-set-cloud-method-server t] "---" ["Open All" gnus-server-open-all-servers t] ["Close All" gnus-server-close-all-servers t] @@ -189,7 +189,7 @@ If nil, a faster, but more primitive, buffer is used instead." "z" gnus-server-compact-server "i" gnus-server-toggle-cloud-server - "I" gnus-server-toggle-cloud-method-server + "I" gnus-server-set-cloud-method-server "\C-c\C-i" gnus-info-find-node "\C-c\C-b" gnus-bug)) @@ -200,9 +200,6 @@ If nil, a faster, but more primitive, buffer is used instead." (t (:bold t))) "Face used for displaying AGENTIZED servers" :group 'gnus-server-visual) -;; backward-compatibility alias -(put 'gnus-server-agent-face 'face-alias 'gnus-server-agent) -(put 'gnus-server-agent-face 'obsolete-face "22.1") (defface gnus-server-cloud '((((class color) (background light)) (:foreground "ForestGreen" :bold t)) @@ -224,9 +221,6 @@ If nil, a faster, but more primitive, buffer is used instead." (t (:bold t))) "Face used for displaying OPENED servers" :group 'gnus-server-visual) -;; backward-compatibility alias -(put 'gnus-server-opened-face 'face-alias 'gnus-server-opened) -(put 'gnus-server-opened-face 'obsolete-face "22.1") (defface gnus-server-closed '((((class color) (background light)) (:foreground "Steel Blue" :italic t)) @@ -235,9 +229,6 @@ If nil, a faster, but more primitive, buffer is used instead." (t (:italic t))) "Face used for displaying CLOSED servers" :group 'gnus-server-visual) -;; backward-compatibility alias -(put 'gnus-server-closed-face 'face-alias 'gnus-server-closed) -(put 'gnus-server-closed-face 'obsolete-face "22.1") (defface gnus-server-denied '((((class color) (background light)) (:foreground "Red" :bold t)) @@ -245,9 +236,6 @@ If nil, a faster, but more primitive, buffer is used instead." (t (:inverse-video t :bold t))) "Face used for displaying DENIED servers" :group 'gnus-server-visual) -;; backward-compatibility alias -(put 'gnus-server-denied-face 'face-alias 'gnus-server-denied) -(put 'gnus-server-denied-face 'obsolete-face "22.1") (defface gnus-server-offline '((((class color) (background light)) (:foreground "Orange" :bold t)) @@ -255,9 +243,6 @@ If nil, a faster, but more primitive, buffer is used instead." (t (:inverse-video t :bold t))) "Face used for displaying OFFLINE servers" :group 'gnus-server-visual) -;; backward-compatibility alias -(put 'gnus-server-offline-face 'face-alias 'gnus-server-offline) -(put 'gnus-server-offline-face 'obsolete-face "22.1") (defvar gnus-server-font-lock-keywords '(("(\\(agent\\))" 1 'gnus-server-agent) @@ -452,7 +437,8 @@ The following commands are available: (if server (error "No such server: %s" server) (error "No server on the current line"))) (unless (assoc server gnus-server-alist) - (error "Read-only server %s" server)) + (error "Server %s must be deleted from your configuration files" + server)) (gnus-dribble-touch) (let ((buffer-read-only nil)) (gnus-delete-line)) @@ -608,7 +594,7 @@ The following commands are available: (error "%s already exists" to)) (unless (gnus-server-to-method from) (error "%s: no such server" from)) - (let ((to-entry (cons from (gnus-copy-sequence + (let ((to-entry (cons from (copy-tree (gnus-server-to-method from))))) (setcar to-entry to) (setcar (nthcdr 2 to-entry) to) @@ -642,7 +628,8 @@ The following commands are available: (unless server (error "No server on current line")) (unless (assoc server gnus-server-alist) - (error "This server can't be edited")) + (error "Server %s must be edited in your configuration files" + server)) (let ((info (cdr (assoc server gnus-server-alist)))) (gnus-close-server info) (gnus-edit-form @@ -821,12 +808,11 @@ claim them." (while (not (eobp)) (ignore-errors (push (cons - (string-as-unibyte - (buffer-substring - (point) - (progn - (skip-chars-forward "^ \t") - (point)))) + (buffer-substring + (point) + (progn + (skip-chars-forward "^ \t") + (point))) (let ((last (read cur))) (cons (read cur) last))) groups)) @@ -834,19 +820,18 @@ claim them." (while (not (eobp)) (ignore-errors (push (cons - (string-as-unibyte - (if (eq (char-after) ?\") - (read cur) - (let ((p (point)) (name "")) - (skip-chars-forward "^ \t\\\\") - (setq name (buffer-substring p (point))) - (while (eq (char-after) ?\\) - (setq p (1+ (point))) - (forward-char 2) - (skip-chars-forward "^ \t\\\\") - (setq name (concat name (buffer-substring - p (point))))) - name))) + (if (eq (char-after) ?\") + (read cur) + (let ((p (point)) (name "")) + (skip-chars-forward "^ \t\\\\") + (setq name (buffer-substring p (point))) + (while (eq (char-after) ?\\) + (setq p (1+ (point))) + (forward-char 2) + (skip-chars-forward "^ \t\\\\") + (setq name (concat name (buffer-substring + p (point))))) + name)) (let ((last (read cur))) (cons (read cur) last))) groups)) @@ -982,7 +967,7 @@ how new groups will be entered into the group buffer." (not (eobp)) (gnus-browse-unsubscribe-group) (zerop (gnus-browse-next-group ward))) - (decf arg)) + (cl-decf arg)) (gnus-group-position-point) (when (/= 0 arg) (gnus-message 7 "No more newsgroups")) @@ -1127,7 +1112,7 @@ Requesting compaction of %s... (this may take a long time)" (and original (gnus-kill-buffer original)))))) (defun gnus-server-toggle-cloud-server () - "Make the server under point be replicated in the Emacs Cloud." + "Toggle whether the server under point is replicated in the Emacs Cloud." (interactive) (let ((server (gnus-server-server-name))) (unless server @@ -1147,7 +1132,7 @@ Requesting compaction of %s... (this may take a long time)" "Replication of %s in the cloud will stop") server))) -(defun gnus-server-toggle-cloud-method-server () +(defun gnus-server-set-cloud-method-server () "Set the server under point to host the Emacs Cloud." (interactive) (let ((server (gnus-server-server-name))) @@ -1157,7 +1142,7 @@ Requesting compaction of %s... (this may take a long time)" (error "The server under point can't host the Emacs Cloud")) (when (not (string-equal gnus-cloud-method server)) - (custom-set-variables '(gnus-cloud-method server)) + (customize-set-variable 'gnus-cloud-method server) ;; Note we can't use `Custom-save' here. (when (gnus-yes-or-no-p (format "The new cloud host server is %S now. Save it? " server)) diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el index 2a7a303408e..623055e1f65 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el @@ -36,8 +36,7 @@ (autoload 'gnus-agent-save-local "gnus-agent") (autoload 'gnus-agent-possibly-alter-active "gnus-agent") -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defvar gnus-agent-covered-methods) (defvar gnus-agent-file-loading-local) @@ -1231,14 +1230,14 @@ for new groups, and subscribe the new groups as zombies." (let ((do-sub (gnus-matches-options-n group))) (cond ((eq do-sub 'subscribe) - (incf groups) + (cl-incf groups) (gnus-sethash group group gnus-killed-hashtb) (gnus-call-subscribe-functions gnus-subscribe-options-newsgroup-method group)) ((eq do-sub 'ignore) nil) (t - (incf groups) + (cl-incf groups) (gnus-sethash group group gnus-killed-hashtb) (if gnus-subscribe-hierarchical-interactive (push group new-newsgroups) @@ -1700,7 +1699,7 @@ backend check whether the group actually exists." ;; aren't equal (and that need extension; i.e., they are async). (let ((methods nil)) (dolist (elem type-cache) - (destructuring-bind (method method-type infos dummy) elem + (cl-destructuring-bind (method method-type infos dummy) elem (let ((gnus-opened-servers methods)) (when (and (gnus-similar-server-opened method) (gnus-check-backend-function @@ -1723,7 +1722,7 @@ backend check whether the group actually exists." ;; Clear out all the early methods. (dolist (elem type-cache) - (destructuring-bind (method method-type infos dummy) elem + (cl-destructuring-bind (method method-type infos dummy) elem (when (and method infos (gnus-check-backend-function @@ -1740,7 +1739,7 @@ backend check whether the group actually exists." (let ((done-methods nil) sanity-spec) (dolist (elem type-cache) - (destructuring-bind (method method-type infos dummy) elem + (cl-destructuring-bind (method method-type infos dummy) elem (setq sanity-spec (list (car method) (cadr method))) (when (and method infos (not (gnus-method-denied-p method))) @@ -1771,7 +1770,7 @@ backend check whether the group actually exists." ;; Do the rest of the retrieval. (dolist (elem type-cache) - (destructuring-bind (method method-type infos early-data) elem + (cl-destructuring-bind (method method-type infos early-data) elem (when (and method infos (not (gnus-method-denied-p method))) (let ((updatep (gnus-check-backend-function @@ -1795,11 +1794,11 @@ backend check whether the group actually exists." ;; are in the secondary select list. ((eq type 'secondary) (let ((i 2)) - (block nil - (dolist (smethod gnus-secondary-select-methods) + (cl-block nil + (cl-dolist (smethod gnus-secondary-select-methods) (when (equal method smethod) - (return i)) - (incf i)) + (cl-return i)) + (cl-incf i)) i))) ;; Just say that all foreign groups have the same rank. (t @@ -1990,15 +1989,10 @@ backend check whether the group actually exists." ;; Enter all dead groups into the hashtb. (defun gnus-update-active-hashtb-from-killed () - (let ((hashtb (setq gnus-active-hashtb (gnus-make-hashtable 4096))) - (lists (list gnus-killed-list gnus-zombie-list)) - killed) - (while lists - (setq killed (car lists)) - (while killed - (gnus-sethash (string-as-unibyte (car killed)) nil hashtb) - (setq killed (cdr killed))) - (setq lists (cdr lists))))) + (let ((hashtb (setq gnus-active-hashtb (gnus-make-hashtable 4096)))) + (dolist (list (list gnus-killed-list gnus-zombie-list)) + (dolist (group list) + (gnus-sethash group nil hashtb))))) (defun gnus-get-killed-groups () "Go through the active hashtb and mark all unknown groups as killed." @@ -2456,10 +2450,6 @@ If FORCE is non-nil, the .newsrc file is read." (setq gnus-format-specs gnus-default-format-specs))) (when gnus-newsrc-assoc (setq gnus-newsrc-alist gnus-newsrc-assoc)))) - (dolist (elem gnus-newsrc-alist) - ;; Protect against broken .newsrc.el files. - (when (car elem) - (setcar elem (string-as-unibyte (car elem))))) (gnus-make-hashtable-from-newsrc-alist) (when (file-newer-than-file-p file ding-file) ;; Old format quick file @@ -2829,73 +2819,75 @@ If FORCE is non-nil, the .newsrc file is read." (erase-buffer) (gnus-message 5 "Saving %s.eld..." gnus-current-startup-file) - ;; check timestamp of `gnus-current-startup-file'.eld against - ;; `gnus-save-newsrc-file-last-timestamp' - (let* ((checkfile (concat gnus-current-startup-file ".eld")) - (mtime (nth 5 (file-attributes checkfile)))) - (when (and gnus-save-newsrc-file-last-timestamp - (time-less-p gnus-save-newsrc-file-last-timestamp - mtime)) - (unless (y-or-n-p + ;; Check timestamp of `gnus-current-startup-file'.eld against + ;; `gnus-save-newsrc-file-last-timestamp'. + (if (let* ((checkfile (concat gnus-current-startup-file ".eld")) + (mtime (nth 5 (file-attributes checkfile)))) + (and gnus-save-newsrc-file-last-timestamp + (time-less-p gnus-save-newsrc-file-last-timestamp + mtime) + (not + (y-or-n-p (format "%s was updated externally after %s, save?" checkfile (format-time-string - "%c" - gnus-save-newsrc-file-last-timestamp))) - (error "Couldn't save %s: updated externally" checkfile)))) - - (if gnus-save-startup-file-via-temp-buffer + "%c" + gnus-save-newsrc-file-last-timestamp)))))) + (gnus-message + 4 "Didn't save %s: updated externally" + (concat gnus-current-startup-file ".eld")) + (if gnus-save-startup-file-via-temp-buffer + (let ((coding-system-for-write gnus-ding-file-coding-system) + (standard-output (current-buffer))) + (gnus-gnus-to-quick-newsrc-format) + (gnus-run-hooks 'gnus-save-quick-newsrc-hook) + (save-buffer) + (setq gnus-save-newsrc-file-last-timestamp + (nth 5 (file-attributes buffer-file-name)))) (let ((coding-system-for-write gnus-ding-file-coding-system) - (standard-output (current-buffer))) - (gnus-gnus-to-quick-newsrc-format) - (gnus-run-hooks 'gnus-save-quick-newsrc-hook) - (save-buffer) - (setq gnus-save-newsrc-file-last-timestamp - (nth 5 (file-attributes buffer-file-name)))) - (let ((coding-system-for-write gnus-ding-file-coding-system) - (version-control gnus-backup-startup-file) - (startup-file (concat gnus-current-startup-file ".eld")) - (working-dir (file-name-directory gnus-current-startup-file)) - working-file - (i -1)) - ;; Generate the name of a non-existent file. - (while (progn (setq working-file - (format - (if (and (eq system-type 'ms-dos) - (not (gnus-long-file-names))) - "%s#%d.tm#" ; MSDOS limits files to 8+3 - "%s#tmp#%d") - working-dir (setq i (1+ i)))) - (file-exists-p working-file))) - - (unwind-protect - (progn - (gnus-with-output-to-file working-file - (gnus-gnus-to-quick-newsrc-format) - (gnus-run-hooks 'gnus-save-quick-newsrc-hook)) - - ;; These bindings will mislead the current buffer - ;; into thinking that it is visiting the startup - ;; file. - (let ((buffer-backed-up nil) - (buffer-file-name startup-file) - (file-precious-flag t) - (setmodes (file-modes startup-file))) - ;; Backup the current version of the startup file. - (backup-buffer) - - ;; Replace the existing startup file with the temp file. - (rename-file working-file startup-file t) - (gnus-set-file-modes startup-file setmodes) - (setq gnus-save-newsrc-file-last-timestamp - (nth 5 (file-attributes startup-file))))) - (condition-case nil - (delete-file working-file) - (file-error nil))))) - - (gnus-kill-buffer (current-buffer)) - (gnus-message - 5 "Saving %s.eld...done" gnus-current-startup-file)) + (version-control gnus-backup-startup-file) + (startup-file (concat gnus-current-startup-file ".eld")) + (working-dir (file-name-directory gnus-current-startup-file)) + working-file + (i -1)) + ;; Generate the name of a non-existent file. + (while (progn (setq working-file + (format + (if (and (eq system-type 'ms-dos) + (not (gnus-long-file-names))) + "%s#%d.tm#" ; MSDOS limits files to 8+3 + "%s#tmp#%d") + working-dir (setq i (1+ i)))) + (file-exists-p working-file))) + + (unwind-protect + (progn + (gnus-with-output-to-file working-file + (gnus-gnus-to-quick-newsrc-format) + (gnus-run-hooks 'gnus-save-quick-newsrc-hook)) + + ;; These bindings will mislead the current buffer + ;; into thinking that it is visiting the startup + ;; file. + (let ((buffer-backed-up nil) + (buffer-file-name startup-file) + (file-precious-flag t) + (setmodes (file-modes startup-file))) + ;; Backup the current version of the startup file. + (backup-buffer) + + ;; Replace the existing startup file with the temp file. + (rename-file working-file startup-file t) + (gnus-set-file-modes startup-file setmodes) + (setq gnus-save-newsrc-file-last-timestamp + (nth 5 (file-attributes startup-file))))) + (condition-case nil + (delete-file working-file) + (file-error nil))))) + + (gnus-kill-buffer (current-buffer)) + (gnus-message + 5 "Saving %s.eld...done" gnus-current-startup-file))) (gnus-dribble-delete-file) (gnus-group-set-mode-line))))) diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index a39af45e92e..e562b30170a 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -24,7 +24,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(require 'cl-lib) (defvar tool-bar-mode) (defvar gnus-tmp-header) @@ -1266,9 +1266,13 @@ For example: ((1 . cn-gb-2312) (2 . big5))." :type 'boolean :group 'gnus-summary-marks) -(defcustom gnus-alter-articles-to-read-function nil - "Function to be called to alter the list of articles to be selected." - :type '(choice (const nil) function) +(defcustom gnus-alter-articles-to-read-function + (lambda (_group article-list) article-list) + "Function to be called to alter the list of articles to be selected. +This option defaults to a lambda form that simply returns the +list of articles unchanged. Use `add-function' to set one or +more custom filter functions." + :type 'function :group 'gnus-summary) (defcustom gnus-orphan-score nil @@ -2366,7 +2370,7 @@ increase the score of each group you read." ["Edit current score file" gnus-score-edit-current-scores t] ["Edit score file..." gnus-score-edit-file t] ["Trace score" gnus-score-find-trace t] - ["Find words" gnus-score-find-favourite-words t] + ["Find words" gnus-score-find-favorite-words t] ["Rescore buffer" gnus-summary-rescore t] ["Increase score..." gnus-summary-increase-score t] ["Lower score..." gnus-summary-lower-score t])))) @@ -2625,6 +2629,7 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) ["Resend message edit" gnus-summary-resend-message-edit t] ["Send bounced mail" gnus-summary-resend-bounced-mail t] ["Send a mail" gnus-summary-mail-other-window t] + ["Attach article to outgoing message" gnus-summary-attach-article t] ["Create a local message" gnus-summary-news-other-window t] ["Uuencode and post" gnus-uu-post-news :help "Post a uuencoded article"] @@ -2940,6 +2945,8 @@ See `gmm-tool-bar-from-list' for the format of the list." (defvar image-load-path) (defvar tool-bar-map) +(declare-function image-load-path-for-library "image" + (library image &optional path no-error)) (defun gnus-summary-make-tool-bar (&optional force) "Make a summary mode tool bar from `gnus-summary-tool-bar'. @@ -3803,7 +3810,7 @@ the thread are to be displayed." 1) (t 0)))) (when (and level (zerop level) gnus-tmp-new-adopts) - (incf number + (cl-incf number (apply '+ (mapcar 'gnus-summary-number-of-articles-in-thread gnus-tmp-new-adopts)))) @@ -3992,7 +3999,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." (spam-initialize)) ;; Save the active value in effect when the group was entered. (setq gnus-newsgroup-active - (gnus-copy-sequence + (copy-tree (gnus-active gnus-newsgroup-name))) (setq gnus-newsgroup-highest (cdr gnus-newsgroup-active)) ;; You can change the summary buffer in some way with this hook. @@ -4405,7 +4412,7 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise." (setq end (1+ (point))) (when (search-backward "<" nil t) (setq new-child (buffer-substring (point) end)) - (push (list (incf generation) + (push (list (cl-incf generation) child (setq child new-child) subject date) relations))) @@ -4426,7 +4433,7 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise." (push gnus-reffed-article-number gnus-newsgroup-sparse) (push (cons gnus-reffed-article-number gnus-sparse-mark) gnus-newsgroup-reads) - (decf gnus-reffed-article-number))) + (cl-decf gnus-reffed-article-number))) (gnus-message 7 "Making sparse threads...done"))) (defun gnus-build-old-threads () @@ -4719,7 +4726,7 @@ If LINE, insert the rebuilt thread starting on line LINE." (setq parent (gnus-parent-id references))) (car (gnus-id-to-thread parent)) nil)) - (decf generation)) + (cl-decf generation)) (and (not (eq headers in-headers)) headers))) @@ -5463,7 +5470,7 @@ or a straight list of headers." (nthcdr 1 thread)) stack)) (push (if (nth 1 thread) 1 0) tree-stack) - (incf gnus-tmp-level) + (cl-incf gnus-tmp-level) (setq threads (if thread-end nil (cdar thread))) (if gnus-summary-display-while-building (if building-count @@ -5737,7 +5744,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." (mail-header-number (car gnus-newsgroup-headers)) gnus-newsgroup-end (mail-header-number - (gnus-last-element gnus-newsgroup-headers)))) + (car (last gnus-newsgroup-headers))))) ;; GROUP is successfully selected. (or gnus-newsgroup-headers t))))) @@ -5914,7 +5921,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." (setq articles (nthcdr (- number select) articles)))) (setq gnus-newsgroup-unselected (gnus-sorted-difference gnus-newsgroup-unreads articles)) - (when gnus-alter-articles-to-read-function + (when (functionp gnus-alter-articles-to-read-function) (setq articles (sort (funcall gnus-alter-articles-to-read-function @@ -6076,12 +6083,12 @@ If SELECT-ARTICLES, only select those articles from GROUP." (del (gnus-list-range-intersection gnus-newsgroup-articles - (gnus-remove-from-range (gnus-copy-sequence old) list))) + (gnus-remove-from-range (copy-tree old) list))) (add (gnus-list-range-intersection gnus-newsgroup-articles (gnus-remove-from-range - (gnus-copy-sequence list) old)))) + (copy-tree list) old)))) (when add (push (list add 'add (list (cdr type))) delta-marks)) (when del @@ -6111,7 +6118,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." (let ((i 5)) (while (and (> i 2) (not (nth i info))) - (when (nthcdr (decf i) info) + (when (nthcdr (cl-decf i) info) (setcdr (nthcdr i info) nil))))))) (defun gnus-set-mode-line (where) @@ -6303,6 +6310,7 @@ The resulting hash table is returned, or nil if no Xrefs were found." (when ,set-marks (gnus-request-set-mark ,group (list (list ',range 'del '(read))))) + (gnus-group-jump-to-group ,group) (gnus-group-update-group ,group t)))) ;; Add the read articles to the range. (gnus-info-set-read info range) @@ -6651,7 +6659,7 @@ current article will be taken into consideration." (if backward (gnus-summary-find-prev nil article) (gnus-summary-find-next nil article))) - (decf n))) + (cl-decf n))) (nreverse articles))) ((and (and transient-mark-mode mark-active) (mark)) (message "region active") @@ -7056,12 +7064,20 @@ buffer." (or (get-buffer-window gnus-article-buffer) (eq gnus-current-article (gnus-summary-article-number)) (gnus-summary-show-article)) - (gnus-configure-windows - (if gnus-widen-article-window - 'only-article - 'article) - t) - (select-window (get-buffer-window gnus-article-buffer)))) + (let ((point (with-current-buffer gnus-article-buffer + (point)))) + (gnus-configure-windows + (if gnus-widen-article-window + 'only-article + 'article) + t) + (select-window (get-buffer-window gnus-article-buffer)) + ;; If we've just selected the message, place point at the start of + ;; the body because that's probably where we want to be. + (if (not (= point (point-min))) + (goto-char point) + (article-goto-body) + (forward-char -1))))) (defun gnus-summary-universal-argument (arg) "Perform any operation on all articles that are process/prefixed." @@ -7274,12 +7290,13 @@ If FORCE (the prefix), also save the .newsrc file(s)." (if quit-config (gnus-handle-ephemeral-exit quit-config) (goto-char group-point) + (unless leave-hidden + (gnus-configure-windows 'group 'force)) ;; If gnus-group-buffer is already displayed, make sure we also move ;; the cursor in the window that displays it. (let ((win (get-buffer-window (current-buffer) 0))) - (if win (set-window-point win (point)))) - (unless leave-hidden - (gnus-configure-windows 'group 'force))) + (goto-char group-point) + (if win (set-window-point win (point))))) ;; If we have several article buffers, we kill them at exit. (unless single-article-buffer @@ -7343,7 +7360,7 @@ If FORCE (the prefix), also save the .newsrc file(s)." (setq gnus-newsgroup-name nil) (unless (gnus-ephemeral-group-p group) (gnus-group-update-group group nil t)) - (when (equal (gnus-group-group-name) group) + (when (gnus-group-goto-group group) (gnus-group-next-unread-group 1)) (gnus-article-stop-animations) (when quit-config @@ -7796,7 +7813,8 @@ If BACKWARD, the previous article is selected instead of the next." (cond ((or (not gnus-auto-select-next) (not cmd)) - (gnus-message 7 "No more%s articles" (if unread " unread" ""))) + (unless (eq gnus-auto-select-next 'quietly) + (gnus-message 6 "No more%s articles" (if unread " unread" "")))) ((or (eq gnus-auto-select-next 'quietly) (and (eq gnus-auto-select-next 'slightly-quietly) push) @@ -7805,10 +7823,11 @@ If BACKWARD, the previous article is selected instead of the next." ;; Select quietly. (if (gnus-ephemeral-group-p gnus-newsgroup-name) (gnus-summary-exit) - (gnus-message 7 "No more%s articles (%s)..." - (if unread " unread" "") - (if group (concat "selecting " group) - "exiting")) + (unless (eq gnus-auto-select-next 'quietly) + (gnus-message 6 "No more%s articles (%s)..." + (if unread " unread" "") + (if group (concat "selecting " group) + "exiting"))) (gnus-summary-next-group nil group backward))) (t (when (numberp last-input-event) @@ -8555,14 +8574,22 @@ Returns how many articles were removed." (gnus-summary-limit articles)) (gnus-summary-position-point))) -(defun gnus-summary-limit-to-score (score) - "Limit to articles with score at or above SCORE." - (interactive "NLimit to articles with score of at least: ") +(defun gnus-summary-limit-to-score (score &optional below) + "Limit to articles with score at or above SCORE. + +With a prefix argument, limit to articles with score at or below +SCORE." + (interactive (list (string-to-number + (read-string + (format "Limit to articles with score of at %s: " + (if current-prefix-arg "most" "least")))))) (let ((data gnus-newsgroup-data) - articles) + (compare (if (or below current-prefix-arg) #'<= #'>=)) + articles) (while data - (when (>= (gnus-summary-article-score (gnus-data-number (car data))) - score) + (when (funcall compare (gnus-summary-article-score + (gnus-data-number (car data))) + score) (push (gnus-data-number (car data)) articles)) (setq data (cdr data))) (prog1 @@ -8755,7 +8782,7 @@ If ALL, mark even excluded ticked and dormants as read." (let ((num 0)) (while threads (when (memq (mail-header-number (caar threads)) gnus-newsgroup-limit) - (incf num)) + (cl-incf num)) (pop threads)) (< num 2))) @@ -8887,7 +8914,7 @@ fetch-old-headers verbiage, and so on." gnus-summary-expunge-below)) ;; We increase the expunge-tally here, but that has ;; nothing to do with the limits, really. - (incf gnus-newsgroup-expunged-tally) + (cl-incf gnus-newsgroup-expunged-tally) ;; We also mark as read here, if that's wanted. (when (and gnus-summary-mark-below (< score gnus-summary-mark-below)) @@ -8912,7 +8939,7 @@ fetch-old-headers verbiage, and so on." (defun gnus-expunge-thread (thread) "Mark all articles in THREAD as read." (let* ((number (mail-header-number (car thread)))) - (incf gnus-newsgroup-expunged-tally) + (cl-incf gnus-newsgroup-expunged-tally) ;; We also mark as read here, if that's wanted. (setq gnus-newsgroup-unreads (delq number gnus-newsgroup-unreads)) @@ -8964,7 +8991,7 @@ The difference between N and the number of articles fetched is returned." (gnus-message 1 "No references in article %d" (gnus-summary-article-number)) (setq error t)) - (decf n)) + (cl-decf n)) (gnus-summary-position-point) n)) @@ -8980,7 +9007,7 @@ Return the number of articles fetched." (error "No References in the current article") ;; For each Message-ID in the References header... (while (string-match "<[^>]*>" ref) - (incf n) + (cl-incf n) ;; ... fetch that article. (gnus-summary-refer-article (prog1 (match-string 0 ref) @@ -11142,7 +11169,7 @@ If NO-EXPIRE, auto-expiry will be inhibited." (re-search-backward "[\n\r]" (point-at-bol) 'move-to-limit) (when forward (when (looking-at "\r") - (incf forward)) + (cl-incf forward)) (when (<= (+ forward (point)) (point-max)) ;; Go to the right position on the line. (goto-char (+ forward (point))) @@ -11722,7 +11749,7 @@ will not be hidden." (let ((end nil) (count 0)) (while (not end) - (incf count) + (cl-incf count) (when (zerop (mod count 1000)) (message "Hiding all threads... %d" count)) (when (or (not predicate) @@ -11794,7 +11821,7 @@ If SILENT, don't output messages." (n (abs n))) (while (and (> n 0) (gnus-summary-go-to-next-thread backward)) - (decf n)) + (cl-decf n)) (unless silent (gnus-summary-position-point)) (when (and (not silent) (/= 0 n)) @@ -11962,7 +11989,7 @@ Argument REVERSE means reverse order." (interactive "P") (gnus-summary-sort 'chars reverse)) -(defun gnus-summary-sort-by-mark (&optional reverse) +(defun gnus-summary-sort-by-marks (&optional reverse) "Sort the summary buffer by article marks. Argument REVERSE means reverse order." (interactive "P") @@ -11981,7 +12008,8 @@ Argument REVERSE means reverse order." (defun gnus-summary-sort (predicate reverse) "Sort summary buffer by PREDICATE. REVERSE means reverse order." - (let* ((thread (intern (format "gnus-thread-sort-by-%s" predicate))) + (let* ((current (gnus-summary-article-number)) + (thread (intern (format "gnus-thread-sort-by-%s" predicate))) (article (intern (format "gnus-article-sort-by-%s" predicate))) (gnus-thread-sort-functions (if (not reverse) @@ -12000,7 +12028,9 @@ Argument REVERSE means reverse order." ;; We do the sorting by regenerating the threads. (gnus-summary-prepare) ;; Hide subthreads if needed. - (gnus-summary-maybe-hide-threads))) + (gnus-summary-maybe-hide-threads) + ;; Restore point. + (gnus-summary-goto-subject current))) ;; Summary saving commands. @@ -12270,21 +12300,27 @@ save those articles instead." (if (> (length articles) 1) (format "these %d articles" (length articles)) "this article"))) + valid-names (to-newsgroup - (cond - ((null split-name) - (gnus-group-completing-read - prom - (gnus-remove-if-not 'gnus-valid-move-group-p gnus-active-hashtb t) - nil prefix nil default)) - ((= 1 (length split-name)) - (gnus-group-completing-read - prom - (gnus-remove-if-not 'gnus-valid-move-group-p gnus-active-hashtb t) - nil prefix 'gnus-group-history (car split-name))) - (t - (gnus-completing-read - prom (nreverse split-name) nil nil 'gnus-group-history)))) + (progn + (mapatoms (lambda (g) + (when (gnus-valid-move-group-p g) + (push g valid-names))) + gnus-active-hashtb) + (cond + ((null split-name) + (gnus-group-completing-read + prom + valid-names + nil prefix nil default)) + ((= 1 (length split-name)) + (gnus-group-completing-read + prom + valid-names + nil prefix 'gnus-group-history (car split-name))) + (t + (gnus-completing-read + prom (nreverse split-name) nil nil 'gnus-group-history))))) (to-method (gnus-server-to-method (gnus-group-method to-newsgroup))) encoded) (when to-newsgroup @@ -12359,7 +12395,7 @@ If REVERSE, save parts that do not match TYPE." (cdr gnus-article-current) gnus-summary-save-parts-counter)))) dir))) - (incf gnus-summary-save-parts-counter) + (cl-incf gnus-summary-save-parts-counter) (unless (file-exists-p file) (mm-save-part-to-file handle file)))))) @@ -12532,7 +12568,7 @@ If REVERSE, save parts that do not match TYPE." ;; article numbers for this article. (mail-header-set-number header gnus-reffed-article-number)) (with-current-buffer gnus-summary-buffer - (decf gnus-reffed-article-number) + (cl-decf gnus-reffed-article-number) (gnus-remove-header (mail-header-number header)) (push header gnus-newsgroup-headers) (setq gnus-current-headers header) @@ -12691,6 +12727,7 @@ UNREAD is a sorted list." `(progn (gnus-info-set-marks ',info ',(gnus-info-marks info) t) (gnus-info-set-read ',info ',(gnus-info-read info)) + (gnus-group-jump-to-group ,group) (gnus-get-unread-articles-in-group ',info (gnus-active ,group)) (gnus-group-update-group ,group t) @@ -12915,7 +12952,7 @@ returned." (mail-header-number (car gnus-newsgroup-headers)) gnus-newsgroup-end (mail-header-number - (gnus-last-element gnus-newsgroup-headers)))) + (car (last gnus-newsgroup-headers))))) (when gnus-use-scoring (gnus-possibly-score-headers)))) @@ -13002,12 +13039,12 @@ If ALL is a number, fetch this number of articles." i new) (unless new-active (error "Couldn't fetch new data")) - (setq gnus-newsgroup-active (gnus-copy-sequence new-active)) + (setq gnus-newsgroup-active (copy-tree new-active)) (setq i (cdr gnus-newsgroup-active) gnus-newsgroup-highest i) (while (> i old-high) (push i new) - (decf i)) + (cl-decf i)) (if (not new) (message "No gnus is bad news") (gnus-summary-insert-articles new) diff --git a/lisp/gnus/gnus-topic.el b/lisp/gnus/gnus-topic.el index 0ff25ecd3b5..111f2ae28a4 100644 --- a/lisp/gnus/gnus-topic.el +++ b/lisp/gnus/gnus-topic.el @@ -25,7 +25,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gnus) (require 'gnus-group) @@ -128,7 +128,7 @@ See Info node `(gnus)Formatting Variables'." number) (while entries (when (numberp (setq number (car (pop entries)))) - (incf total number))) + (cl-incf total number))) total)) (defun gnus-group-topic (group) @@ -220,6 +220,8 @@ If RECURSIVE is t, return groups in its subtopics too." ;; Check for permanent visibility. (and gnus-permanently-visible-groups (string-match gnus-permanently-visible-groups group)) + ;; Marked groups are always visible. + (member group gnus-group-marked) (memq 'visible params) (cdr (assq 'visible params))) ;; Add this group to the list of visible groups. @@ -302,7 +304,7 @@ If RECURSIVE is t, return groups in its subtopics too." (while (and (not (zerop num)) (setq topic (funcall way topic))) (when (gnus-topic-goto-topic topic) - (decf num))) + (cl-decf num))) (unless (zerop num) (goto-char (point-max))) num)) @@ -458,7 +460,7 @@ If LOWEST is non-nil, list all newsgroups of level LOWEST or higher." (unless gnus-killed-hashtb (gnus-make-hashtable-from-killed)) (gnus-group-prepare-flat-list-dead - (gnus-remove-if (lambda (group) + (seq-remove (lambda (group) (or (gnus-group-entry group) (gnus-gethash group gnus-killed-hashtb))) not-in-list) @@ -508,7 +510,7 @@ articles in the topic and its subtopics." info entry end active tick) ;; Insert any sub-topics. (while topicl - (incf unread + (cl-incf unread (gnus-topic-prepare-topic (pop topicl) (1+ level) list-level predicate (not visiblep) lowest regexp))) @@ -562,7 +564,7 @@ articles in the topic and its subtopics." (car entry) (gnus-info-method info))))) (when (and (listp entry) (numberp (car entry))) - (incf unread (car entry))) + (cl-incf unread (car entry))) (when (listp entry) (setq tick t)))) (goto-char beg) @@ -728,10 +730,10 @@ articles in the topic and its subtopics." (cdr gnus-group-list-mode))) entry) (while children - (incf unread (gnus-topic-unread (caar (pop children))))) + (cl-incf unread (gnus-topic-unread (caar (pop children))))) (while (setq entry (pop entries)) (when (numberp (car entry)) - (incf unread (car entry)))) + (cl-incf unread (car entry)))) (gnus-topic-insert-topic-line topic t t (car (gnus-topic-find-topology topic)) nil unread))) @@ -772,10 +774,10 @@ articles in the topic and its subtopics." (if reads (setq unread (- (gnus-group-topic-unread) reads)) (while children - (incf unread (gnus-topic-unread (caar (pop children))))) + (cl-incf unread (gnus-topic-unread (caar (pop children))))) (while (setq entry (pop entries)) (when (numberp (car entry)) - (incf unread (car entry))))) + (cl-incf unread (car entry))))) (setq old-unread (gnus-group-topic-unread)) ;; Insert the topic line. (gnus-topic-insert-topic-line diff --git a/lisp/gnus/gnus-undo.el b/lisp/gnus/gnus-undo.el index 8144e0cadc8..d487262c931 100644 --- a/lisp/gnus/gnus-undo.el +++ b/lisp/gnus/gnus-undo.el @@ -43,8 +43,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - (require 'gnus-util) (require 'gnus) diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index 1c42d7d0ef8..b30e4d125b2 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -32,8 +32,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'time-date) @@ -142,7 +141,7 @@ This is a compatibility function for different Emacsen." "Extract address components from a From header. Given an RFC-822 address FROM, extract full name and canonical address. Returns a list of the form (FULL-NAME CANONICAL-ADDRESS). Much more simple -solution than `mail-extract-address-components', which works much better, but +solution than `mail-header-parse-address', which works much better, but is slower." (let (name address) ;; First find the address - the thing with the @ in it. This may @@ -1117,41 +1116,9 @@ ARG is passed to the first function." (with-current-buffer gnus-group-buffer (eq major-mode 'gnus-group-mode)))) -(defun gnus-remove-if (predicate sequence &optional hash-table-p) - "Return a copy of SEQUENCE with all items satisfying PREDICATE removed. -SEQUENCE should be a list, a vector, or a string. Returns always a list. -If HASH-TABLE-P is non-nil, regards SEQUENCE as a hash table." - (let (out) - (if hash-table-p - (mapatoms (lambda (symbol) - (unless (funcall predicate symbol) - (push symbol out))) - sequence) - (unless (listp sequence) - (setq sequence (append sequence nil))) - (while sequence - (unless (funcall predicate (car sequence)) - (push (car sequence) out)) - (setq sequence (cdr sequence)))) - (nreverse out))) - -(defun gnus-remove-if-not (predicate sequence &optional hash-table-p) - "Return a copy of SEQUENCE with all items not satisfying PREDICATE removed. -SEQUENCE should be a list, a vector, or a string. Returns always a list. -If HASH-TABLE-P is non-nil, regards SEQUENCE as a hash table." - (let (out) - (if hash-table-p - (mapatoms (lambda (symbol) - (when (funcall predicate symbol) - (push symbol out))) - sequence) - (unless (listp sequence) - (setq sequence (append sequence nil))) - (while sequence - (when (funcall predicate (car sequence)) - (push (car sequence) out)) - (setq sequence (cdr sequence)))) - (nreverse out))) +(define-obsolete-function-alias 'gnus-remove-if 'seq-remove "27.1") + +(define-obsolete-function-alias 'gnus-remove-if-not 'seq-filter "27.1") (defun gnus-grep-in-list (word list) "Find if a WORD matches any regular expression in the given LIST." @@ -1440,7 +1407,7 @@ SPEC is a predicate specifier that contains stuff like `or', `and', (symbol-value history) collection)) filtered-choices) (dolist (x choices) - (setq filtered-choices (adjoin x filtered-choices))) + (setq filtered-choices (cl-adjoin x filtered-choices))) (nreverse filtered-choices)))))) (unwind-protect (progn @@ -1648,8 +1615,7 @@ empty directories from OLD-PATH." "Rescale IMAGE to SIZE if possible. SIZE is in format (WIDTH . HEIGHT). Return a new image. Sizes are in pixels." - (if (or (not (fboundp 'imagemagick-types)) - (not (get-buffer-window (current-buffer)))) + (if (not (fboundp 'imagemagick-types)) image (let ((new-width (car size)) (new-height (cdr size))) diff --git a/lisp/gnus/gnus-uu.el b/lisp/gnus/gnus-uu.el index f660b861f7b..a171a385956 100644 --- a/lisp/gnus/gnus-uu.el +++ b/lisp/gnus/gnus-uu.el @@ -26,7 +26,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gnus) (require 'gnus-art) @@ -2047,7 +2047,7 @@ If no file has been included, the user will be asked for a file." (setq length (count-lines (point-min) (point-max))) (setq parts (/ length gnus-uu-post-length)) (unless (< (% length gnus-uu-post-length) 4) - (incf parts))) + (cl-incf parts))) (when gnus-uu-post-separate-description (forward-line -1)) @@ -2106,7 +2106,7 @@ If no file has been included, the user will be asked for a file." (insert-buffer-substring uubuf beg end) (insert beg-line "\n") (setq beg end) - (incf i) + (cl-incf i) (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$") nil t) diff --git a/lisp/gnus/gnus-vm.el b/lisp/gnus/gnus-vm.el index f0c48db10d6..24235d9c718 100644 --- a/lisp/gnus/gnus-vm.el +++ b/lisp/gnus/gnus-vm.el @@ -34,12 +34,6 @@ (require 'gnus) (require 'gnus-msg) -(eval-when-compile - (require 'cl)) - -(autoload 'vm-mode "vm") -(autoload 'vm-save-message "vm") - (defvar gnus-vm-inhibit-window-system nil "Inhibit loading `win-vm' if using a window-system. Has to be set before gnus-vm is loaded.") @@ -49,6 +43,8 @@ Has to be set before gnus-vm is loaded.") (when window-system (require 'win-vm)))) +(declare-function vm-mode "ext:vm" (&optional read-only)) + (defun gnus-vm-make-folder (&optional buffer) (require 'vm) (let ((article (or buffer (current-buffer))) @@ -81,6 +77,8 @@ save those articles instead." (let ((gnus-default-article-saver 'gnus-summary-save-in-vm)) (gnus-summary-save-article arg))) +(declare-function vm-save-message "ext:vm-save" (folder &optional count)) + (defun gnus-summary-save-in-vm (&optional folder) (interactive) (require 'vm) diff --git a/lisp/gnus/gnus-win.el b/lisp/gnus/gnus-win.el index 28fd66ca75e..ff3073a6794 100644 --- a/lisp/gnus/gnus-win.el +++ b/lisp/gnus/gnus-win.el @@ -24,7 +24,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gnus) (require 'gnus-util) @@ -312,7 +312,7 @@ See the Gnus manual for an explanation of the syntax used.") ;; Select the frame in question and do more splits there. (select-frame frame) (setq fresult (or (gnus-configure-frame (elt subs i)) fresult)) - (incf i)) + (cl-incf i)) ;; Select the frame that has the selected buffer. (when fresult (select-frame (window-frame fresult))))) @@ -344,7 +344,7 @@ See the Gnus manual for an explanation of the syntax used.") ((eq type 'vertical) (setq s (max s window-min-height)))) (setcar (cdar comp-subs) s) - (incf total s))) + (cl-incf total s))) ;; Take care of the "1.0" spec. (if rest (setcar (cdr rest) (- len total)) @@ -513,7 +513,7 @@ should have point." (memq frame '(t 0 visible))) (car (let ((frames (frames-on-display-list))) - (gnus-remove-if (lambda (win) (not (memq (window-frame win) + (seq-remove (lambda (win) (not (memq (window-frame win) frames))) (get-buffer-window-list buffer nil frame))))) (t diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index 4af818d9165..2786323f671 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -1,4 +1,4 @@ -;;; gnus.el --- a newsreader for GNU Emacs +;;; gnus.el --- a newsreader for GNU Emacs -*- lexical-binding:t -*- ;; Copyright (C) 1987-1990, 1993-1998, 2000-2018 Free Software ;; Foundation, Inc. @@ -29,10 +29,11 @@ (run-hooks 'gnus-load-hook) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'wid-edit) (require 'mm-util) (require 'nnheader) +(require 'seq) ;; These are defined afterwards with gnus-define-group-parameter (defvar gnus-ham-process-destinations) @@ -335,21 +336,6 @@ be set in `.emacs' instead." ;; We define these group faces here to avoid the display ;; update forced when creating new faces. -(defface gnus-group-news-1 - '((((class color) - (background dark)) - (:foreground "PaleTurquoise" :bold t)) - (((class color) - (background light)) - (:foreground "ForestGreen" :bold t)) - (t - ())) - "Level 1 newsgroup face." - :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-news-1-face 'face-alias 'gnus-group-news-1) -(put 'gnus-group-news-1-face 'obsolete-face "22.1") - (defface gnus-group-news-1-empty '((((class color) (background dark)) @@ -361,24 +347,11 @@ be set in `.emacs' instead." ())) "Level 1 empty newsgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-news-1-empty-face 'face-alias 'gnus-group-news-1-empty) -(put 'gnus-group-news-1-empty-face 'obsolete-face "22.1") -(defface gnus-group-news-2 - '((((class color) - (background dark)) - (:foreground "turquoise" :bold t)) - (((class color) - (background light)) - (:foreground "CadetBlue4" :bold t)) - (t - ())) - "Level 2 newsgroup face." +(defface gnus-group-news-1 + '((t (:inherit gnus-group-news-1-empty :bold t))) + "Level 1 newsgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-news-2-face 'face-alias 'gnus-group-news-2) -(put 'gnus-group-news-2-face 'obsolete-face "22.1") (defface gnus-group-news-2-empty '((((class color) @@ -391,24 +364,11 @@ be set in `.emacs' instead." ())) "Level 2 empty newsgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-news-2-empty-face 'face-alias 'gnus-group-news-2-empty) -(put 'gnus-group-news-2-empty-face 'obsolete-face "22.1") -(defface gnus-group-news-3 - '((((class color) - (background dark)) - (:bold t)) - (((class color) - (background light)) - (:bold t)) - (t - ())) - "Level 3 newsgroup face." +(defface gnus-group-news-2 + '((t (:inherit gnus-group-news-2-empty :bold t))) + "Level 2 newsgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-news-3-face 'face-alias 'gnus-group-news-3) -(put 'gnus-group-news-3-face 'obsolete-face "22.1") (defface gnus-group-news-3-empty '((((class color) @@ -421,24 +381,11 @@ be set in `.emacs' instead." ())) "Level 3 empty newsgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-news-3-empty-face 'face-alias 'gnus-group-news-3-empty) -(put 'gnus-group-news-3-empty-face 'obsolete-face "22.1") -(defface gnus-group-news-4 - '((((class color) - (background dark)) - (:bold t)) - (((class color) - (background light)) - (:bold t)) - (t - ())) - "Level 4 newsgroup face." +(defface gnus-group-news-3 + '((t (:inherit gnus-group-news-3-empty :bold t))) + "Level 3 newsgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-news-4-face 'face-alias 'gnus-group-news-4) -(put 'gnus-group-news-4-face 'obsolete-face "22.1") (defface gnus-group-news-4-empty '((((class color) @@ -451,24 +398,11 @@ be set in `.emacs' instead." ())) "Level 4 empty newsgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-news-4-empty-face 'face-alias 'gnus-group-news-4-empty) -(put 'gnus-group-news-4-empty-face 'obsolete-face "22.1") -(defface gnus-group-news-5 - '((((class color) - (background dark)) - (:bold t)) - (((class color) - (background light)) - (:bold t)) - (t - ())) - "Level 5 newsgroup face." +(defface gnus-group-news-4 + '((t (:inherit gnus-group-news-4-empty :bold t))) + "Level 4 newsgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-news-5-face 'face-alias 'gnus-group-news-5) -(put 'gnus-group-news-5-face 'obsolete-face "22.1") (defface gnus-group-news-5-empty '((((class color) @@ -481,24 +415,11 @@ be set in `.emacs' instead." ())) "Level 5 empty newsgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-news-5-empty-face 'face-alias 'gnus-group-news-5-empty) -(put 'gnus-group-news-5-empty-face 'obsolete-face "22.1") -(defface gnus-group-news-6 - '((((class color) - (background dark)) - (:bold t)) - (((class color) - (background light)) - (:bold t)) - (t - ())) - "Level 6 newsgroup face." +(defface gnus-group-news-5 + '((t (:inherit gnus-group-news-5-empty :bold t))) + "Level 5 newsgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-news-6-face 'face-alias 'gnus-group-news-6) -(put 'gnus-group-news-6-face 'obsolete-face "22.1") (defface gnus-group-news-6-empty '((((class color) @@ -511,24 +432,11 @@ be set in `.emacs' instead." ())) "Level 6 empty newsgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-news-6-empty-face 'face-alias 'gnus-group-news-6-empty) -(put 'gnus-group-news-6-empty-face 'obsolete-face "22.1") -(defface gnus-group-news-low - '((((class color) - (background dark)) - (:foreground "DarkTurquoise" :bold t)) - (((class color) - (background light)) - (:foreground "DarkGreen" :bold t)) - (t - ())) - "Low level newsgroup face." +(defface gnus-group-news-6 + '((t (:inherit gnus-group-news-6-empty :bold t))) + "Level 6 newsgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-news-low-face 'face-alias 'gnus-group-news-low) -(put 'gnus-group-news-low-face 'obsolete-face "22.1") (defface gnus-group-news-low-empty '((((class color) @@ -541,24 +449,11 @@ be set in `.emacs' instead." ())) "Low level empty newsgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-news-low-empty-face 'face-alias 'gnus-group-news-low-empty) -(put 'gnus-group-news-low-empty-face 'obsolete-face "22.1") -(defface gnus-group-mail-1 - '((((class color) - (background dark)) - (:foreground "#e1ffe1" :bold t)) - (((class color) - (background light)) - (:foreground "DeepPink3" :bold t)) - (t - (:bold t))) - "Level 1 mailgroup face." +(defface gnus-group-news-low + '((t (:inherit gnus-group-news-low-empty :bold t))) + "Low level newsgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-mail-1-face 'face-alias 'gnus-group-mail-1) -(put 'gnus-group-mail-1-face 'obsolete-face "22.1") (defface gnus-group-mail-1-empty '((((class color) @@ -568,27 +463,14 @@ be set in `.emacs' instead." (background light)) (:foreground "DeepPink3")) (t - (:italic t :bold t))) + (:italic t))) "Level 1 empty mailgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-mail-1-empty-face 'face-alias 'gnus-group-mail-1-empty) -(put 'gnus-group-mail-1-empty-face 'obsolete-face "22.1") -(defface gnus-group-mail-2 - '((((class color) - (background dark)) - (:foreground "DarkSeaGreen1" :bold t)) - (((class color) - (background light)) - (:foreground "HotPink3" :bold t)) - (t - (:bold t))) - "Level 2 mailgroup face." +(defface gnus-group-mail-1 + '((t (:inherit gnus-group-mail-1-empty :bold t))) + "Level 1 mailgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-mail-2-face 'face-alias 'gnus-group-mail-2) -(put 'gnus-group-mail-2-face 'obsolete-face "22.1") (defface gnus-group-mail-2-empty '((((class color) @@ -598,27 +480,14 @@ be set in `.emacs' instead." (background light)) (:foreground "HotPink3")) (t - (:bold t))) + (:italic t))) "Level 2 empty mailgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-mail-2-empty-face 'face-alias 'gnus-group-mail-2-empty) -(put 'gnus-group-mail-2-empty-face 'obsolete-face "22.1") -(defface gnus-group-mail-3 - '((((class color) - (background dark)) - (:foreground "aquamarine1" :bold t)) - (((class color) - (background light)) - (:foreground "magenta4" :bold t)) - (t - (:bold t))) - "Level 3 mailgroup face." +(defface gnus-group-mail-2 + '((t (:inherit gnus-group-mail-2-empty :bold t))) + "Level 2 mailgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-mail-3-face 'face-alias 'gnus-group-mail-3) -(put 'gnus-group-mail-3-face 'obsolete-face "22.1") (defface gnus-group-mail-3-empty '((((class color) @@ -631,24 +500,11 @@ be set in `.emacs' instead." ())) "Level 3 empty mailgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-mail-3-empty-face 'face-alias 'gnus-group-mail-3-empty) -(put 'gnus-group-mail-3-empty-face 'obsolete-face "22.1") -(defface gnus-group-mail-low - '((((class color) - (background dark)) - (:foreground "aquamarine2" :bold t)) - (((class color) - (background light)) - (:foreground "DeepPink4" :bold t)) - (t - (:bold t))) - "Low level mailgroup face." +(defface gnus-group-mail-3 + '((t (:inherit gnus-group-mail-3-empty :bold t))) + "Level 3 mailgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-mail-low-face 'face-alias 'gnus-group-mail-low) -(put 'gnus-group-mail-low-face 'obsolete-face "22.1") (defface gnus-group-mail-low-empty '((((class color) @@ -661,57 +517,23 @@ be set in `.emacs' instead." (:bold t))) "Low level empty mailgroup face." :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-mail-low-empty-face 'face-alias 'gnus-group-mail-low-empty) -(put 'gnus-group-mail-low-empty-face 'obsolete-face "22.1") + +(defface gnus-group-mail-low + '((t (:inherit gnus-group-mail-low-empty :bold t))) + "Low level mailgroup face." + :group 'gnus-group) ;; Summary mode faces. (defface gnus-summary-selected '((t (:underline t))) "Face used for selected articles." :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-selected-face 'face-alias 'gnus-summary-selected) -(put 'gnus-summary-selected-face 'obsolete-face "22.1") (defface gnus-summary-cancelled '((((class color)) (:foreground "yellow" :background "black"))) "Face used for canceled articles." :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-cancelled-face 'face-alias 'gnus-summary-cancelled) -(put 'gnus-summary-cancelled-face 'obsolete-face "22.1") - -(defface gnus-summary-high-ticked - '((((class color) - (background dark)) - (:foreground "pink" :bold t)) - (((class color) - (background light)) - (:foreground "firebrick" :bold t)) - (t - (:bold t))) - "Face used for high interest ticked articles." - :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-high-ticked-face 'face-alias 'gnus-summary-high-ticked) -(put 'gnus-summary-high-ticked-face 'obsolete-face "22.1") - -(defface gnus-summary-low-ticked - '((((class color) - (background dark)) - (:foreground "pink" :italic t)) - (((class color) - (background light)) - (:foreground "firebrick" :italic t)) - (t - (:italic t))) - "Face used for low interest ticked articles." - :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-low-ticked-face 'face-alias 'gnus-summary-low-ticked) -(put 'gnus-summary-low-ticked-face 'obsolete-face "22.1") (defface gnus-summary-normal-ticked '((((class color) @@ -724,39 +546,16 @@ be set in `.emacs' instead." ())) "Face used for normal interest ticked articles." :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-normal-ticked-face 'face-alias 'gnus-summary-normal-ticked) -(put 'gnus-summary-normal-ticked-face 'obsolete-face "22.1") -(defface gnus-summary-high-ancient - '((((class color) - (background dark)) - (:foreground "SkyBlue" :bold t)) - (((class color) - (background light)) - (:foreground "RoyalBlue" :bold t)) - (t - (:bold t))) - "Face used for high interest ancient articles." +(defface gnus-summary-high-ticked + '((t (:inherit gnus-summary-normal-ticked :bold t))) + "Face used for high interest ticked articles." :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-high-ancient-face 'face-alias 'gnus-summary-high-ancient) -(put 'gnus-summary-high-ancient-face 'obsolete-face "22.1") -(defface gnus-summary-low-ancient - '((((class color) - (background dark)) - (:foreground "SkyBlue" :italic t)) - (((class color) - (background light)) - (:foreground "RoyalBlue" :italic t)) - (t - (:italic t))) - "Face used for low interest ancient articles." +(defface gnus-summary-low-ticked + '((t (:inherit gnus-summary-normal-ticked :italic t))) + "Face used for low interest ticked articles." :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-low-ancient-face 'face-alias 'gnus-summary-low-ancient) -(put 'gnus-summary-low-ancient-face 'obsolete-face "22.1") (defface gnus-summary-normal-ancient '((((class color) @@ -769,35 +568,16 @@ be set in `.emacs' instead." ())) "Face used for normal interest ancient articles." :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-normal-ancient-face 'face-alias 'gnus-summary-normal-ancient) -(put 'gnus-summary-normal-ancient-face 'obsolete-face "22.1") -(defface gnus-summary-high-undownloaded - '((((class color) - (background light)) - (:bold t :foreground "cyan4")) - (((class color) (background dark)) - (:bold t :foreground "LightGray")) - (t (:inverse-video t :bold t))) - "Face used for high interest uncached articles." +(defface gnus-summary-high-ancient + '((t (:inherit gnus-summary-normal-ancient :bold t))) + "Face used for high interest ancient articles." :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-high-undownloaded-face 'face-alias 'gnus-summary-high-undownloaded) -(put 'gnus-summary-high-undownloaded-face 'obsolete-face "22.1") -(defface gnus-summary-low-undownloaded - '((((class color) - (background light)) - (:italic t :foreground "cyan4" :bold nil)) - (((class color) (background dark)) - (:italic t :foreground "LightGray" :bold nil)) - (t (:inverse-video t :italic t))) - "Face used for low interest uncached articles." +(defface gnus-summary-low-ancient + '((t (:inherit gnus-summary-normal-ancient :italic t))) + "Face used for low interest ancient articles." :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-low-undownloaded-face 'face-alias 'gnus-summary-low-undownloaded) -(put 'gnus-summary-low-undownloaded-face 'obsolete-face "22.1") (defface gnus-summary-normal-undownloaded '((((class color) @@ -808,70 +588,32 @@ be set in `.emacs' instead." (t (:inverse-video t))) "Face used for normal interest uncached articles." :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-normal-undownloaded-face 'face-alias 'gnus-summary-normal-undownloaded) -(put 'gnus-summary-normal-undownloaded-face 'obsolete-face "22.1") -(defface gnus-summary-high-unread - '((t - (:bold t))) - "Face used for high interest unread articles." +(defface gnus-summary-high-undownloaded + '((t (:inherit gnus-summary-normal-undownloaded :bold t))) + "Face used for high interest uncached articles." :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-high-unread-face 'face-alias 'gnus-summary-high-unread) -(put 'gnus-summary-high-unread-face 'obsolete-face "22.1") -(defface gnus-summary-low-unread - '((t - (:italic t))) - "Face used for low interest unread articles." +(defface gnus-summary-low-undownloaded + '((t (:inherit gnus-summary-normal-undownloaded :italic t))) + "Face used for low interest uncached articles." :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-low-unread-face 'face-alias 'gnus-summary-low-unread) -(put 'gnus-summary-low-unread-face 'obsolete-face "22.1") (defface gnus-summary-normal-unread '((t ())) "Face used for normal interest unread articles." :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-normal-unread-face 'face-alias 'gnus-summary-normal-unread) -(put 'gnus-summary-normal-unread-face 'obsolete-face "22.1") -(defface gnus-summary-high-read - '((((class color) - (background dark)) - (:foreground "PaleGreen" - :bold t)) - (((class color) - (background light)) - (:foreground "DarkGreen" - :bold t)) - (t - (:bold t))) - "Face used for high interest read articles." +(defface gnus-summary-high-unread + '((t (:inherit gnus-summary-normal-unread :bold t))) + "Face used for high interest unread articles." :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-high-read-face 'face-alias 'gnus-summary-high-read) -(put 'gnus-summary-high-read-face 'obsolete-face "22.1") -(defface gnus-summary-low-read - '((((class color) - (background dark)) - (:foreground "PaleGreen" - :italic t)) - (((class color) - (background light)) - (:foreground "DarkGreen" - :italic t)) - (t - (:italic t))) - "Face used for low interest read articles." +(defface gnus-summary-low-unread + '((t (:inherit gnus-summary-normal-unread :italic t))) + "Face used for low interest unread articles." :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-low-read-face 'face-alias 'gnus-summary-low-read) -(put 'gnus-summary-low-read-face 'obsolete-face "22.1") (defface gnus-summary-normal-read '((((class color) @@ -884,9 +626,16 @@ be set in `.emacs' instead." ())) "Face used for normal interest read articles." :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-normal-read-face 'face-alias 'gnus-summary-normal-read) -(put 'gnus-summary-normal-read-face 'obsolete-face "22.1") + +(defface gnus-summary-high-read + '((t (:inherit gnus-summary-normal-read :bold t))) + "Face used for high interest read articles." + :group 'gnus-summary) + +(defface gnus-summary-low-read + '((t (:inherit gnus-summary-normal-read :italic t))) + "Face used for low interest read articles." + :group 'gnus-summary) ;;; @@ -946,9 +695,6 @@ be set in `.emacs' instead." ())) "Face for the splash screen." :group 'gnus-start) -;; backward-compatibility alias -(put 'gnus-splash-face 'face-alias 'gnus-splash) -(put 'gnus-splash-face 'obsolete-face "22.1") (defun gnus-splash () (save-excursion @@ -1006,6 +752,7 @@ be set in `.emacs' instead." (cdr (assq gnus-logo-color-style gnus-logo-color-alist)) "Colors used for the Gnus logo.") +(defvar image-load-path) (declare-function image-size "image.c" (spec &optional pixels frame)) (defun gnus-group-startup-message (&optional x y) @@ -1106,12 +853,11 @@ be set in `.emacs' instead." (cons (car list) (list :type type :data data))) list))) -(eval-when (load) - (let ((command (format "%s" this-command))) - (when (string-match "gnus" command) - (if (string-match "gnus-other-frame" command) - (gnus-get-buffer-create gnus-group-buffer) - (gnus-splash))))) +(let ((command (format "%s" this-command))) + (when (string-match "gnus" command) + (if (eq 'gnus-other-frame this-command) + (gnus-get-buffer-create gnus-group-buffer) + (gnus-splash)))) ;;; Do the rest. @@ -2479,7 +2225,7 @@ Disabling the agent may result in noticeable loss of performance." :group 'gnus-agent :type 'boolean) -(defcustom gnus-other-frame-function 'gnus +(defcustom gnus-other-frame-function #'gnus "Function called by the command `gnus-other-frame' when starting Gnus." :group 'gnus-start :type '(choice (function-item gnus) @@ -2487,7 +2233,9 @@ Disabling the agent may result in noticeable loss of performance." (function-item gnus-slave) (function-item gnus-slave-no-server))) -(defcustom gnus-other-frame-resume-function 'gnus-group-get-new-news +(declare-function gnus-group-get-new-news "gnus-group") + +(defcustom gnus-other-frame-resume-function #'gnus-group-get-new-news "Function called by the command `gnus-other-frame' when resuming Gnus." :version "24.4" :group 'gnus-start @@ -2555,7 +2303,7 @@ a string, be sure to use a valid format, see RFC 2616." ) (defvar gnus-agent-target-move-group-header "X-Gnus-Agent-Move-To") (defvar gnus-draft-meta-information-header "X-Draft-From") -(defvar gnus-group-get-parameter-function 'gnus-group-get-parameter) +(defvar gnus-group-get-parameter-function #'gnus-group-get-parameter) (defvar gnus-original-article-buffer " *Original Article*") (defvar gnus-newsgroup-name nil) (defvar gnus-ephemeral-servers nil) @@ -2592,7 +2340,9 @@ a string, be sure to use a valid format, see RFC 2616." (defvar gnus-group-history nil) (defvar gnus-server-alist nil - "List of available servers.") + "Servers created by Gnus, or via the server buffer. +Servers defined in the user's config files do not appear here. +This variable is persisted in the user's .newsrc.eld file.") (defcustom gnus-cache-directory (nnheader-concat gnus-directory "cache/") @@ -2755,7 +2505,6 @@ gnus-registry.el will populate this if it's loaded.") (nthcdr 3 package) (cdr package))))) '(("info" :interactive t Info-goto-node) - ("pp" pp-to-string) ("qp" quoted-printable-decode-region quoted-printable-decode-string) ("ps-print" ps-print-preprint) ("message" :interactive t @@ -2902,7 +2651,6 @@ gnus-registry.el will populate this if it's loaded.") gnus-check-reasonable-setup) ("gnus-dup" gnus-dup-suppress-articles gnus-dup-unsuppress-article gnus-dup-enter-articles) - ("gnus-range" gnus-copy-sequence) ("gnus-eform" gnus-edit-form) ("gnus-logic" gnus-score-advanced) ("gnus-undo" gnus-undo-mode gnus-undo-register) @@ -3179,9 +2927,9 @@ with a `subscribed' parameter." (or (gnus-group-fast-parameter group 'to-address) (gnus-group-fast-parameter group 'to-list)))) (when address - (add-to-list 'addresses address)))) + (cl-pushnew address addresses :test #'equal)))) (when addresses - (list (mapconcat 'regexp-quote addresses "\\|"))))) + (list (mapconcat #'regexp-quote addresses "\\|"))))) (defmacro gnus-string-or (&rest strings) "Return the first element of STRINGS that is a non-blank string. @@ -3234,6 +2982,8 @@ If ARG, insert string at point." minor least) (format "%d.%02d%02d" major minor least)))))) +(defvar gnus-info-buffer) + (defun gnus-info-find-node (&optional nodename) "Find Info documentation of Gnus." (interactive) @@ -3253,7 +3003,7 @@ If ARG, insert string at point." (defvar gnus-current-prefix-symbols nil "List of current prefix symbols.") -(defun gnus-interactive (string &optional params) +(defun gnus-interactive (string) "Return a list that can be fed to `interactive'. See `interactive' for full documentation. @@ -3345,9 +3095,9 @@ g -- Group name." (setq out (delq 'gnus-prefix-nil out)) (nreverse out))) -(defun gnus-symbolic-argument (&optional arg) +(defun gnus-symbolic-argument () "Read a symbolic argument and a command, and then execute command." - (interactive "P") + (interactive) (let* ((in-command (this-command-keys)) (command in-command) gnus-current-prefix-symbols @@ -3463,16 +3213,15 @@ that that variable is buffer-local to the summary buffers." (throw 'server-name (car name-method)))) gnus-server-method-cache)) - (mapc - (lambda (server-alist) - (mapc (lambda (name-method) - (when (gnus-methods-equal-p (cdr name-method) method) - (unless (member name-method gnus-server-method-cache) - (push name-method gnus-server-method-cache)) - (throw 'server-name (car name-method)))) - server-alist)) - (list gnus-server-alist - gnus-predefined-server-alist)) + (dolist (server-alist + (list gnus-server-alist + gnus-predefined-server-alist)) + (mapc (lambda (name-method) + (when (gnus-methods-equal-p (cdr name-method) method) + (unless (member name-method gnus-server-method-cache) + (push name-method gnus-server-method-cache)) + (throw 'server-name (car name-method)))) + server-alist)) (let* ((name (if (member (cadr method) '(nil "")) (format "%s" (car method)) @@ -3574,26 +3323,26 @@ that that variable is buffer-local to the summary buffers." (let ((p1 (copy-sequence (cddr m1))) (p2 (copy-sequence (cddr m2))) e1 e2) - (block nil + (cl-block nil (while (setq e1 (pop p1)) (unless (setq e2 (assq (car e1) p2)) ;; The parameter doesn't exist in p2. - (return nil)) + (cl-return nil)) (setq p2 (delq e2 p2)) (unless (equal e1 e2) (if (not (and (stringp (cadr e1)) (stringp (cadr e2)))) - (return nil) + (cl-return nil) ;; Special-case string parameter comparison so that we ;; can uniquify them. (let ((s1 (cadr e1)) (s2 (cadr e2))) - (when (string-match "/$" s1) + (when (string-match "/\\'" s1) (setq s1 (directory-file-name s1))) - (when (string-match "/$" s2) + (when (string-match "/\\'" s2) (setq s2 (directory-file-name s2))) (unless (equal s1 s2) - (return nil)))))) + (cl-return nil)))))) ;; If p2 now is empty, they were equal. (null p2)))) @@ -3981,8 +3730,7 @@ If SCORE is nil, add 1 to the score of GROUP." "Collapse GROUP name LEVELS. Select methods are stripped and any remote host name is stripped down to just the host name." - (let* ((name "") - (foreign "") + (let* ((foreign "") (depth 0) (skip 1) (levels (or levels @@ -4024,13 +3772,13 @@ just the host name." gsep ".")) (setq levels (- glen levels)) (dolist (g glist) - (push (if (>= (decf levels) 0) + (push (if (>= (cl-decf levels) 0) (if (zerop (length g)) "" (substring g 0 1)) g) res)) - (concat foreign (mapconcat 'identity (nreverse res) gsep)))))) + (concat foreign (mapconcat #'identity (nreverse res) gsep)))))) (defun gnus-narrow-to-body () "Narrow to the body of an article." @@ -4272,7 +4020,7 @@ Allow completion over sensible values." gnus-server-alist)) (method (gnus-completing-read - prompt (mapcar 'car servers) + prompt (mapcar #'car servers) t nil 'gnus-method-history))) (cond ((equal method "") @@ -4385,13 +4133,13 @@ current display is used." (progn (switch-to-buffer gnus-group-buffer) (funcall gnus-other-frame-resume-function arg)) (funcall gnus-other-frame-function arg) - (add-hook 'gnus-exit-gnus-hook 'gnus-delete-gnus-frame) + (add-hook 'gnus-exit-gnus-hook #'gnus-delete-gnus-frame) ;; One might argue that `gnus-delete-gnus-frame' should not be called ;; from `gnus-suspend-gnus-hook', but, on the other hand, one might ;; argue that it should. No matter what you think, for the sake of ;; those who want it to be called from it, please keep (defun ;; gnus-delete-gnus-frame) even if you remove the next `add-hook'. - (add-hook 'gnus-suspend-gnus-hook 'gnus-delete-gnus-frame))))) + (add-hook 'gnus-suspend-gnus-hook #'gnus-delete-gnus-frame))))) ;;;###autoload (defun gnus (&optional arg dont-connect slave) diff --git a/lisp/gnus/mail-source.el b/lisp/gnus/mail-source.el index d2850f4cee3..51f76a4a2e8 100644 --- a/lisp/gnus/mail-source.el +++ b/lisp/gnus/mail-source.el @@ -26,7 +26,7 @@ (require 'format-spec) (eval-when-compile - (require 'cl) + (require 'cl-lib) (require 'imap)) (autoload 'auth-source-search "auth-source") (autoload 'pop3-movemail "pop3") @@ -439,7 +439,7 @@ the `mail-source-keyword-map' variable." ;; the msname is the mail-source parameter (dolist (msname '(:server :user :port)) ;; the asname is the auth-source parameter - (let* ((asname (case msname + (let* ((asname (cl-case msname (:server :host) ; auth-source uses :host (t msname))) ;; this is the mail-source default @@ -786,7 +786,7 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) (when (and (file-regular-p file) (funcall predicate file) (mail-source-movemail file mail-source-crash-box)) - (incf found (mail-source-callback callback file)) + (cl-incf found (mail-source-callback callback file)) (mail-source-run-script postscript (format-spec-make ?t path)) (mail-source-delete-crash-box))) found))) @@ -1041,7 +1041,7 @@ This only works when `display-time' is enabled." (insert "\001\001\001\001\n")) (delete-file file) nil)))) - (incf found (mail-source-callback callback file)) + (cl-incf found (mail-source-callback callback file)) (mail-source-delete-crash-box))))) found))) @@ -1116,7 +1116,7 @@ This only works when `display-time' is enabled." (replace-match ">From ")) (goto-char (point-max)))) (nnheader-ms-strip-cr)) - (incf found (mail-source-callback callback server)) + (cl-incf found (mail-source-callback callback server)) (mail-source-delete-crash-box) (when (and remove fetchflag) (setq remove (nreverse remove)) diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 461f61f144d..dde9c28656c 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -28,9 +28,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) - +(require 'cl-lib) (require 'mailheader) (require 'gmm-utils) (require 'mail-utils) @@ -158,7 +156,7 @@ If this variable is nil, no such courtesy message will be added." :group 'message-interface :type 'regexp) -(defcustom message-from-style mail-from-style +(defcustom message-from-style 'angles "Specifies how \"From\" headers look. If nil, they contain just the return address like: @@ -170,12 +168,16 @@ If `angles', they look like: Otherwise, most addresses look like `angles', but they look like `parens' if `angles' would need quoting and `parens' would not." - :version "23.2" + :version "27.1" :type '(choice (const :tag "simple" nil) (const parens) (const angles) (const default)) :group 'message-headers) +(make-obsolete-variable + 'message-from-style + "Only the `angles' value is valid according to RFC2822" "27.1") + (defcustom message-insert-canlock t "Whether to insert a Cancel-Lock header in news postings." @@ -550,10 +552,15 @@ The provided functions are: (function-item message-forward-subject-name-subject) (repeat :tag "List of functions" function))) -(defcustom message-forward-as-mime t +(defcustom message-forward-as-mime nil "Non-nil means forward messages as an inline/rfc822 MIME section. -Otherwise, directly inline the old message in the forwarded message." - :version "21.1" +Otherwise, directly inline the old message in the forwarded +message. + +When forwarding as MIME, certain MIME-related headers in the +forwarded message may be removed/altered to ensure that the +resulting mail is syntactically valid." + :version "27.1" :group 'message-forwarding :link '(custom-manual "(message)Forwarding") :type 'boolean) @@ -605,6 +612,9 @@ Done before generating the new subject of a forward." (defcustom message-forward-ignored-headers "^Content-Transfer-Encoding:\\|^X-Gnus" "All headers that match this regexp will be deleted when forwarding a message. +This variable is only consulted when forwarding \"normally\", not +when forwarding as MIME or the like. + This may also be a list of regexps." :version "21.1" :group 'message-forwarding @@ -615,11 +625,12 @@ This may also be a list of regexps." (widget-editable-list-match widget value))) regexp)) -(defcustom message-forward-included-headers nil +(defcustom message-forward-included-headers + '("^From:" "^Subject:" "^Date:") "If non-nil, delete non-matching headers when forwarding a message. Only headers that match this regexp will be included. This variable should be a regexp or a list of regexps." - :version "25.1" + :version "27.1" :group 'message-forwarding :type '(repeat :value-to-internal (lambda (widget value) (custom-split-regexp-maybe value)) @@ -1241,13 +1252,13 @@ called and its result is inserted." ;; Ease the transition from mail-mode to message-mode. See bugs#4431, 5555. (concat (if (and (boundp 'mail-default-reply-to) (stringp mail-default-reply-to)) - (format "Reply-to: %s\n" mail-default-reply-to)) + (format "Reply-To: %s\n" mail-default-reply-to)) (if (and (boundp 'mail-self-blind) mail-self-blind) - (format "BCC: %s\n" user-mail-address)) + (format "Bcc: %s\n" user-mail-address)) (if (and (boundp 'mail-archive-file-name) (stringp mail-archive-file-name)) - (format "FCC: %s\n" mail-archive-file-name)) + (format "Fcc: %s\n" mail-archive-file-name)) mail-default-headers) "A string of header lines to be inserted in outgoing mails." :version "23.2" @@ -1341,7 +1352,8 @@ If nil, Message won't auto-save." :link '(custom-manual "(message)Various Message Variables") :type '(choice directory (const :tag "Don't auto-save" nil))) -(defcustom message-default-charset (and (not (mm-multibyte-p)) 'iso-8859-1) +(defcustom message-default-charset (and (not enable-multibyte-characters) + 'iso-8859-1) "Default charset used in non-MULE Emacsen. If nil, you might be asked to input the charset." :version "21.1" @@ -1436,8 +1448,6 @@ starting with `not' and followed by regexps." :bold t :italic t)) "Face used for displaying To headers." :group 'message-faces) -(define-obsolete-face-alias 'message-header-to-face - 'message-header-to "22.1") (defface message-header-cc '((((class color) @@ -1450,8 +1460,6 @@ starting with `not' and followed by regexps." :bold t)) "Face used for displaying Cc headers." :group 'message-faces) -(define-obsolete-face-alias 'message-header-cc-face - 'message-header-cc "22.1") (defface message-header-subject '((((class color) @@ -1464,8 +1472,6 @@ starting with `not' and followed by regexps." :bold t)) "Face used for displaying Subject headers." :group 'message-faces) -(define-obsolete-face-alias 'message-header-subject-face - 'message-header-subject "22.1") (defface message-header-newsgroups '((((class color) @@ -1478,8 +1484,6 @@ starting with `not' and followed by regexps." :bold t :italic t)) "Face used for displaying Newsgroups headers." :group 'message-faces) -(define-obsolete-face-alias 'message-header-newsgroups-face - 'message-header-newsgroups "22.1") (defface message-header-other '((((class color) @@ -1492,8 +1496,6 @@ starting with `not' and followed by regexps." :bold t :italic t)) "Face used for displaying other headers." :group 'message-faces) -(define-obsolete-face-alias 'message-header-other-face - 'message-header-other "22.1") (defface message-header-name '((((class color) @@ -1506,8 +1508,6 @@ starting with `not' and followed by regexps." :bold t)) "Face used for displaying header names." :group 'message-faces) -(define-obsolete-face-alias 'message-header-name-face - 'message-header-name "22.1") (defface message-header-xheader '((((class color) @@ -1520,8 +1520,6 @@ starting with `not' and followed by regexps." :bold t)) "Face used for displaying X-Header headers." :group 'message-faces) -(define-obsolete-face-alias 'message-header-xheader-face - 'message-header-xheader "22.1") (defface message-separator '((((class color) @@ -1534,8 +1532,6 @@ starting with `not' and followed by regexps." :bold t)) "Face used for displaying the separator." :group 'message-faces) -(define-obsolete-face-alias 'message-separator-face - 'message-separator "22.1") (defface message-cited-text '((((class color) @@ -1548,8 +1544,6 @@ starting with `not' and followed by regexps." :bold t)) "Face used for displaying cited text names." :group 'message-faces) -(define-obsolete-face-alias 'message-cited-text-face - 'message-cited-text "22.1") (defface message-mml '((((class color) @@ -1562,53 +1556,50 @@ starting with `not' and followed by regexps." :bold t)) "Face used for displaying MML." :group 'message-faces) -(define-obsolete-face-alias 'message-mml-face - 'message-mml "22.1") -(defun message-font-lock-make-header-matcher (regexp) - (let ((form - `(lambda (limit) - (let ((start (point))) - (save-restriction - (widen) - (goto-char (point-min)) - (if (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "$") - nil t) - (setq limit (min limit (match-beginning 0)))) - (goto-char start)) - (and (< start limit) - (re-search-forward ,regexp limit t)))))) - (if (featurep 'bytecomp) - (byte-compile form) - form))) +(defun message-match-to-eoh (_limit) + (let ((start (point))) + (rfc822-goto-eoh) + ;; Typical situation: some temporary change causes the header to be + ;; incorrect, so EOH comes earlier than intended: the last lines of the + ;; intended headers are now not considered part of the header any more, + ;; so they don't have the multiline property set. When the change is + ;; completed and the header has its correct shape again, the lack of the + ;; multiline property means we won't rehighlight the last lines of + ;; the header. + (if (< (point) start) + nil ;No header within start..limit. + ;; Here we disregard LIMIT so that we may extend the area again. + (set-match-data (list start (point))) + (point)))) (defvar message-font-lock-keywords (let ((content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)\n?")) - `((,(message-font-lock-make-header-matcher - (concat "^\\([Tt]o:\\)" content)) - (1 'message-header-name) - (2 'message-header-to nil t)) - (,(message-font-lock-make-header-matcher - (concat "^\\(^[GBF]?[Cc][Cc]:\\|^[Rr]eply-[Tt]o:\\)" content)) - (1 'message-header-name) - (2 'message-header-cc nil t)) - (,(message-font-lock-make-header-matcher - (concat "^\\([Ss]ubject:\\)" content)) - (1 'message-header-name) - (2 'message-header-subject nil t)) - (,(message-font-lock-make-header-matcher - (concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content)) - (1 'message-header-name) - (2 'message-header-newsgroups nil t)) - (,(message-font-lock-make-header-matcher - (concat "^\\(X-[A-Za-z0-9-]+:\\|In-Reply-To:\\)" content)) - (1 'message-header-name) - (2 'message-header-xheader)) - (,(message-font-lock-make-header-matcher - (concat "^\\([A-Z][^: \n\t]+:\\)" content)) - (1 'message-header-name) - (2 'message-header-other nil t)) + `((message-match-to-eoh + (,(concat "^\\([Tt]o:\\)" content) + (progn (goto-char (match-beginning 0)) (match-end 0)) nil + (1 'message-header-name) + (2 'message-header-to nil t)) + (,(concat "^\\(^[GBF]?[Cc][Cc]:\\|^[Rr]eply-[Tt]o:\\)" content) + (progn (goto-char (match-beginning 0)) (match-end 0)) nil + (1 'message-header-name) + (2 'message-header-cc nil t)) + (,(concat "^\\([Ss]ubject:\\)" content) + (progn (goto-char (match-beginning 0)) (match-end 0)) nil + (1 'message-header-name) + (2 'message-header-subject nil t)) + (,(concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content) + (progn (goto-char (match-beginning 0)) (match-end 0)) nil + (1 'message-header-name) + (2 'message-header-newsgroups nil t)) + (,(concat "^\\(X-[A-Za-z0-9-]+:\\|In-Reply-To:\\)" content) + (progn (goto-char (match-beginning 0)) (match-end 0)) nil + (1 'message-header-name) + (2 'message-header-xheader)) + (,(concat "^\\([A-Z][^: \n\t]+:\\)" content) + (progn (goto-char (match-beginning 0)) (match-end 0)) nil + (1 'message-header-name) + (2 'message-header-other nil t))) ,@(if (and mail-header-separator (not (equal mail-header-separator ""))) `((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$") @@ -2436,7 +2427,7 @@ Return the number of headers removed." (looking-at "[!-9;-~]+:")) (looking-at regexp)) (progn - (incf number) + (cl-incf number) (when first (setq last t)) (delete-region @@ -2461,10 +2452,10 @@ Return the number of headers removed." (save-excursion (goto-char (point-min)) (while (re-search-forward regexp nil t) - (incf count))) + (cl-incf count))) (while (> count 1) (message-remove-header header nil t) - (decf count)))) + (cl-decf count)))) (defun message-narrow-to-headers () "Narrow the buffer to the head of the message." @@ -2607,6 +2598,36 @@ PGG manual, depending on the value of `mml2015-use'." (t 'message))))) +(defun message-all-recipients () + "Return a list of all recipients in the message, looking at TO, Cc and Bcc. + +Each recipient is in the format of `mail-extract-address-components'." + (mapcan (lambda (header) + (let ((header-value (message-fetch-field header))) + (and + header-value + (mail-extract-address-components header-value t)))) + '("To" "Cc" "Bcc"))) + +(defun message-all-epg-keys-available-p () + "Return non-nil if the pgp keyring has a public key for each recipient." + (require 'epa) + (let ((context (epg-make-context epa-protocol))) + (catch 'break + (dolist (recipient (message-all-recipients)) + (let ((recipient-email (cadr recipient))) + (when (and recipient-email (not (epg-list-keys context recipient-email))) + (throw 'break nil)))) + t))) + +(defun message-sign-encrypt-if-all-keys-available () + "Add MML tag to encrypt message when there is a key for each recipient. + +Consider adding this function to `message-send-hook' to +systematically send encrypted emails when possible." + (when (message-all-epg-keys-available-p) + (mml-secure-message-sign-encrypt))) + ;;; @@ -2844,8 +2865,7 @@ See also `message-forbidden-properties'." (message-display-abbrev)) (when (and message-strip-special-text-properties (message-tamago-not-in-use-p begin)) - (let ((buffer-read-only nil) - (inhibit-read-only t)) + (let ((inhibit-read-only t)) (remove-text-properties begin end message-forbidden-properties)))) (defvar message-smileys '(":-)" ":)" @@ -2952,7 +2972,7 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." (easy-menu-add message-mode-menu message-mode-map) (easy-menu-add message-mode-field-menu message-mode-map) ;; Mmmm... Forbidden properties... - (add-hook 'after-change-functions 'message-strip-forbidden-properties + (add-hook 'after-change-functions #'message-strip-forbidden-properties nil 'local) ;; Allow mail alias things. (cond @@ -2960,7 +2980,9 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." (mail-abbrevs-setup)) ((message-mail-alias-type-p 'ecomplete) (ecomplete-setup))) - (add-hook 'completion-at-point-functions 'message-completion-function nil t) + ;; FIXME: merge the completion tables from ecomplete/bbdb/...? + ;;(add-hook 'completion-at-point-functions #'message-ecomplete-capf nil t) + (add-hook 'completion-at-point-functions #'message-completion-function nil t) (unless buffer-file-name (message-set-auto-save-file-name)) (unless (buffer-base-buffer) @@ -3094,17 +3116,15 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." (push-mark) (message-position-on-field "Summary" "Subject")) -(defun message-goto-body () - "Move point to the beginning of the message body." - (interactive) - (when (and (called-interactively-p 'any) - (looking-at "[ \t]*\n")) +(define-obsolete-function-alias 'message-goto-body-1 'message-goto-body "27.1") +(defun message-goto-body (&optional interactive) + "Move point to the beginning of the message body. +Returns point." + (interactive "p") + (when interactive + (when (looking-at "[ \t]*\n") (expand-abbrev)) - (push-mark) - (message-goto-body-1)) - -(defun message-goto-body-1 () - "Go to the body and return point." + (push-mark)) (goto-char (point-min)) (or (search-forward (concat "\n" mail-header-separator "\n") nil t) ;; If the message is mangled, find the end of the headers the @@ -3123,12 +3143,12 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." "Return t if point is in the message body." (>= (point) (save-excursion - (message-goto-body-1)))) + (message-goto-body)))) -(defun message-goto-eoh () +(defun message-goto-eoh (&optional interactive) "Move point to the end of the headers." - (interactive) - (message-goto-body) + (interactive "p") + (message-goto-body interactive) (forward-line -1)) (defun message-goto-signature () @@ -3219,13 +3239,13 @@ or in the synonym headers, defined by `message-header-synonyms'." (dolist (header headers) (let* ((header-name (symbol-name (car header))) (new-header (cdr header)) - (synonyms (loop for synonym in message-header-synonyms - when (memq (car header) synonym) return synonym)) + (synonyms (cl-loop for synonym in message-header-synonyms + when (memq (car header) synonym) return synonym)) (old-header - (loop for synonym in synonyms - for old-header = (mail-fetch-field (symbol-name synonym)) - when (and old-header (string-match new-header old-header)) - return synonym))) + (cl-loop for synonym in synonyms + for old-header = (mail-fetch-field (symbol-name synonym)) + when (and old-header (string-match new-header old-header)) + return synonym))) (if old-header (message "already have `%s' in `%s'" new-header old-header) (when (and (message-position-on-field header-name) @@ -3545,7 +3565,7 @@ Note that this should not be used in newsgroups." (message-remove-header "Disposition-Notification-To")) (message-goto-eoh) (insert (format "Disposition-Notification-To: %s\n" - (or (message-field-value "Reply-to") + (or (message-field-value "Reply-To") (message-field-value "From") (message-make-from)))))) @@ -3586,7 +3606,7 @@ text was killed." "Create a rot table with offset N." (let ((i -1) (table (make-string 256 0))) - (while (< (incf i) 256) + (while (< (cl-incf i) 256) (aset table i i)) (concat (substring table 0 ?A) @@ -3754,13 +3774,13 @@ To use this automatically, you may add this function to (goto-char (mark t)) (insert-before-markers ?\n) (goto-char pt)))) - (case message-cite-reply-position - (above + (pcase message-cite-reply-position + ('above (message-goto-body) (insert body-text) (insert (if (bolp) "\n" "\n\n")) (message-goto-body)) - (below + ('below (message-goto-signature))) ;; Add a `message-setup-very-last-hook' here? ;; Add `gnus-article-highlight-citation' here? @@ -4278,7 +4298,7 @@ conformance." (point-max)))) (setq char (char-after))) (when (or (< char 128) - (and (mm-multibyte-p) + (and enable-multibyte-characters (memq (char-charset char) '(eight-bit-control eight-bit-graphic ;; Emacs 23, Bug#1770: @@ -4310,7 +4330,7 @@ conformance." (while (not (eobp)) (when (let ((char (char-after))) (or (< char 128) - (and (mm-multibyte-p) + (and enable-multibyte-characters ;; FIXME: Wrong for Emacs 23 (unicode) and for ;; things like undecodable utf-8 (in Emacs 21?). ;; Should at least use find-coding-systems-region. @@ -4383,7 +4403,7 @@ This function could be useful in `message-setup-hook'." (if (string= encoded bog) "" (format " (%s)" encoded)))))) - (error "Bogus address")))))))) + (user-error "Bogus address")))))))) (custom-add-option 'message-setup-hook 'message-check-recipients) @@ -4605,9 +4625,9 @@ This function could be useful in `message-setup-hook'." (with-current-buffer mailbuf message-courtesy-message))) ;; Let's make sure we encoded all the body. - (assert (save-excursion - (goto-char (point-min)) - (not (re-search-forward "[^\000-\377]" nil t)))) + (cl-assert (save-excursion + (goto-char (point-min)) + (not (re-search-forward "[^\000-\377]" nil t)))) (mm-disable-multibyte) (if (or (not message-send-mail-partially-limit) (< (buffer-size) message-send-mail-partially-limit) @@ -4672,9 +4692,11 @@ that instead." (message-send-mail-with-sendmail)) ((equal (car method) "smtp") (require 'smtpmail) - (let ((smtpmail-smtp-server (nth 1 method)) - (smtpmail-smtp-service (nth 2 method)) - (smtpmail-smtp-user (or (nth 3 method) smtpmail-smtp-user))) + (let* ((smtpmail-smtp-server (nth 1 method)) + (service (nth 2 method)) + (port (string-to-number service)) + (smtpmail-smtp-service (if (> port 0) port service)) + (smtpmail-smtp-user (or (nth 3 method) smtpmail-smtp-user))) (message-smtpmail-send-it))) (t (error "Unknown method %s" method)))))) @@ -4761,7 +4783,7 @@ to find out how to use this." (replace-match "\n") (run-hooks 'message-send-mail-hook) ;; send the message - (case + (pcase (let ((coding-system-for-write message-send-coding-system)) (apply 'call-process-region (point-min) (point-max) @@ -4792,7 +4814,7 @@ to find out how to use this." (100 (error "qmail-inject reported permanent failure")) (111 (error "qmail-inject reported transient failure")) ;; should never happen - (t (error "qmail-inject reported unknown failure")))) + (_ (error "qmail-inject reported unknown failure")))) (defvar mh-previous-window-config) @@ -5315,7 +5337,9 @@ Otherwise, generate and save a value for `canlock-password' first." ;; Check for control characters. (message-check 'control-chars (if (re-search-forward - (string-to-multibyte "[\000-\007\013\015-\032\034-\037\200-\237]") + (eval-when-compile + (decode-coding-string "[\000-\007\013\015-\032\034-\037\200-\237]" + 'binary)) nil t) (y-or-n-p "The article contains control characters. Really post? ") @@ -5417,7 +5441,7 @@ Otherwise, generate and save a value for `canlock-password' first." (concat "^" (regexp-quote mail-header-separator) "$") nil t) (replace-match "" t t )) - ;; Process FCC operations. + ;; Process Fcc operations. (while list (setq file (pop list)) (if (string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" file) @@ -5842,10 +5866,10 @@ subscribed address (and not the additional To and Cc header contents)." message-subscribed-address-functions)))) (save-match-data (let ((list - (loop for recipient in recipients - when (loop for regexp in mft-regexps - thereis (string-match regexp recipient)) - return recipient))) + (cl-loop for recipient in recipients + when (cl-loop for regexp in mft-regexps + thereis (string-match regexp recipient)) + return recipient))) (when list (if only-show-subscribed list @@ -6194,7 +6218,7 @@ they are." (when (> count maxcount) (let ((surplus (- count maxcount))) (message-shorten-1 refs cut surplus) - (decf count surplus))) + (cl-decf count surplus))) ;; When sending via news, make sure the total folded length will ;; be less than 998 characters. This is to cater to broken INN @@ -6719,9 +6743,9 @@ The function is called with one parameter, a cons cell ..." ;; Gmane renames "To". Look at "Original-To", too, if it is present in ;; message-header-synonyms. (setq to (or (message-fetch-field "to") - (and (loop for synonym in message-header-synonyms - when (memq 'Original-To synonym) - return t) + (and (cl-loop for synonym in message-header-synonyms + when (memq 'Original-To synonym) + return t) (message-fetch-field "original-to"))) cc (message-fetch-field "cc") extra (when message-extra-wide-headers @@ -6859,6 +6883,9 @@ want to get rid of this query permanently."))) (setq recipients (delq recip recipients)))))))) (setq recipients (message-prune-recipients recipients)) + (setq recipients + (cl-loop for (id . address) in recipients + collect (cons id (message--alter-repeat-address address)))) ;; Build the header alist. Allow the user to be asked whether ;; or not to reply to all recipients in a wide reply. @@ -6889,6 +6916,15 @@ want to get rid of this query permanently."))) (setq recipients (delq recipient recipients)))))))) recipients) +(defun message--alter-repeat-address (address) + "Transform an address on the form \"\"foo@bar.com\"\" <foo@bar.com>\". +The first bit will be elided if a match is made." + (let ((bits (gnus-extract-address-components address))) + (if (equal (car bits) (cadr bits)) + (car bits) + ;; Return the original address if we don't have repetition. + address))) + (defcustom message-simplify-subject-functions '(message-strip-list-identifiers message-strip-subject-re @@ -7403,7 +7439,8 @@ Optional DIGEST will use digest to forward." (when message-forward-included-headers (message-remove-header (if (listp message-forward-included-headers) - (regexp-opt message-forward-included-headers) + (mapconcat #'identity (cons "^$" message-forward-included-headers) + "\\|") message-forward-included-headers) t nil t))))) @@ -7877,6 +7914,8 @@ See `gmm-tool-bar-from-list' for the format of the list." :group 'message) (defvar image-load-path) +(declare-function image-load-path-for-library "image" + (library image &optional path no-error)) (defun message-make-tool-bar (&optional force) "Make a message mode tool bar from `message-tool-bar-list'. @@ -7903,6 +7942,7 @@ When FORCE, rebuild the tool bar." :type 'regexp) (defcustom message-completion-alist + ;; FIXME: Make it possible to use the standard completion UI. (list (cons message-newgroups-header-regexp 'message-expand-group) '("^\\(Resent-\\)?\\(To\\|B?Cc\\):" . message-expand-name) '("^\\(Reply-To\\|From\\|Mail-Followup-To\\|Mail-Copies-To\\):" @@ -8126,11 +8166,12 @@ From headers in the original article." (message-tokenize-header (mail-strip-quoted-names (mapconcat 'message-fetch-reply-field fields ",")))) - (email (cond ((functionp message-alternative-emails) - (car (cl-remove-if-not message-alternative-emails emails))) - (t (loop for email in emails - if (string-match-p message-alternative-emails email) - return email))))) + (email + (cond ((functionp message-alternative-emails) + (car (cl-remove-if-not message-alternative-emails emails))) + (t (cl-loop for email in emails + if (string-match-p message-alternative-emails email) + return email))))) (unless (or (not email) (equal email user-mail-address)) (message-remove-header "From") (goto-char (point-max)) @@ -8226,16 +8267,19 @@ From headers in the original article." (autoload 'ecomplete-display-matches "ecomplete") +(defun message--in-tocc-p () + (and (memq (char-after (point-at-bol)) '(?C ?T ?\t ? )) + (message-point-in-header-p) + (save-excursion + (beginning-of-line) + (while (and (memq (char-after) '(?\t ? )) + (zerop (forward-line -1)))) + (looking-at "To:\\|Cc:")))) + (defun message-display-abbrev (&optional choose) "Display the next possible abbrev for the text before point." (interactive (list t)) - (when (and (memq (char-after (point-at-bol)) '(?C ?T ?\t ? )) - (message-point-in-header-p) - (save-excursion - (beginning-of-line) - (while (and (memq (char-after) '(?\t ? )) - (zerop (forward-line -1)))) - (looking-at "To:\\|Cc:"))) + (when (message--in-tocc-p) (let* ((end (point)) (start (save-excursion (and (re-search-backward "[\n\t ]" nil t) @@ -8248,6 +8292,20 @@ From headers in the original article." (delete-region start end) (insert match))))) +(defun message-ecomplete-capf () + "Return completion data for email addresses in Ecomplete. +Meant for use on `completion-at-point-functions'." + (when (and (bound-and-true-p ecomplete-database) + (fboundp 'ecomplete-completion-table) + (message--in-tocc-p)) + (let ((end (save-excursion + (skip-chars-forward "^, \t\n") + (point))) + (start (save-excursion + (skip-chars-backward "^, \t\n") + (point)))) + `(,start ,end ,(ecomplete-completion-table 'mail))))) + ;; To send pre-formatted letters like the example below, you can use ;; `message-send-form-letter': ;; --8<---------------cut here---------------start------------->8--- @@ -8355,6 +8413,9 @@ even if NEW-VALUE is empty." (message-position-on-field header)) (insert new-value)))) +(make-obsolete-variable + 'message-recipients-without-full-name + "Recipients are simplified by default" "27.1") (defcustom message-recipients-without-full-name (list "ding@gnus.org" "bugs@gnus.org" @@ -8370,6 +8431,7 @@ Used in `message-simplify-recipients'." :version "23.1" ;; No Gnus :group 'message-headers) +(make-obsolete 'message-simplify-recipients nil "27.1") (defun message-simplify-recipients () (interactive) (dolist (hdr '("Cc" "To")) diff --git a/lisp/gnus/mm-bodies.el b/lisp/gnus/mm-bodies.el index faf887cbb9d..e292dac16fe 100644 --- a/lisp/gnus/mm-bodies.el +++ b/lisp/gnus/mm-bodies.el @@ -262,7 +262,7 @@ decoding. If it is nil, default to `mail-parse-charset'." (setq coding-system (mm-charset-to-coding-system mail-parse-charset))) (when (and charset coding-system - (mm-multibyte-p) + enable-multibyte-characters (or (not (eq coding-system 'ascii)) (setq coding-system mail-parse-charset))) (decode-coding-region (point-min) (point-max) coding-system)) @@ -289,7 +289,7 @@ decoding. If it is nil, default to `mail-parse-charset'." (setq coding-system (mm-charset-to-coding-system mail-parse-charset))) (when (and charset coding-system - (mm-multibyte-p) + enable-multibyte-characters (or (not (eq coding-system 'ascii)) (setq coding-system mail-parse-charset))) (decode-coding-string string coding-system))) diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el index 87941b88450..3e6883b2a4b 100644 --- a/lisp/gnus/mm-decode.el +++ b/lisp/gnus/mm-decode.el @@ -1,4 +1,4 @@ -;;; mm-decode.el --- Functions for decoding MIME things +;;; mm-decode.el --- Functions for decoding MIME things -*- lexical-binding:t -*- ;; Copyright (C) 1998-2018 Free Software Foundation, Inc. @@ -25,7 +25,7 @@ (require 'mail-parse) (require 'mm-bodies) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (autoload 'gnus-map-function "gnus-util") @@ -118,8 +118,7 @@ ((executable-find "w3m") 'gnus-w3m) ((executable-find "links") 'links) ((executable-find "lynx") 'lynx) - ((locate-library "html2text") 'html2text) - (t nil)) + ((locate-library "html2text") 'html2text)) "Render of HTML contents. It is one of defined renderer types, or a rendering function. The defined renderer types are: @@ -129,9 +128,8 @@ The defined renderer types are: `w3m-standalone': use plain w3m; `links': use links; `lynx': use lynx; -`html2text': use html2text; -nil : use external viewer (default web browser)." - :version "24.1" +`html2text': use html2text." + :version "27.1" :type '(choice (const shr) (const gnus-w3m) (const w3m :tag "emacs-w3m") @@ -139,7 +137,6 @@ nil : use external viewer (default web browser)." (const links) (const lynx) (const html2text) - (const nil :tag "External viewer") (function)) :group 'mime-display) @@ -323,10 +320,12 @@ type inline." (defcustom mm-keep-viewer-alive-types '("application/postscript" "application/msword" "application/vnd.ms-excel" - "application/pdf" "application/x-dvi") - "List of media types for which the external viewer will not be killed -when selecting a different article." - :version "22.1" + "application/pdf" "application/x-dvi" + "application/vnd.*") + "Media types for viewers not to be killed when selecting a different article. +Instead the viewers will be killed on Gnus exit instead. This is +a list of regexps." + :version "27.1" :type '(repeat regexp) :group 'mime-display) @@ -761,7 +760,7 @@ MIME-Version header before proceeding." (defun mm-copy-to-buffer () "Copy the contents of the current buffer to a fresh buffer." (let ((obuf (current-buffer)) - (mb (mm-multibyte-p)) + (mb enable-multibyte-characters) beg) (goto-char (point-min)) (search-forward-regexp "^\n" nil t) @@ -773,15 +772,16 @@ MIME-Version header before proceeding." (insert-buffer-substring obuf beg) (current-buffer)))) -(defun mm-display-parts (handle &optional no-default) - (if (stringp (car handle)) - (mapcar 'mm-display-parts (cdr handle)) - (if (bufferp (car handle)) - (save-restriction - (narrow-to-region (point) (point)) - (mm-display-part handle) - (goto-char (point-max))) - (mapcar 'mm-display-parts handle)))) +(defun mm-display-parts (handle) + (cond + ((stringp (car handle)) (mapcar #'mm-display-parts (cdr handle))) + ((bufferp (car handle)) + (save-restriction + (narrow-to-region (point) (point)) + (mm-display-part handle) + (goto-char (point-max)))) + (t + (mapcar #'mm-display-parts handle)))) (autoload 'mailcap-parse-mailcaps "mailcap") (autoload 'mailcap-mime-info "mailcap") @@ -961,15 +961,15 @@ external if displayed external." mm-external-terminal-program "-e" shell-file-name shell-command-switch command) - `(lambda (process state) - (if (eq 'exit (process-status process)) - (run-at-time - 60.0 nil - (lambda () - (ignore-errors (delete-file ,file)) - (ignore-errors (delete-directory - ,(file-name-directory - file)))))))) + (lambda (process _state) + (if (eq 'exit (process-status process)) + (run-at-time + 60.0 nil + (lambda () + (ignore-errors (delete-file file)) + (ignore-errors (delete-directory + (file-name-directory + file)))))))) (require 'term) (require 'gnus-win) (set-buffer @@ -982,13 +982,13 @@ external if displayed external." (term-char-mode) (set-process-sentinel (get-buffer-process buffer) - `(lambda (process state) - (when (eq 'exit (process-status process)) - (ignore-errors (delete-file ,file)) - (ignore-errors - (delete-directory ,(file-name-directory file))) - (gnus-configure-windows - ',gnus-current-window-configuration)))) + (let ((wc gnus-current-window-configuration)) + (lambda (process _state) + (when (eq 'exit (process-status process)) + (ignore-errors (delete-file file)) + (ignore-errors + (delete-directory (file-name-directory file))) + (gnus-configure-windows wc))))) (gnus-configure-windows 'display-term)) (mm-handle-set-external-undisplayer handle (cons file buffer)) (add-to-list 'mm-temp-files-to-be-deleted file t)) @@ -1032,34 +1032,29 @@ external if displayed external." shell-command-switch command) (set-process-sentinel (get-buffer-process buffer) - (lexical-let ((outbuf outbuf) - (file file) - (buffer buffer) - (command command) - (handle handle)) - (lambda (process state) - (when (eq (process-status process) 'exit) - (run-at-time - 60.0 nil - (lambda () - (ignore-errors (delete-file file)) - (ignore-errors (delete-directory - (file-name-directory file))))) - (when (buffer-live-p outbuf) - (with-current-buffer outbuf - (let ((buffer-read-only nil) - (point (point))) - (forward-line 2) - (let ((start (point))) - (mm-insert-inline - handle (with-current-buffer buffer - (buffer-string))) - (put-text-property start (point) - 'face 'mm-command-output)) - (goto-char point)))) - (when (buffer-live-p buffer) - (kill-buffer buffer))) - (message "Displaying %s...done" command))))) + (lambda (process _state) + (when (eq (process-status process) 'exit) + (run-at-time + 60.0 nil + (lambda () + (ignore-errors (delete-file file)) + (ignore-errors (delete-directory + (file-name-directory file))))) + (when (buffer-live-p outbuf) + (with-current-buffer outbuf + (let ((buffer-read-only nil) + (point (point))) + (forward-line 2) + (let ((start (point))) + (mm-insert-inline + handle (with-current-buffer buffer + (buffer-string))) + (put-text-property start (point) + 'face 'mm-command-output)) + (goto-char point)))) + (when (buffer-live-p buffer) + (kill-buffer buffer))) + (message "Displaying %s...done" command)))) (mm-handle-set-external-undisplayer handle (cons file buffer)) (add-to-list 'mm-temp-files-to-be-deleted file t)) @@ -1170,9 +1165,9 @@ external if displayed external." (goto-char (point-min)))) (defun mm-assoc-string-match (alist type) - (dolist (elem alist) + (cl-dolist (elem alist) (when (string-match (car elem) type) - (return elem)))) + (cl-return elem)))) (defun mm-automatic-display-p (handle) "Say whether the user wants HANDLE to be displayed automatically." @@ -1302,8 +1297,6 @@ are ignored." 'gnus-decoded) (with-current-buffer (mm-handle-buffer handle) (buffer-string))) - ((mm-multibyte-p) - (string-to-multibyte (mm-get-part handle no-cache))) (t (mm-get-part handle no-cache))))) (save-restriction @@ -1448,8 +1441,7 @@ text/html\\(?:;\\s-*charset=\\([^\t\n\r \"'>]+\\)\\)?[^>]*>" nil t) (defun mm-pipe-part (handle &optional cmd) "Pipe HANDLE to a process. Use CMD as the process." - (let ((name (mail-content-type-get (mm-handle-type handle) 'name)) - (command (or cmd + (let ((command (or cmd (read-shell-command "Shell command on MIME part: " mm-last-shell-command)))) (mm-with-unibyte-buffer @@ -1784,6 +1776,9 @@ If RECURSIVE, search recursively." (declare-function shr-insert-document "shr" (dom)) (defvar shr-blocked-images) (defvar shr-use-fonts) +(defvar shr-width) +(defvar shr-content-function) +(defvar shr-inhibit-images) (defun mm-shr (handle) ;; Require since we bind its variables. @@ -1840,13 +1835,14 @@ text/html;\\s-*charset=\\([^\t\n\r \"'>]+\\)[^>]*>" nil t) (mm-convert-shr-links) (mm-handle-set-undisplayer handle - `(lambda () - (let ((inhibit-read-only t)) - (delete-region ,(point-min-marker) - ,(point-max-marker)))))))) + (let ((min (point-min-marker)) + (max (point-max-marker))) + (lambda () + (let ((inhibit-read-only t)) + (delete-region min max)))))))) (defvar shr-image-map) - +(defvar shr-map) (autoload 'widget-convert-button "wid-edit") (defvar widget-keymap) @@ -1860,12 +1856,15 @@ text/html;\\s-*charset=\\([^\t\n\r \"'>]+\\)[^>]*>" nil t) (widget-convert-button 'url-link start end :help-echo (get-text-property start 'help-echo) - :keymap (setq keymap (copy-keymap shr-image-map)) + :keymap (setq keymap (copy-keymap + (if (mm-images-in-region-p start end) + shr-image-map + shr-map))) (get-text-property start 'shr-url)) ;; Mask keys that launch `widget-button-click'. ;; Those bindings are provided by `widget-keymap' ;; that is a parent of `gnus-article-mode-map'. - (dolist (key (where-is-internal #'widget-button-click widget-keymap)) + (dolist (key (where-is-internal 'widget-button-click widget-keymap)) (unless (lookup-key keymap key) (define-key keymap key #'ignore))) ;; Avoid `shr-next-link' and `shr-previous-link' in `keymap' so diff --git a/lisp/gnus/mm-encode.el b/lisp/gnus/mm-encode.el index 2eec32b9ac0..361e85fbe1f 100644 --- a/lisp/gnus/mm-encode.el +++ b/lisp/gnus/mm-encode.el @@ -23,7 +23,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'mail-parse) (autoload 'mailcap-extension-to-mime "mailcap") (autoload 'mm-body-7-or-8 "mm-bodies") @@ -204,7 +204,7 @@ This is either `base64' or `quoted-printable'." (goto-char (point-min)) (skip-chars-forward "\x20-\x7f\r\n\t" limit) (while (< (point) limit) - (incf n8bit) + (cl-incf n8bit) (forward-char 1) (skip-chars-forward "\x20-\x7f\r\n\t" limit)) (if (or (< (* 6 n8bit) (- limit (point-min))) diff --git a/lisp/gnus/mm-extern.el b/lisp/gnus/mm-extern.el index b7c602030d7..fbae669ce94 100644 --- a/lisp/gnus/mm-extern.el +++ b/lisp/gnus/mm-extern.el @@ -1,4 +1,4 @@ -;;; mm-extern.el --- showing message/external-body +;;; mm-extern.el --- showing message/external-body -*- lexical-binding:t -*- ;; Copyright (C) 2000-2018 Free Software Foundation, Inc. @@ -24,8 +24,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - (require 'mm-util) (require 'mm-decode) (require 'mm-url) @@ -33,13 +31,13 @@ (defvar gnus-article-mime-handles) (defvar mm-extern-function-alist - '((local-file . mm-extern-local-file) - (url . mm-extern-url) - (anon-ftp . mm-extern-anon-ftp) - (ftp . mm-extern-ftp) -;;; (tftp . mm-extern-tftp) - (mail-server . mm-extern-mail-server) -;;; (afs . mm-extern-afs)) + `((local-file . ,#'mm-extern-local-file) + (url . ,#'mm-extern-url) + (anon-ftp . ,#'mm-extern-anon-ftp) + (ftp . ,#'mm-extern-ftp) + ;; (tftp . ,#'mm-extern-tftp) + (mail-server . ,#'mm-extern-mail-server) + ;; (afs . ,#'mm-extern-afs)) )) (defvar mm-extern-anonymous "anonymous") @@ -72,7 +70,6 @@ (name (cdr (assq 'name params))) (site (cdr (assq 'site params))) (directory (cdr (assq 'directory params))) - (mode (cdr (assq 'mode params))) (path (concat "/" (or mm-extern-anonymous (read-string (format "ID for %s: " site))) "@" site ":" directory "/" name)) @@ -86,7 +83,7 @@ (let (mm-extern-anonymous) (mm-extern-anon-ftp handle))) -(declare-function message-goto-body "message" ()) +(declare-function message-goto-body "message" (&optional interactive)) (defun mm-extern-mail-server (handle) (require 'message) diff --git a/lisp/gnus/mm-partial.el b/lisp/gnus/mm-partial.el index b380fae7666..51dc8b89e3a 100644 --- a/lisp/gnus/mm-partial.el +++ b/lisp/gnus/mm-partial.el @@ -24,8 +24,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - (require 'gnus-sum) (require 'mm-util) (require 'mm-decode) diff --git a/lisp/gnus/mm-url.el b/lisp/gnus/mm-url.el index 1715097d4f8..1008c60a173 100644 --- a/lisp/gnus/mm-url.el +++ b/lisp/gnus/mm-url.el @@ -28,7 +28,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'mm-util) (require 'gnus) @@ -318,7 +318,7 @@ If FOLLOW-REFRESH is non-nil, redirect refresh url in META." (done nil) (first t) result) - (while (and (not (zerop (decf times))) + (while (and (not (zerop (cl-decf times))) (not done)) (with-timeout (mm-url-timeout) (unless first diff --git a/lisp/gnus/mm-util.el b/lisp/gnus/mm-util.el index fcd97f2b27c..25b156803a6 100644 --- a/lisp/gnus/mm-util.el +++ b/lisp/gnus/mm-util.el @@ -1,4 +1,4 @@ -;;; mm-util.el --- Utility functions for Mule and low level things +;;; mm-util.el --- Utility functions for Mule and low level things -*- lexical-binding:t -*- ;; Copyright (C) 1998-2018 Free Software Foundation, Inc. @@ -23,7 +23,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'mail-prsvr) (require 'timer) @@ -431,7 +431,7 @@ mail with multiple parts is preferred to sending a Unicode one.") (#x94 . #x201D) (#x95 . #x2022) (#x96 . #x2013) (#x97 . #x2014) (#x98 . #x02DC) (#x99 . #x2122) (#x9A . #x0161) (#x9B . #x203A) (#x9C . #x0153) (#x9E . #x017E) (#x9F . #x0178))) - "*Alist of extra numeric entities and characters other than ISO 10646. + "Alist of extra numeric entities and characters other than ISO 10646. This table is used for decoding extra numeric entities to characters, like \"€\" to the euro sign, mainly in html messages." :type '(alist :key-type character :value-type character) @@ -521,7 +521,7 @@ If POS is out of range, the value is nil." enable-multibyte-characters) (defun mm-iso-8859-x-to-15-region (&optional b e) - (let (charset item c inconvertible) + (let (item c inconvertible) (save-restriction (if e (narrow-to-region b e)) (goto-char (point-min)) @@ -559,7 +559,7 @@ nil means ASCII, a single-element list represents an appropriate MIME charset, and a longer list means no appropriate charset." (let (charsets) ;; The return possibilities of this function are a mess... - (or (and (mm-multibyte-p) + (or (and enable-multibyte-characters mm-use-find-coding-systems-region ;; Find the mime-charset of the most preferred coding ;; system that has one. @@ -597,7 +597,7 @@ charset, and a longer list means no appropriate charset." ;; We're not multibyte, or a single coding system won't cover it. (setq charsets (delete-dups - (mapcar 'mm-mime-charset + (mapcar #'mm-mime-charset (delq 'ascii (mm-find-charset-region b e)))))) (if (and (> (length charsets) 1) @@ -612,45 +612,23 @@ charset, and a longer list means no appropriate charset." charsets)) (defmacro mm-with-unibyte-buffer (&rest forms) - "Create a temporary buffer, and evaluate FORMS there like `progn'. -Use unibyte mode for this." + "Create a temporary unibyte buffer, and evaluate FORMS there like `progn'." + (declare (indent 0) (debug t)) `(with-temp-buffer (mm-disable-multibyte) ,@forms)) -(put 'mm-with-unibyte-buffer 'lisp-indent-function 0) -(put 'mm-with-unibyte-buffer 'edebug-form-spec '(body)) (defmacro mm-with-multibyte-buffer (&rest forms) - "Create a temporary buffer, and evaluate FORMS there like `progn'. -Use multibyte mode for this." + "Create a temporary multibyte buffer, and evaluate FORMS there like `progn'." + (declare (indent 0) (debug t)) `(with-temp-buffer (mm-enable-multibyte) ,@forms)) -(put 'mm-with-multibyte-buffer 'lisp-indent-function 0) -(put 'mm-with-multibyte-buffer 'edebug-form-spec '(body)) - -(defmacro mm-with-unibyte-current-buffer (&rest forms) - "Evaluate FORMS with current buffer temporarily made unibyte. - -Note: We recommend not using this macro any more; there should be -better ways to do a similar thing. The previous version of this macro -bound the default value of `enable-multibyte-characters' to nil while -evaluating FORMS but it is no longer done. So, some programs assuming -it if any may malfunction." - (declare (obsolete nil "25.1") (indent 0) (debug t)) - (let ((multibyte (make-symbol "multibyte"))) - `(let ((,multibyte enable-multibyte-characters)) - (when ,multibyte - (set-buffer-multibyte nil)) - (prog1 - (progn ,@forms) - (when ,multibyte - (set-buffer-multibyte t)))))) (defun mm-find-charset-region (b e) "Return a list of Emacs charsets in the region B to E." (cond - ((mm-multibyte-p) + (enable-multibyte-characters ;; Remove composition since the base charsets have been included. ;; Remove eight-bit-*, treat them as ascii. (let ((css (find-charset-region b e))) @@ -699,21 +677,26 @@ to advanced Emacs features, such as file-name-handlers, format decoding, `find-file-hook', etc. If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'. This function ensures that none of these modifications will take place." - (letf* ((format-alist nil) - (auto-mode-alist (if inhibit nil (mm-auto-mode-alist))) - ((default-value 'major-mode) 'fundamental-mode) - (enable-local-variables nil) - (after-insert-file-functions nil) - (enable-local-eval nil) - (inhibit-file-name-operation (if inhibit - 'insert-file-contents - inhibit-file-name-operation)) - (inhibit-file-name-handlers - (if inhibit - (append mm-inhibit-file-name-handlers - inhibit-file-name-handlers) - inhibit-file-name-handlers)) - (find-file-hook nil)) + (cl-letf* ((format-alist nil) + ;; FIXME: insert-file-contents doesn't look at auto-mode-alist, + ;; nor at (default-value 'major-mode)! + (auto-mode-alist (if inhibit nil (mm-auto-mode-alist))) + ((default-value 'major-mode) 'fundamental-mode) + ;; FIXME: neither enable-local-variables nor enable-local-eval are + ;; run by insert-file-contents, AFAICT?! + (enable-local-variables nil) + (after-insert-file-functions nil) + (enable-local-eval nil) + (inhibit-file-name-operation (if inhibit + 'insert-file-contents + inhibit-file-name-operation)) + (inhibit-file-name-handlers + (if inhibit + (append mm-inhibit-file-name-handlers + inhibit-file-name-handlers) + inhibit-file-name-handlers)) + ;; FIXME: insert-file-contents doesn't run find-file-hook anyway! + (find-file-hook nil)) (insert-file-contents filename visit beg end replace))) (defun mm-append-to-file (start end filename &optional codesys inhibit) @@ -838,17 +821,18 @@ decompressed data. The buffer's multibyteness must be turned off." prog t (list t err-file) nil args) jka-compr-acceptable-retval-list) (erase-buffer) - (insert (mapconcat 'identity + (insert (mapconcat #'identity (split-string (prog2 (insert-file-contents err-file) (buffer-string) - (erase-buffer)) t) + (erase-buffer)) + t) " ") "\n") (setq err-msg (format "Error while executing \"%s %s < %s\"" - prog (mapconcat 'identity args " ") + prog (mapconcat #'identity args " ") filename))) (setq retval (buffer-string))) (error @@ -898,6 +882,19 @@ gzip, bzip2, etc. are allowed." (when decomp (kill-buffer (current-buffer))))))) +(defun mm-images-in-region-p (start end) + (let ((found nil)) + (save-excursion + (goto-char start) + (while (and (not found) + (< (point) end)) + (let ((display (get-text-property (point) 'display))) + (when (and (consp display) + (eq (car display) 'image)) + (setq found t))) + (forward-char 1))) + found)) + (provide 'mm-util) ;;; mm-util.el ends here diff --git a/lisp/gnus/mm-uu.el b/lisp/gnus/mm-uu.el index e15eba75924..cf6d6d17ed5 100644 --- a/lisp/gnus/mm-uu.el +++ b/lisp/gnus/mm-uu.el @@ -24,7 +24,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (require 'mail-parse) (require 'nnheader) (require 'mm-decode) diff --git a/lisp/gnus/mm-view.el b/lisp/gnus/mm-view.el index c11af7060b7..50a927bce23 100644 --- a/lisp/gnus/mm-view.el +++ b/lisp/gnus/mm-view.el @@ -22,7 +22,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'mail-parse) (require 'mailcap) (require 'mm-bodies) @@ -318,6 +318,8 @@ (if entry (setq func (cdr entry))) (cond + ((null func) + (mm-insert-inline handle (mm-get-part handle))) ((functionp func) (funcall func handle)) (t @@ -561,7 +563,7 @@ If MODE is not set, try to find mode automatically." (error "Could not identify PKCS#7 type"))))) (defun mm-view-pkcs7 (handle &optional from) - (case (mm-view-pkcs7-get-type handle) + (cl-case (mm-view-pkcs7-get-type handle) (enveloped (mm-view-pkcs7-decrypt handle from)) (signed (mm-view-pkcs7-verify handle)) (otherwise (error "Unknown or unimplemented PKCS#7 type")))) diff --git a/lisp/gnus/mml-sec.el b/lisp/gnus/mml-sec.el index 099e5372b48..9a64853edf6 100644 --- a/lisp/gnus/mml-sec.el +++ b/lisp/gnus/mml-sec.el @@ -23,7 +23,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(require 'cl-lib) (require 'gnus-util) (require 'epg) @@ -167,9 +167,9 @@ You can also customize or set `mml-signencrypt-style-alist' instead." (if (or (eq style 'separate) (eq style 'combined)) ;; valid style setting? - (setf (second style-item) style) + (setf (cadr style-item) style) ;; otherwise, just return the current value - (second style-item)) + (cadr style-item)) (message "Warning, attempt to set invalid signencrypt style")))) ;;; Security functions @@ -554,7 +554,7 @@ customized in this variable." "For CONTEXT, USAGE, and NAME record fingerprint(s) of KEYS. If optional SAVE is not nil, save customized fingerprints. Return keys." - (assert keys) + (cl-assert keys) (let* ((usage-prefs (mml-secure-cust-usage-lookup context usage)) (curr-fprs (cdr (assoc name (cdr usage-prefs)))) (key-fprs (mapcar 'mml-secure-fingerprint keys)) @@ -647,6 +647,7 @@ The passphrase is read and cached." (when passphrase (let ((password-cache-expiry (mml-secure-cache-expiry-interval (epg-context-protocol context)))) + ;; FIXME test passphrase works before caching it. (password-cache-add password-cache-key-id passphrase)) (mml-secure-add-secret-key-id password-cache-key-id) (copy-sequence passphrase))))) @@ -903,7 +904,7 @@ If no one is selected, symmetric encryption will be performed. " (defun mml-secure-epg-encrypt (protocol cont &optional sign) ;; Based on code appearing inside mml2015-epg-encrypt. (let* ((context (epg-make-context protocol)) - (config (epg-configuration)) + (config (epg-find-configuration 'OpenPGP)) (sender (message-options-get 'message-sender)) (recipients (mml-secure-recipients protocol context config sender)) (signer-names (mml-secure-signer-names protocol sender)) diff --git a/lisp/gnus/mml-smime.el b/lisp/gnus/mml-smime.el index f91aa140e7b..9df33d09377 100644 --- a/lisp/gnus/mml-smime.el +++ b/lisp/gnus/mml-smime.el @@ -24,7 +24,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'smime) (require 'mm-decode) @@ -238,7 +238,7 @@ Whether the passphrase is cached at all is controlled by ;; todo: try dns/ldap automatically first, before prompting user (let (certs done) (while (not done) - (ecase (read (gnus-completing-read + (cl-ecase (read (gnus-completing-read "Fetch certificate from" '("dns" "ldap" "file") t nil nil "ldap")) diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el index 3c9476333fa..9fd72a93d5b 100644 --- a/lisp/gnus/mml.el +++ b/lisp/gnus/mml.el @@ -27,7 +27,7 @@ (require 'mm-encode) (require 'mm-decode) (require 'mml-sec) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (eval-when-compile (require 'url)) (autoload 'message-make-message-id "message") @@ -548,6 +548,9 @@ be \"related\" or \"alternate\"." ">"))))))) cont)))) +(autoload 'image-property "image") + +;; FIXME presumably (built-in) ImageMagick could replace exiftool? (defun mml--possibly-alter-image (file-name image) (if (or (null image) (not (consp image)) @@ -795,12 +798,12 @@ be \"related\" or \"alternate\"." (if (setq recipients (cdr (assq 'recipients cont))) (message-options-set 'message-recipients recipients)) (let ((style (mml-signencrypt-style - (first (or sign-item encrypt-item))))) + (car (or sign-item encrypt-item))))) ;; check if: we're both signing & encrypting, both methods ;; are the same (why would they be different?!), and that ;; the signencrypt style allows for combined operation. - (if (and sign-item encrypt-item (equal (first sign-item) - (first encrypt-item)) + (if (and sign-item encrypt-item (equal (car sign-item) + (car encrypt-item)) (equal style 'combined)) (funcall (nth 1 encrypt-item) cont t) ;; otherwise, revert to the old behavior. @@ -812,7 +815,7 @@ be \"related\" or \"alternate\"." (defun mml-compute-boundary (cont) "Return a unique boundary that does not exist in CONT." (let ((mml-boundary (funcall mml-boundary-function - (incf mml-multipart-number)))) + (cl-incf mml-multipart-number)))) (unless mml-inhibit-compute-boundary ;; This function tries again and again until it has found ;; a unique boundary. @@ -832,7 +835,7 @@ be \"related\" or \"alternate\"." (when (re-search-forward (concat "^--" (regexp-quote mml-boundary)) nil t) (setq mml-boundary (funcall mml-boundary-function - (incf mml-multipart-number))) + (cl-incf mml-multipart-number))) (throw 'not-unique nil)))) ((eq (car cont) 'multipart) (mapc 'mml-compute-boundary-1 (cddr cont)))) diff --git a/lisp/gnus/mml1991.el b/lisp/gnus/mml1991.el index 4198f2c0c54..b2056b2fd0d 100644 --- a/lisp/gnus/mml1991.el +++ b/lisp/gnus/mml1991.el @@ -25,9 +25,7 @@ ;;; Code: -(eval-when-compile - (require 'cl) - (require 'mm-util)) +(eval-when-compile (require 'mm-util)) (require 'mm-encode) (require 'mml-sec) @@ -277,6 +275,8 @@ Whether the passphrase is cached at all is controlled by (mm-decode-content-transfer-encoding cte))) (let* ((pair (mml-secure-epg-sign 'OpenPGP 'clear)) (signature (car pair))) + (unless (stringp signature) + (error "Signature failed")) (delete-region (point-min) (point-max)) (insert (with-temp-buffer diff --git a/lisp/gnus/mml2015.el b/lisp/gnus/mml2015.el index b220a960983..403b5e1af6a 100644 --- a/lisp/gnus/mml2015.el +++ b/lisp/gnus/mml2015.el @@ -27,7 +27,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'mm-decode) (require 'mm-util) (require 'mml) @@ -237,7 +237,7 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." (setq result (concat result - (case n-slice + (cl-case n-slice (1 slice) (otherwise (concat " " slice)))))) result)) @@ -958,6 +958,8 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." (let* ((pair (mml-secure-epg-sign 'OpenPGP t)) (signature (car pair)) (micalg (cdr pair))) + (unless (stringp signature) + (error "Signature failed")) (goto-char (point-min)) (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n" boundary)) diff --git a/lisp/gnus/nnagent.el b/lisp/gnus/nnagent.el index 44b010c29b6..1b2b13ebe4d 100644 --- a/lisp/gnus/nnagent.el +++ b/lisp/gnus/nnagent.el @@ -26,7 +26,6 @@ (require 'nnheader) (require 'nnoo) -(eval-when-compile (require 'cl)) (require 'gnus-agent) (require 'nnml) diff --git a/lisp/gnus/nnbabyl.el b/lisp/gnus/nnbabyl.el index faa797aae45..9f80a755713 100644 --- a/lisp/gnus/nnbabyl.el +++ b/lisp/gnus/nnbabyl.el @@ -35,7 +35,7 @@ 5 "Ignore rmail errors from this file, you don't have rmail"))) (require 'nnmail) (require 'nnoo) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (nnoo-declare nnbabyl) @@ -103,7 +103,7 @@ (insert ".\n")) (and (numberp nnmail-large-newsgroup) (> number nnmail-large-newsgroup) - (zerop (% (incf count) 20)) + (zerop (% (cl-incf count) 20)) (nnheader-message 5 "nnbabyl: Receiving headers... %d%%" (floor (* count 100.0) number)))) diff --git a/lisp/gnus/nndiary.el b/lisp/gnus/nndiary.el index 2d3d3d16a84..0b300c1a16f 100644 --- a/lisp/gnus/nndiary.el +++ b/lisp/gnus/nndiary.el @@ -83,7 +83,6 @@ (require 'nnoo) (require 'nnheader) (require 'nnmail) -(eval-when-compile (require 'cl)) (require 'gnus-start) (require 'gnus-sum) @@ -233,7 +232,7 @@ through all nnml directories and generate nov databases for them all. This may very well take some time.") (defvoo nndiary-prepare-save-mail-hook nil - "*Hook run narrowed to an article before saving.") + "Hook run narrowed to an article before saving.") (defvoo nndiary-inhibit-expiry nil "If non-nil, inhibit expiry.") @@ -1532,7 +1531,7 @@ all. This may very well take some time.") ;; past. A permanent schedule never expires. (and sched (setq sched (nndiary-last-occurrence sched)) - (time-less-p sched (current-time)))) + (time-less-p sched nil))) ;; else (nnheader-report 'nndiary "Could not read file %s" file) nil) diff --git a/lisp/gnus/nndir.el b/lisp/gnus/nndir.el index 28c903cb913..6dc6c338082 100644 --- a/lisp/gnus/nndir.el +++ b/lisp/gnus/nndir.el @@ -28,7 +28,6 @@ (require 'nnmh) (require 'nnml) (require 'nnoo) -(eval-when-compile (require 'cl)) (nnoo-declare nndir nnml nnmh) @@ -38,7 +37,7 @@ nnml-current-directory nnmh-current-directory) (defvoo nndir-nov-is-evil nil - "*Non-nil means that nndir will never retrieve NOV headers." + "Non-nil means that nndir will never retrieve NOV headers." nnml-nov-is-evil) diff --git a/lisp/gnus/nndoc.el b/lisp/gnus/nndoc.el index 53864d1bc1b..149406a9a21 100644 --- a/lisp/gnus/nndoc.el +++ b/lisp/gnus/nndoc.el @@ -33,19 +33,19 @@ (require 'nnoo) (require 'gnus-util) (require 'mm-util) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (nnoo-declare nndoc) (defvoo nndoc-article-type 'guess - "*Type of the file. + "Type of the file. One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward', `rfc934', `rfc822-forward', `mime-parts', `standard-digest', `slack-digest', `clari-briefs', `nsmail', `outlook', `oe-dbx', `mailman', `exim-bounce', or `guess'.") (defvoo nndoc-post-type 'mail - "*Whether the nndoc group is `mail' or `post'.") + "Whether the nndoc group is `mail' or `post'.") (defvoo nndoc-open-document-hook 'nnheader-ms-strip-cr "Hook run after opening a document. @@ -765,7 +765,7 @@ from the document.") (looking-at "JMF")) (defun nndoc-oe-dbx-type-p () - (looking-at (string-to-multibyte "\317\255\022\376"))) + (looking-at "\317\255\022\376")) (defun nndoc-read-little-endian () (+ (prog1 (char-after) (forward-char 1)) @@ -788,7 +788,7 @@ from the document.") (setq blk (nndoc-oe-dbx-decode-block))) (while (and blk (> (car blk) 0) (or (zerop (nth 3 blk)) (> (nth 3 blk) p))) - (push (list (incf i) p nil nil nil 0) nndoc-dissection-alist) + (push (list (cl-incf i) p nil nil nil 0) nndoc-dissection-alist) (while (and (> (car blk) 0) (> (nth 3 blk) p)) (goto-char (1+ (nth 3 blk))) (setq blk (nndoc-oe-dbx-decode-block))) @@ -927,7 +927,7 @@ from the document.") (and (re-search-backward nndoc-file-end nil t) (beginning-of-line))))) (setq body-end (point)) - (push (list (incf i) head-begin head-end body-begin body-end + (push (list (cl-incf i) head-begin head-end body-begin body-end (count-lines body-begin body-end)) nndoc-dissection-alist))))) (setq nndoc-dissection-alist (nreverse nndoc-dissection-alist)))) @@ -1040,7 +1040,7 @@ PARENT is the message-ID of the parent summary line, or nil for none." (replace-match line t t summary-insert) (concat summary-insert line))))) ;; Generate dissection information for this entity. - (push (list (incf nndoc-mime-split-ordinal) + (push (list (cl-incf nndoc-mime-split-ordinal) head-begin head-end body-begin body-end (count-lines body-begin body-end) article-insert summary-insert) @@ -1078,7 +1078,7 @@ PARENT is the message-ID of the parent summary line, or nil for none." part-begin part-end article-insert (concat position (and position ".") - (format "%d" (incf part-counter))) + (format "%d" (cl-incf part-counter))) message-id))))))))) ;;;###autoload diff --git a/lisp/gnus/nndraft.el b/lisp/gnus/nndraft.el index e984bcb382a..cee7c92b3f1 100644 --- a/lisp/gnus/nndraft.el +++ b/lisp/gnus/nndraft.el @@ -31,7 +31,6 @@ (require 'nnmh) (require 'nnoo) (require 'mm-util) -(eval-when-compile (require 'cl)) ;; The nnoo-import at the end, I think. (declare-function nndraft-request-list "nndraft" (&rest args) t) diff --git a/lisp/gnus/nneething.el b/lisp/gnus/nneething.el index 9b6a92f10e7..abd17c55086 100644 --- a/lisp/gnus/nneething.el +++ b/lisp/gnus/nneething.el @@ -25,7 +25,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'mailcap) (require 'nnheader) @@ -101,7 +101,7 @@ included.") (nneething-insert-head file) (insert ".\n")) - (incf count) + (cl-incf count) (and large (zerop (% count 20)) diff --git a/lisp/gnus/nnfolder.el b/lisp/gnus/nnfolder.el index 565c9856051..826fd8d8552 100644 --- a/lisp/gnus/nnfolder.el +++ b/lisp/gnus/nnfolder.el @@ -32,7 +32,6 @@ (require 'message) (require 'nnmail) (require 'nnoo) -(eval-when-compile (require 'cl)) (require 'gnus) (require 'gnus-util) (require 'gnus-range) diff --git a/lisp/gnus/nngateway.el b/lisp/gnus/nngateway.el index b05c4e88073..8b7898c1893 100644 --- a/lisp/gnus/nngateway.el +++ b/lisp/gnus/nngateway.el @@ -24,7 +24,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (require 'nnoo) (require 'message) diff --git a/lisp/gnus/nnheader.el b/lisp/gnus/nnheader.el index 77afb09a2a8..b9ce20413fb 100644 --- a/lisp/gnus/nnheader.el +++ b/lisp/gnus/nnheader.el @@ -26,7 +26,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defvar nnmail-extra-headers) (defvar gnus-newsgroup-name) @@ -237,7 +237,7 @@ on your system, you could say something like: (format "fake+none+%s+%d" gnus-newsgroup-name number) (format "fake+none+%s+%s" gnus-newsgroup-name - (int-to-string (incf nnheader-fake-message-id))))) + (int-to-string (cl-incf nnheader-fake-message-id))))) (defsubst nnheader-fake-message-id-p (id) (save-match-data ; regular message-id's are <.*> @@ -612,7 +612,7 @@ the line could be found." (while (and (eq nnheader-head-chop-length (nth 1 (mm-insert-file-contents file nil beg - (incf beg nnheader-head-chop-length)))) + (cl-incf beg nnheader-head-chop-length)))) ;; CRLF or CR might be used for the line-break code. (prog1 (not (re-search-forward "\n\r?\n\\|\r\r" nil t)) (goto-char (point-max))) @@ -784,7 +784,7 @@ If FULL, translate everything." (when (setq trans (cdr (assq (aref leaf i) nnheader-file-name-translation-alist))) (aset leaf i trans)) - (incf i)) + (cl-incf i)) (concat path leaf)))) (defun nnheader-report (backend &rest args) @@ -973,7 +973,7 @@ find-file-hook, etc. (defun nnheader-find-file-noselect (&rest args) "Open a file with some variables bound. See `find-file-noselect' for the arguments." - (letf* ((format-alist nil) + (cl-letf* ((format-alist nil) (auto-mode-alist (mm-auto-mode-alist)) ((default-value 'major-mode) 'fundamental-mode) (enable-local-variables nil) @@ -1071,14 +1071,11 @@ See `find-file-noselect' for the arguments." (defmacro nnheader-insert-buffer-substring (buffer &optional start end) "Copy string from unibyte buffer to multibyte current buffer." - `(if enable-multibyte-characters - (insert (with-current-buffer ,buffer - (string-to-multibyte - ,(if (or start end) - `(buffer-substring (or ,start (point-min)) - (or ,end (point-max))) - '(buffer-string))))) - (insert-buffer-substring ,buffer ,start ,end))) + `(insert (with-current-buffer ,buffer + ,(if (or start end) + `(buffer-substring (or ,start (point-min)) + (or ,end (point-max))) + '(buffer-string))))) (defvar nnheader-last-message-time '(0 0)) (defun nnheader-message-maybe (&rest args) diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index cab1513a164..dc51b5f0f0c 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -27,7 +27,7 @@ ;;; Code: (eval-when-compile - (require 'cl) + (require 'cl-lib) (require 'subr-x)) (require 'nnheader) @@ -144,7 +144,7 @@ textual parts.") (defvar nnimap-keepalive-timer nil) (defvar nnimap-process-buffers nil) -(defstruct nnimap +(cl-defstruct nnimap group process commands capabilities select-result newlinep server last-command-time greeting examined stream-type initial-resync) @@ -212,23 +212,24 @@ textual parts.") (defun nnimap-transform-headers () (goto-char (point-min)) (let (article lines size string labels) - (block nil + (cl-block nil (while (not (eobp)) (while (not (looking-at "\\* [0-9]+ FETCH")) (delete-region (point) (progn (forward-line 1) (point))) (when (eobp) - (return))) + (cl-return))) (goto-char (match-end 0)) ;; Unfold quoted {number} strings. - (while (re-search-forward - "[^]][ (]{\\([0-9]+\\)}\r?\n" - (save-excursion - ;; Start of the header section. - (or (re-search-forward "] {[0-9]+}\r?\n" nil t) - ;; Start of the next FETCH. - (re-search-forward "\\* [0-9]+ FETCH" nil t) - (point-max))) - t) + (while (or (looking-at "[ (]{\\([0-9]+\\)}\r?\n") + (re-search-forward + "[^]][ (]{\\([0-9]+\\)}\r?\n" + (save-excursion + ;; Start of the header section. + (or (re-search-forward "] {[0-9]+}\r?\n" nil t) + ;; Start of the next FETCH. + (re-search-forward "\\* [0-9]+ FETCH" nil t) + (point-max))) + t)) (setq size (string-to-number (match-string 1))) (delete-region (+ (match-beginning 0) 2) (point)) (setq string (buffer-substring (point) (+ (point) size))) @@ -381,7 +382,7 @@ textual parts.") (setq nnimap-stream 'ssl)) (let ((stream (if (eq nnimap-stream 'undecided) - (loop for type in '(ssl network) + (cl-loop for type in '(ssl network) for stream = (let ((nnimap-stream type)) (nnimap-open-connection-1 buffer)) while (eq stream 'no-connect) @@ -522,6 +523,7 @@ textual parts.") ((and (not (nnimap-capability "LOGINDISABLED")) (eq (nnimap-stream-type nnimap-object) 'tls) (or (null nnimap-authenticator) + (eq nnimap-authenticator 'anonymous) (eq nnimap-authenticator 'login))) (nnimap-command "LOGIN %S %S" user password)) ((and (nnimap-capability "AUTH=CRAM-MD5") @@ -541,6 +543,7 @@ textual parts.") (nnimap-wait-for-response sequence))) ((and (not (nnimap-capability "LOGINDISABLED")) (or (null nnimap-authenticator) + (eq nnimap-authenticator 'anonymous) (eq nnimap-authenticator 'login))) (nnimap-command "LOGIN %S %S" user password)) ((and (nnimap-capability "AUTH=PLAIN") @@ -794,7 +797,7 @@ textual parts.") (equal id "1") (string-match nnimap-fetch-partial-articles type)) (push id parts)))) - (incf num))) + (cl-incf num))) (nreverse parts))) (deffoo nnimap-request-group (group &optional server dont-check info) @@ -1145,7 +1148,7 @@ If LIMIT, first try to limit the search to the N last articles." ;; Just send all the STORE commands without waiting for ;; response. If they're successful, they're successful. (dolist (action actions) - (destructuring-bind (range action marks) action + (cl-destructuring-bind (range action marks) action (let ((flags (nnimap-marks-to-flags marks))) (when flags (setq sequence (nnimap-send-command @@ -1408,7 +1411,7 @@ If LIMIT, first try to limit the search to the N last articles." (if (and active uidvalidity unexist) ;; Fetch the last 100 flags. (setq start (max 1 (- (cdr active) 100))) - (incf (nnimap-initial-resync nnimap-object)) + (cl-incf (nnimap-initial-resync nnimap-object)) (setq start 1)) (push (list (nnimap-send-command "%s %S" command (utf7-encode group t)) @@ -1472,7 +1475,7 @@ If LIMIT, first try to limit the search to the N last articles." (nnimap-update-info info marks))))) (defun nnimap-update-info (info marks) - (destructuring-bind (existing flags high low uidnext start-article + (cl-destructuring-bind (existing flags high low uidnext start-article permanent-flags uidvalidity vanished highestmodseq) marks (cond @@ -1544,6 +1547,8 @@ If LIMIT, first try to limit the search to the N last articles." info existing (nnimap-imap-ranges-to-gnus-ranges vanished) flags) ;; Do normal non-QRESYNC flag updates. ;; Update the list of read articles. + (unless start-article + (setq start-article 1)) (let* ((unread (gnus-compress-sequence (gnus-set-difference @@ -1725,7 +1730,7 @@ If LIMIT, first try to limit the search to the N last articles." (let (start end articles groups uidnext elems permanent-flags uidvalidity vanished highestmodseq) (dolist (elem sequences) - (destructuring-bind (group-sequence flag-sequence totalp group command) + (cl-destructuring-bind (group-sequence flag-sequence totalp group command) elem (setq start (point)) (when (and @@ -1861,7 +1866,9 @@ Return the server's response to the SELECT or EXAMINE command." (setq nnimap-connection-alist (delq entry nnimap-connection-alist)) nil)))) -(defvar nnimap-sequence 0) +;; Leave room for `open-network-stream' to issue a couple of IMAP +;; commands before nnimap starts. +(defvar nnimap-sequence 5) (defun nnimap-send-command (&rest args) (setf (nnimap-last-command-time nnimap-object) (current-time)) @@ -1869,7 +1876,7 @@ Return the server's response to the SELECT or EXAMINE command." (get-buffer-process (current-buffer)) (nnimap-log-command (format "%d %s%s\n" - (incf nnimap-sequence) + (cl-incf nnimap-sequence) (apply #'format args) (if (nnimap-newlinep nnimap-object) "" @@ -2166,7 +2173,7 @@ Return the server's response to the SELECT or EXAMINE command." (let ((specs nil) entry) (dolist (elem list) - (destructuring-bind (article spec) elem + (cl-destructuring-bind (article spec) elem (dolist (group (delete nil (mapcar #'car spec))) (unless (setq entry (assoc group specs)) (push (setq entry (list group)) specs)) @@ -2178,12 +2185,12 @@ Return the server's response to the SELECT or EXAMINE command." (defun nnimap-transform-split-mail () (goto-char (point-min)) (let (article bytes) - (block nil + (cl-block nil (while (not (eobp)) (while (not (looking-at "\\* [0-9]+ FETCH.+UID \\([0-9]+\\)")) (delete-region (point) (progn (forward-line 1) (point))) (when (eobp) - (return))) + (cl-return))) (setq article (match-string 1) bytes (nnimap-get-length)) (delete-region (line-beginning-position) (line-end-position)) diff --git a/lisp/gnus/nnir.el b/lisp/gnus/nnir.el index 55e00a0b69f..7e5f56e4dd0 100644 --- a/lisp/gnus/nnir.el +++ b/lisp/gnus/nnir.el @@ -30,7 +30,7 @@ ;;; Commentary: ;; What does it do? Well, it allows you to search your mail using -;; some search engine (imap, namazu, swish-e, gmane and others -- see +;; some search engine (imap, namazu, swish-e and others -- see ;; later) by typing `G G' in the Group buffer. You will then get a ;; buffer which shows all articles matching the query, sorted by ;; Retrieval Status Value (score). @@ -530,8 +530,6 @@ that it is for notmuch, not Namazu." nnir-imap-search-argument-history ; the history to use ,nnir-imap-default-search-key ; default ))) - (gmane nnir-run-gmane - ((gmane-author . "Gmane Author: "))) (swish++ nnir-run-swish++ ((swish++-group . "Swish++ Group spec (regexp): "))) (swish-e nnir-run-swish-e @@ -561,7 +559,7 @@ needs the variables `nnir-namazu-program', Add an entry here when adding a new search engine.") -(defcustom nnir-method-default-engines '((nnimap . imap) (nntp . gmane)) +(defcustom nnir-method-default-engines '((nnimap . imap)) "Alist of default search engines keyed by server method." :version "24.1" :group 'nnir @@ -644,7 +642,7 @@ skips all prompting." (add-hook 'gnus-summary-mode-hook 'nnir-mode) (nnoo-change-server 'nnir server definitions)))) -(deffoo nnir-request-group (group &optional server dont-check info) +(deffoo nnir-request-group (group &optional server dont-check _info) (nnir-possibly-change-group group server) (let ((pgroup (gnus-group-guess-full-name-from-command-method group)) length) @@ -669,7 +667,9 @@ skips all prompting." group)))) ; group name nnir-artlist) -(deffoo nnir-retrieve-headers (articles &optional group server fetch-old) +(defvar gnus-inhibit-demon) + +(deffoo nnir-retrieve-headers (articles &optional _group _server _fetch-old) (with-current-buffer nntp-server-buffer (let ((gnus-inhibit-demon t) (articles-by-group (nnir-categorize @@ -716,6 +716,8 @@ skips all prompting." (mapc 'nnheader-insert-nov headers) 'nov))) +(defvar gnus-article-decode-hook) + (deffoo nnir-request-article (article &optional group server to-buffer) (nnir-possibly-change-group group server) (if (and (stringp article) @@ -753,7 +755,7 @@ skips all prompting." (cons artfullgroup artno))))))) (deffoo nnir-request-move-article (article group server accept-form - &optional last internal-move-group) + &optional last _internal-move-group) (nnir-possibly-change-group group server) (let* ((artfullgroup (nnir-article-group article)) (artno (nnir-article-number article)) @@ -803,7 +805,8 @@ skips all prompting." (error "Can't warp to a pseudo-article"))) (backend-article-group (nnir-article-group cur)) (backend-article-number (nnir-article-number cur)) - (quit-config (gnus-ephemeral-group-p gnus-newsgroup-name))) +; (quit-config (gnus-ephemeral-group-p gnus-newsgroup-name)) + ) ;; what should we do here? we could leave all the buffers around ;; and assume that we have to exit from them one by one. or we can @@ -818,7 +821,7 @@ skips all prompting." (gnus-summary-read-group-1 backend-article-group t t nil nil (list backend-article-number)))) -(deffoo nnir-request-update-mark (group article mark) +(deffoo nnir-request-update-mark (_group article mark) (let ((artgroup (nnir-article-group article)) (artnumber (nnir-article-number article))) (or (and artgroup @@ -956,7 +959,7 @@ details on the language and supported extensions." (save-excursion (let ((qstring (cdr (assq 'query query))) (server (cadr (gnus-server-to-method srv))) - (defs (nth 2 (gnus-server-to-method srv))) +;; (defs (nth 2 (gnus-server-to-method srv))) (criteria (or (cdr (assq 'criteria query)) (cdr (assoc nnir-imap-default-search-key nnir-imap-search-arguments)))) @@ -1177,7 +1180,7 @@ returning the one at the supplied position." ;; - article number ;; - file size ;; - group -(defun nnir-run-swish++ (query server &optional group) +(defun nnir-run-swish++ (query server &optional _group) "Run QUERY against swish++. Returns a vector of (group name, file name) pairs (also vectors, actually). @@ -1267,7 +1270,7 @@ Windows NT 4.0." (nnir-artitem-rsv y))))))))) ;; Swish-E interface. -(defun nnir-run-swish-e (query server &optional group) +(defun nnir-run-swish-e (query server &optional _group) "Run given query against swish-e. Returns a vector of (group name, file name) pairs (also vectors, actually). @@ -1433,7 +1436,7 @@ Tested with swish-e-2.0.1 on Windows NT 4.0." ))) ;; Namazu interface -(defun nnir-run-namazu (query server &optional group) +(defun nnir-run-namazu (query server &optional _group) "Run given query against Namazu. Returns a vector of (group name, file name) pairs (also vectors, actually). @@ -1502,7 +1505,7 @@ Tested with Namazu 2.0.6 on a GNU/Linux system." (> (nnir-artitem-rsv x) (nnir-artitem-rsv y))))))))) -(defun nnir-run-notmuch (query server &optional group) +(defun nnir-run-notmuch (query server &optional _group) "Run QUERY against notmuch. Returns a vector of (group name, file name) pairs (also vectors, actually)." @@ -1662,54 +1665,6 @@ actually)." (declare-function mm-url-insert "mm-url" (url &optional follow-refresh)) (declare-function mm-url-encode-www-form-urlencoded "mm-url" (pairs)) -;; gmane interface -(defun nnir-run-gmane (query srv &optional groups) - "Run a search against a gmane back-end server." - (let* ((case-fold-search t) - (qstring (cdr (assq 'query query))) - (server (cadr (gnus-server-to-method srv))) - (groupspec (mapconcat - (lambda (x) - (if (string-match-p "gmane" x) - (format "group:%s" (gnus-group-short-name x)) - (error "Can't search non-gmane groups: %s" x))) - groups " ")) - (authorspec - (if (assq 'gmane-author query) - (format "author:%s" (cdr (assq 'gmane-author query))) "")) - (search (format "%s %s %s" - qstring groupspec authorspec)) - (gnus-inhibit-demon t) - artlist) - (require 'mm-url) - (with-current-buffer (get-buffer-create nnir-tmp-buffer) - (erase-buffer) - (mm-url-insert - (concat - "http://search.gmane.org/nov.php" - "?" - (mm-url-encode-www-form-urlencoded - `(("query" . ,search) - ("HITSPERPAGE" . "999"))))) - (set-buffer-multibyte t) - (decode-coding-region (point-min) (point-max) 'utf-8) - (goto-char (point-min)) - (forward-line 1) - (while (not (eobp)) - (unless (or (eolp) (looking-at "\x0d")) - (let ((header (nnheader-parse-nov))) - (let ((xref (mail-header-xref header)) - (xscore (string-to-number (cdr (assoc 'X-Score - (mail-header-extra header)))))) - (when (string-match " \\([^:]+\\)[:/]\\([0-9]+\\)" xref) - (push - (vector - (gnus-group-prefixed-name (match-string 1 xref) srv) - (string-to-number (match-string 2 xref)) xscore) - artlist))))) - (forward-line 1))) - (apply #'vector (nreverse (delete-dups artlist))))) - ;;; Util Code: (defun gnus-nnir-group-p (group) @@ -1809,8 +1764,7 @@ article came from is also searched." groups) (gnus-request-list method) (with-current-buffer nntp-server-buffer - (let ((cur (current-buffer)) - name) + (let ((cur (current-buffer))) (goto-char (point-min)) (unless (or (null nnir-ignored-newsgroups) (string= nnir-ignored-newsgroups "")) @@ -1818,31 +1772,29 @@ article came from is also searched." (if (eq (car method) 'nntp) (while (not (eobp)) (ignore-errors - (push (string-as-unibyte - (gnus-group-full-name - (buffer-substring - (point) - (progn - (skip-chars-forward "^ \t") - (point))) - method)) + (push (gnus-group-full-name + (buffer-substring + (point) + (progn + (skip-chars-forward "^ \t") + (point))) + method) groups)) (forward-line)) (while (not (eobp)) (ignore-errors - (push (string-as-unibyte - (if (eq (char-after) ?\") - (gnus-group-full-name (read cur) method) - (let ((p (point)) (name "")) - (skip-chars-forward "^ \t\\\\") - (setq name (buffer-substring p (point))) - (while (eq (char-after) ?\\) - (setq p (1+ (point))) - (forward-char 2) - (skip-chars-forward "^ \t\\\\") - (setq name (concat name (buffer-substring - p (point))))) - (gnus-group-full-name name method)))) + (push (if (eq (char-after) ?\") + (gnus-group-full-name (read cur) method) + (let ((p (point)) (name "")) + (skip-chars-forward "^ \t\\\\") + (setq name (buffer-substring p (point))) + (while (eq (char-after) ?\\) + (setq p (1+ (point))) + (forward-char 2) + (skip-chars-forward "^ \t\\\\") + (setq name (concat name (buffer-substring + p (point))))) + (gnus-group-full-name name method))) groups)) (forward-line))))) groups)) @@ -1851,7 +1803,7 @@ article came from is also searched." (declare-function gnus-registry-action "gnus-registry" (action data-header from &optional to method)) -(defun nnir-registry-action (action data-header from &optional to method) +(defun nnir-registry-action (action data-header _from &optional to method) "Call `gnus-registry-action' with the original article group." (gnus-registry-action action @@ -1886,7 +1838,7 @@ article came from is also searched." (gnus-group-find-parameter pgroup))))) -(deffoo nnir-request-create-group (group &optional server args) +(deffoo nnir-request-create-group (group &optional _server args) (message "Creating nnir group %s" group) (let* ((group (gnus-group-prefixed-name group '(nnir "nnir"))) (specs (assq 'nnir-specs args)) @@ -1907,13 +1859,13 @@ article came from is also searched." (nnir-request-update-info group (gnus-get-info group))) t) -(deffoo nnir-request-delete-group (group &optional force server) +(deffoo nnir-request-delete-group (_group &optional _force _server) t) -(deffoo nnir-request-list (&optional server) +(deffoo nnir-request-list (&optional _server) t) -(deffoo nnir-request-scan (group method) +(deffoo nnir-request-scan (_group _method) t) (deffoo nnir-request-close () diff --git a/lisp/gnus/nnmail.el b/lisp/gnus/nnmail.el index 88156d1af82..08db5ab5b69 100644 --- a/lisp/gnus/nnmail.el +++ b/lisp/gnus/nnmail.el @@ -24,7 +24,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gnus) ; for macro gnus-kill-buffer, at least (require 'nnheader) @@ -488,7 +488,8 @@ Example: (to . "to\\|cc\\|apparently-to\\|resent-to\\|resent-cc") (from . "from\\|sender\\|resent-from") (nato . "to\\|cc\\|resent-to\\|resent-cc") - (naany . "from\\|to\\|cc\\|sender\\|resent-from\\|resent-to\\|resent-cc")) + (naany . "from\\|to\\|cc\\|sender\\|resent-from\\|resent-to\\|resent-cc") + (list . "list-id\\|list-post\\|x-mailing-list\||x-beenthere\\|x-loop")) "Alist of abbreviations allowed in `nnmail-split-fancy'." :group 'nnmail-split :type '(repeat (cons :format "%v" symbol regexp))) @@ -665,7 +666,7 @@ nn*-request-list should have been called before calling this function." (setq group (symbol-name group))) (if (and (numberp (setq max (read buffer))) (numberp (setq min (read buffer)))) - (push (list (string-as-unibyte group) (cons min max)) + (push (list group (cons min max)) group-assoc))) (error nil)) (widen) @@ -723,7 +724,7 @@ If SOURCE is a directory spec, try to return the group name component." ;; Skip all the headers in case there are more "From "s... (or (search-forward "\n\n" nil t) (search-forward-regexp "^[^:]*\\( .*\\|\\)$" nil t) - (search-forward " ")) + (search-forward "\^_\^L")) (point))) ;; Unquote the ">From " line, if any. (goto-char (point-min)) @@ -763,7 +764,7 @@ If SOURCE is a directory spec, try to return the group name component." (if (or (= (+ (point) content-length) (point-max)) (save-excursion (goto-char (+ (point) content-length)) - (looking-at " "))) + (looking-at "\^_"))) (progn (goto-char (+ (point) content-length)) (setq do-search nil)) @@ -772,7 +773,7 @@ If SOURCE is a directory spec, try to return the group name component." ;; Go to the beginning of the next article - or to the end ;; of the buffer. (when do-search - (if (re-search-forward "^ " nil t) + (if (re-search-forward "^\^_" nil t) (goto-char (match-beginning 0)) (goto-char (1- (point-max))))) (delete-char 1) ; delete ^_ @@ -781,7 +782,7 @@ If SOURCE is a directory spec, try to return the group name component." (narrow-to-region start (point)) (goto-char (point-min)) (nnmail-check-duplication message-id func artnum-func) - (incf count) + (cl-incf count) (setq end (point-max)))) (goto-char end)) count)) @@ -927,7 +928,7 @@ If SOURCE is a directory spec, try to return the group name component." (save-restriction (narrow-to-region start (point)) (goto-char (point-min)) - (incf count) + (cl-incf count) (nnmail-check-duplication message-id func artnum-func) (setq end (point-max)))) (goto-char end))) @@ -980,7 +981,7 @@ If SOURCE is a directory spec, try to return the group name component." (save-restriction (narrow-to-region start (point)) (goto-char (point-min)) - (incf count) + (cl-incf count) (nnmail-check-duplication message-id func artnum-func junk-func) (setq end (point-max)))) (goto-char end) @@ -1248,11 +1249,11 @@ Return the number of characters in the body." (progn (forward-line 1) (point)))) (insert (format "Xref: %s" (system-name))) (while group-alist - (insert (if (mm-multibyte-p) - (string-as-multibyte - (format " %s:%d" (caar group-alist) (cdar group-alist))) - (string-as-unibyte - (format " %s:%d" (caar group-alist) (cdar group-alist))))) + (insert (if enable-multibyte-characters + (format " %s:%d" (caar group-alist) (cdar group-alist)) + (encode-coding-string + (format " %s:%d" (caar group-alist) (cdar group-alist)) + 'utf-8))) (setq group-alist (cdr group-alist))) (insert "\n"))) @@ -1836,8 +1837,8 @@ be called once per group or once for all groups." ((error quit) (message "Mail source %s failed: %s" source cond) 0))) - (incf total new) - (incf i))) + (cl-incf total new) + (cl-incf i))) ;; If we did indeed read any incoming spools, we save all info. (if (zerop total) (when mail-source-plugged @@ -1883,7 +1884,7 @@ If TIME is nil, then return the cutoff time for oldness instead." (setq days (days-to-time days)) ;; Compare the time with the current time. (if (null time) - (time-subtract (current-time) days) + (time-subtract nil days) (ignore-errors (time-less-p days (time-since time))))))))) (declare-function gnus-group-mark-article-read "gnus-group" (group article)) @@ -1899,7 +1900,7 @@ If TIME is nil, then return the cutoff time for oldness instead." (unless (eq target 'delete) (when (or (gnus-request-group target nil nil (gnus-get-info target)) (gnus-request-create-group target)) - (let ((group-art (gnus-request-accept-article target nil nil t))) + (let ((group-art (gnus-request-accept-article target nil t t))) (when (and (consp group-art) (cdr group-art)) (gnus-group-mark-article-read target (cdr group-art)))))))) @@ -2034,7 +2035,7 @@ If TIME is nil, then return the cutoff time for oldness instead." "Remove all instances of GROUP from `nnmail-split-history'." (let ((history nnmail-split-history)) (while history - (setcar history (gnus-remove-if (lambda (e) (string= (car e) group)) + (setcar history (seq-remove (lambda (e) (string= (car e) group)) (car history))) (pop history)) (setq nnmail-split-history (delq nil nnmail-split-history)))) diff --git a/lisp/gnus/nnmaildir.el b/lisp/gnus/nnmaildir.el index 272240f5a9f..d5cfa27c21a 100644 --- a/lisp/gnus/nnmaildir.el +++ b/lisp/gnus/nnmaildir.el @@ -68,8 +68,7 @@ (require 'message) (require 'nnmail) -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defconst nnmaildir-version "Gnus") @@ -165,14 +164,14 @@ This variable is set by `nnmaildir-request-article'.") (defmacro nnmaildir--nov-set-mtime (nov value) `(aset ,nov 3 ,value)) (defmacro nnmaildir--nov-set-extra (nov value) `(aset ,nov 4 ,value)) -(defstruct nnmaildir--art +(cl-defstruct nnmaildir--art (prefix nil :type string) ;; "time.pid.host" (suffix nil :type string) ;; ":2,flags" (num nil :type natnum) ;; article number (msgid nil :type string) ;; "<mess.age@id>" (nov nil :type vector)) ;; cached nov structure, or nil -(defstruct nnmaildir--grp +(cl-defstruct nnmaildir--grp (name nil :type string) ;; "group.name" (new nil :type list) ;; new/ modtime (cur nil :type list) ;; cur/ modtime @@ -186,7 +185,7 @@ This variable is set by `nnmaildir-request-article'.") (mmth nil :type vector)) ;; obarray mapping mark name->dir modtime ; ("Mark Mod Time Hash") -(defstruct nnmaildir--srv +(cl-defstruct nnmaildir--srv (address nil :type string) ;; server address string (method nil :type list) ;; (nnmaildir "address" ...) (prefix nil :type string) ;; "nnmaildir+address:" @@ -814,7 +813,7 @@ This variable is set by `nnmaildir-request-article'.") (when (or isnew nattr) (dolist (file (funcall ls ndir nil "\\`[^.]" 'nosort)) (setq x (concat ndir file)) - (and (time-less-p (nth 5 (file-attributes x)) (current-time)) + (and (time-less-p (nth 5 (file-attributes x)) nil) (rename-file x (concat cdir (nnmaildir--ensure-suffix file))))) (setf (nnmaildir--grp-new group) nattr)) (setq cattr (nth 5 (file-attributes cdir))) @@ -856,7 +855,7 @@ This variable is set by `nnmaildir-request-article'.") ;; then look in marks directories (not (file-exists-p (concat cdir prefix))) (file-exists-p (concat ndir prefix))) - (incf num))))) + (cl-incf num))))) (setf (nnmaildir--grp-cache group) (make-vector num nil)) (let ((inhibit-quit t)) (set (intern gname groups) group)) @@ -915,7 +914,7 @@ This variable is set by `nnmaildir-request-article'.") (setq dirs (funcall srv-ls srv-dir nil "\\`[^.]" 'nosort) dirs (if (zerop (length target-prefix)) dirs - (gnus-remove-if + (seq-remove (lambda (dir) (and (>= (length dir) (length target-prefix)) (string= (substring dir 0 @@ -1732,7 +1731,7 @@ This variable is set by `nnmaildir-request-article'.") (setq ranges (car action) todo-marks (caddr action)) (dolist (mark todo-marks) - (pushnew mark all-marks :test #'equal)) + (cl-pushnew mark all-marks :test #'equal)) (if (numberp (cdr ranges)) (setq ranges (list ranges))) (nnmaildir--nlist-iterate nlist ranges (cond ((eq 'del (cadr action)) del-action) @@ -1779,14 +1778,11 @@ This variable is set by `nnmaildir-request-article'.") t))) (defun nnmaildir-close-server (&optional server) - (defvar flist) (defvar ls) (defvar dirs) (defvar dir) - (defvar files) (defvar file) (defvar x) - (let (flist ls dirs dir files file x) - (nnmaildir--prepare server nil) - (when nnmaildir--cur-server - (setq server nnmaildir--cur-server - nnmaildir--cur-server nil) - (unintern (nnmaildir--srv-address server) nnmaildir--servers))) + (nnmaildir--prepare server nil) + (when nnmaildir--cur-server + (setq server nnmaildir--cur-server + nnmaildir--cur-server nil) + (unintern (nnmaildir--srv-address server) nnmaildir--servers)) t) (defun nnmaildir-request-close () diff --git a/lisp/gnus/nnmairix.el b/lisp/gnus/nnmairix.el index 3a0035a3116..24188f5c740 100644 --- a/lisp/gnus/nnmairix.el +++ b/lisp/gnus/nnmairix.el @@ -134,8 +134,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) ;For (pop (cdr ogroup)). - (require 'nnoo) (require 'gnus-group) (require 'gnus-sum) diff --git a/lisp/gnus/nnmbox.el b/lisp/gnus/nnmbox.el index 57d8d2125f5..05342dae001 100644 --- a/lisp/gnus/nnmbox.el +++ b/lisp/gnus/nnmbox.el @@ -33,7 +33,6 @@ (require 'nnmail) (require 'nnoo) (require 'gnus-range) -(eval-when-compile (require 'cl)) (nnoo-declare nnmbox) diff --git a/lisp/gnus/nnmh.el b/lisp/gnus/nnmh.el index b8dd3835520..33be64fb8d2 100644 --- a/lisp/gnus/nnmh.el +++ b/lisp/gnus/nnmh.el @@ -33,7 +33,6 @@ (require 'nnmail) (require 'gnus-start) (require 'nnoo) -(eval-when-compile (require 'cl)) (nnoo-declare nnmh) @@ -242,12 +241,11 @@ as unread by Gnus.") (file-truename (file-name-as-directory (expand-file-name nnmh-toplev)))) dir) - (string-to-multibyte ;Why? Isn't it multibyte already? - (encode-coding-string - (nnheader-replace-chars-in-string - (substring dir (match-end 0)) - ?/ ?.) - nnmail-pathname-coding-system))) + (encode-coding-string + (nnheader-replace-chars-in-string + (substring dir (match-end 0)) + ?/ ?.) + nnmail-pathname-coding-system)) (or max 0) (or min 1)))))) t) diff --git a/lisp/gnus/nnml.el b/lisp/gnus/nnml.el index a1b7d417ab4..6307e132187 100644 --- a/lisp/gnus/nnml.el +++ b/lisp/gnus/nnml.el @@ -35,7 +35,6 @@ (require 'nnheader) (require 'nnmail) (require 'nnoo) -(eval-when-compile (require 'cl)) ;; FIXME first is unused in this file. (autoload 'gnus-article-unpropagatable-p "gnus-sum") diff --git a/lisp/gnus/nnoo.el b/lisp/gnus/nnoo.el index 6a61d3d09f2..1e69af65a3b 100644 --- a/lisp/gnus/nnoo.el +++ b/lisp/gnus/nnoo.el @@ -25,7 +25,7 @@ ;;; Code: (require 'nnheader) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defvar nnoo-definition-alist nil) (defvar nnoo-state-alist nil) @@ -142,7 +142,7 @@ (if (numberp (nth i (cdr m))) (push `(nth ,i args) margs) (push (nth i (cdr m)) margs)) - (incf i)) + (cl-incf i)) (eval `(deffoo ,(nnoo-symbol backend (nnoo-rest-symbol (car m))) (&rest args) (nnoo-parent-function ',backend ',(car m) diff --git a/lisp/gnus/nnrss.el b/lisp/gnus/nnrss.el index 3ab7d0893b9..f80e2c51078 100644 --- a/lisp/gnus/nnrss.el +++ b/lisp/gnus/nnrss.el @@ -24,7 +24,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gnus) (require 'nnoo) @@ -49,7 +49,7 @@ "Where nnrss will save its files.") (defvoo nnrss-ignore-article-fields '(slash:comments) - "*List of fields that should be ignored when comparing RSS articles. + "List of fields that should be ignored when comparing RSS articles. Some RSS feeds update article fields during their lives, e.g. to indicate the number of comments or the number of times the articles have been seen. However, if there is a difference @@ -355,8 +355,8 @@ for decoding when the cdr that the data specify is not available.") (with-current-buffer nntp-server-buffer (erase-buffer) (dolist (elem nnrss-group-alist) - (if (third elem) - (insert (car elem) "\t" (third elem) "\n")))) + (if (nth 2 elem) + (insert (car elem) "\t" (nth 2 elem) "\n")))) t) (deffoo nnrss-retrieve-groups (groups &optional server) @@ -625,7 +625,7 @@ which RSS 2.0 allows." ;;; Snarf functions (defun nnrss-make-hash-index (item) (gnus-message 9 "nnrss: Making hash index of %s" (gnus-prin1-to-string item)) - (setq item (gnus-remove-if + (setq item (seq-remove (lambda (field) (when (listp field) (memq (car field) nnrss-ignore-article-fields))) @@ -645,7 +645,7 @@ which RSS 2.0 allows." nnrss-directory)))) (setq xml (nnrss-fetch file t)) (setq url (or (nth 2 (assoc group nnrss-server-data)) - (second (assoc group nnrss-group-alist)))) + (cadr (assoc group nnrss-group-alist)))) (unless url (setq url (cdr @@ -691,7 +691,7 @@ which RSS 2.0 allows." (if (and len (integerp (setq len (string-to-number len)))) ;; actually already in `ls-lisp-format-file-size' but ;; probably not worth to require it for one function - (do ((size (/ len 1.0) (/ size 1024.0)) + (cl-do ((size (/ len 1.0) (/ size 1024.0)) (post-fixes (list "" "k" "M" "G" "T" "P" "E") (cdr post-fixes))) ((< size 1024) @@ -705,7 +705,7 @@ which RSS 2.0 allows." (setq enclosure (list url name len type)))) (push (list - (incf nnrss-group-max) + (cl-incf nnrss-group-max) (current-time) url (and subject (nnrss-mime-encode-string subject)) @@ -792,7 +792,7 @@ It is useful when `(setq nnrss-use-local t)'." (insert "RSSDIR='" (expand-file-name nnrss-directory) "'\n") (dolist (elem nnrss-server-data) (let ((url (or (nth 2 elem) - (second (assoc (car elem) nnrss-group-alist))))) + (cadr (assoc (car elem) nnrss-group-alist))))) (insert "$WGET -q -O \"$RSSDIR\"/'" (nnrss-translate-file-chars (concat (car elem) ".xml")) "' '" url "'\n")))) diff --git a/lisp/gnus/nnspool.el b/lisp/gnus/nnspool.el index c3fc25047b0..2f16b653924 100644 --- a/lisp/gnus/nnspool.el +++ b/lisp/gnus/nnspool.el @@ -29,17 +29,17 @@ (require 'nnheader) (require 'nntp) (require 'nnoo) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;; Probably this entire thing should be obsolete. ;; It's only used to init nnspool-spool-directory, so why not just ;; set that variable's default directly? (eval-and-compile + (defvaralias 'news-path 'news-directory) (defvar news-directory (if (file-exists-p "/usr/spool/news/") "/usr/spool/news/" "/var/spool/news/") - "The root directory below which all news files are stored.") - (defvaralias 'news-path 'news-directory)) + "The root directory below which all news files are stored.")) ;; Ditto re obsolescence. (defvar news-inews-program @@ -105,7 +105,7 @@ If nil, nnspool will load the entire file into a buffer and process it there.") (defvoo nnspool-rejected-article-hook nil - "*A hook that will be run when an article has been rejected by the server.") + "A hook that will be run when an article has been rejected by the server.") (defvoo nnspool-file-coding-system nnheader-file-coding-system "Coding system for nnspool.") @@ -172,7 +172,7 @@ there.") (delete-region (point) (point-max))) (and do-message - (zerop (% (incf count) 20)) + (zerop (% (cl-incf count) 20)) (nnheader-message 5 "nnspool: Receiving headers... %d%%" (floor (* count 100.0) number)))) diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el index d0d13849370..be9e4955105 100644 --- a/lisp/gnus/nntp.el +++ b/lisp/gnus/nntp.el @@ -33,7 +33,7 @@ (nnoo-declare nntp) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (autoload 'auth-source-search "auth-source") @@ -48,7 +48,7 @@ "Port number on the physical nntp server.") (defvoo nntp-server-opened-hook '(nntp-send-mode-reader) - "*Hook used for sending commands to the server at startup. + "Hook used for sending commands to the server at startup. The default value is `nntp-send-mode-reader', which makes an innd server spawn an nnrpd server.") @@ -94,7 +94,7 @@ For indirect connections: - `nntp-open-via-telnet-and-telnet'") (defvoo nntp-never-echoes-commands nil - "*Non-nil means the nntp server never echoes commands. + "Non-nil means the nntp server never echoes commands. It is reported that some nntps server doesn't echo commands. So, you may want to set this to non-nil in the method for such a server setting `nntp-open-connection-function' to `nntp-open-ssl-stream' for example. @@ -103,102 +103,102 @@ variable overrides the nil value of this variable.") (defvoo nntp-open-connection-functions-never-echo-commands '(nntp-open-network-stream) - "*List of functions that never echo commands. + "List of functions that never echo commands. Add or set a function which you set to `nntp-open-connection-function' to this list if it does not echo commands. Note that a non-nil value of the `nntp-never-echoes-commands' variable overrides this variable.") (defvoo nntp-pre-command nil - "*Pre-command to use with the various nntp-open-via-* methods. + "Pre-command to use with the various nntp-open-via-* methods. This is where you would put \"runsocks\" or stuff like that.") (defvoo nntp-telnet-command "telnet" - "*Telnet command used to connect to the nntp server. + "Telnet command used to connect to the nntp server. This command is used by the methods `nntp-open-telnet-stream', `nntp-open-via-rlogin-and-telnet' and `nntp-open-via-telnet-and-telnet'.") (defvoo nntp-telnet-switches '("-8") - "*Switches given to the telnet command `nntp-telnet-command'.") + "Switches given to the telnet command `nntp-telnet-command'.") (defvoo nntp-end-of-line "\r\n" - "*String to use on the end of lines when talking to the NNTP server. + "String to use on the end of lines when talking to the NNTP server. This is \"\\r\\n\" by default, but should be \"\\n\" when using an indirect connection method (nntp-open-via-*).") (defvoo nntp-via-rlogin-command "rsh" - "*Rlogin command used to connect to an intermediate host. + "Rlogin command used to connect to an intermediate host. This command is used by the methods `nntp-open-via-rlogin-and-telnet' and `nntp-open-via-rlogin-and-netcat'. The default is \"rsh\", but \"ssh\" is a popular alternative.") (defvoo nntp-via-rlogin-command-switches nil - "*Switches given to the rlogin command `nntp-via-rlogin-command'. + "Switches given to the rlogin command `nntp-via-rlogin-command'. If you use \"ssh\" for `nntp-via-rlogin-command', you may set this to \(\"-C\") in order to compress all data connections, otherwise set this to \(\"-t\" \"-e\" \"none\") or (\"-C\" \"-t\" \"-e\" \"none\") if the telnet command requires a pseudo-tty allocation on an intermediate host.") (defvoo nntp-via-telnet-command "telnet" - "*Telnet command used to connect to an intermediate host. + "Telnet command used to connect to an intermediate host. This command is used by the `nntp-open-via-telnet-and-telnet' method.") (defvoo nntp-via-telnet-switches '("-8") - "*Switches given to the telnet command `nntp-via-telnet-command'.") + "Switches given to the telnet command `nntp-via-telnet-command'.") (defvoo nntp-netcat-command "nc" - "*Netcat command used to connect to the nntp server. + "Netcat command used to connect to the nntp server. This command is used by the `nntp-open-netcat-stream' and `nntp-open-via-rlogin-and-netcat' methods.") (defvoo nntp-netcat-switches nil - "*Switches given to the netcat command `nntp-netcat-command'.") + "Switches given to the netcat command `nntp-netcat-command'.") (defvoo nntp-via-user-name nil - "*User name to log in on an intermediate host with. + "User name to log in on an intermediate host with. This variable is used by the various nntp-open-via-* methods.") (defvoo nntp-via-user-password nil - "*Password to use to log in on an intermediate host with. + "Password to use to log in on an intermediate host with. This variable is used by the `nntp-open-via-telnet-and-telnet' method.") (defvoo nntp-via-address nil - "*Address of an intermediate host to connect to. + "Address of an intermediate host to connect to. This variable is used by the various nntp-open-via-* methods.") (defvoo nntp-via-envuser nil - "*Whether both telnet client and server support the ENVIRON option. + "Whether both telnet client and server support the ENVIRON option. If non-nil, there will be no prompt for a login name.") (defvoo nntp-via-shell-prompt "bash\\|[$>] *\r?$" - "*Regular expression to match the shell prompt on an intermediate host. + "Regular expression to match the shell prompt on an intermediate host. This variable is used by the `nntp-open-via-telnet-and-telnet' method.") (defvoo nntp-large-newsgroup 50 - "*The number of articles which indicates a large newsgroup. + "The number of articles which indicates a large newsgroup. If the number of articles is greater than the value, verbose messages will be shown to indicate the current status.") (defvoo nntp-maximum-request 400 - "*The maximum number of the requests sent to the NNTP server at one time. + "The maximum number of the requests sent to the NNTP server at one time. If Emacs hangs up while retrieving headers, set the variable to a lower value.") (defvoo nntp-nov-is-evil nil - "*If non-nil, nntp will never attempt to use XOVER when talking to the server.") + "If non-nil, nntp will never attempt to use XOVER when talking to the server.") (defvoo nntp-xover-commands '("XOVER" "XOVERVIEW") - "*List of strings that are used as commands to fetch NOV lines from a server. + "List of strings that are used as commands to fetch NOV lines from a server. The strings are tried in turn until a positive response is gotten. If none of the commands are successful, nntp will just grab headers one by one.") (defvoo nntp-nov-gap 5 - "*Maximum allowed gap between two articles. + "Maximum allowed gap between two articles. If the gap between two consecutive articles is bigger than this variable, split the XOVER request into two requests.") (defvoo nntp-xref-number-is-evil nil - "*If non-nil, Gnus never trusts article numbers in the Xref header. + "If non-nil, Gnus never trusts article numbers in the Xref header. Some news servers, e.g., ones running Diablo, run multiple engines having the same articles but article numbers are not kept synchronized between them. If you connect to such a server, set this to a non-nil @@ -206,7 +206,7 @@ value, and Gnus never uses article numbers (that appear in the Xref header and vary by which engine is chosen) to refer to articles.") (defvoo nntp-prepare-server-hook nil - "*Hook run before a server is opened. + "Hook run before a server is opened. If can be used to set up a server remotely, for instance. Say you have an account at the machine \"other.machine\". This machine has access to an NNTP server that you can't access locally. You could @@ -237,11 +237,11 @@ server there that you can connect to. See also (defvoo nntp-connection-timeout nil - "*Number of seconds to wait before an nntp connection times out. + "Number of seconds to wait before an nntp connection times out. If this variable is nil, which is the default, no timers are set.") (defvoo nntp-prepare-post-hook nil - "*Hook run just before posting an article. It is supposed to be used + "Hook run just before posting an article. It is supposed to be used to insert Cancel-Lock headers.") (defvoo nntp-server-list-active-group 'try @@ -342,9 +342,7 @@ retried once before actually displaying the error report." `(let ((string (buffer-substring ,start ,end))) (with-current-buffer ,buffer (erase-buffer) - (insert (if enable-multibyte-characters - (string-to-multibyte string) - string)) + (insert string) (goto-char (point-min)) nil))) @@ -565,7 +563,7 @@ retried once before actually displaying the error report." (nntp-find-connection-buffer nntp-server-buffer))) (nntp-encode-text) ;; Make sure we did not forget to encode some of the content. - (assert (save-excursion (goto-char (point-min)) + (cl-assert (save-excursion (goto-char (point-min)) (not (re-search-forward "[^\000-\377]" nil t)))) (mm-disable-multibyte) (process-send-region (nntp-find-connection nntp-server-buffer) @@ -701,7 +699,7 @@ command whose response triggered the error." ;; `articles' is either a list of article numbers ;; or a list of article IDs. article)) - (incf count) + (cl-incf count) ;; Every 400 requests we have to read the stream in ;; order to avoid deadlocks. (when (or (null articles) ;All requests have been sent. @@ -713,7 +711,7 @@ command whose response triggered the error." ;; Count replies. (while (nntp-next-result-arrived-p) (setq last-point (point)) - (incf received)) + (cl-incf received)) (< received count)) ;; If number of headers is greater than 100, give ;; informative messages. @@ -786,7 +784,7 @@ command whose response triggered the error." "^[.]" "^[0-9]") nil t) - (incf received)) + (cl-incf received)) (setq last-point (point)) (< received count))) (nntp-accept-response)) @@ -851,7 +849,7 @@ command whose response triggered the error." (throw 'done nil)) ;; Send the command to the server. (nntp-send-command nil command (pop groups)) - (incf count) + (cl-incf count) ;; Every 400 requests we have to read the stream in ;; order to avoid deadlocks. (when (or (null groups) ;All requests have been sent. @@ -865,7 +863,7 @@ command whose response triggered the error." (goto-char last-point) ;; Count replies. (while (re-search-forward "^[0-9]" nil t) - (incf received)) + (cl-incf received)) (setq last-point (point)) (< received count))) (nntp-accept-response)))) @@ -937,7 +935,7 @@ command whose response triggered the error." ;; `articles' is either a list of article numbers ;; or a list of article IDs. article)) - (incf count) + (cl-incf count) ;; Every 400 requests we have to read the stream in ;; order to avoid deadlocks. (when (or (null articles) ;All requests have been sent. @@ -950,7 +948,7 @@ command whose response triggered the error." (while (nntp-next-result-arrived-p) (aset map received (cons (aref map received) (point))) (setq last-point (point)) - (incf received)) + (cl-incf received)) (< received count)) ;; If number of headers is greater than 100, give ;; informative messages. @@ -1572,7 +1570,7 @@ If SEND-IF-FORCE, only send authinfo to the server if the ;; Count replies. (while (re-search-forward "^\\([0-9][0-9][0-9]\\) .*\n" nil t) - (incf received) + (cl-incf received) (setq status (match-string 1)) (if (string-match "^[45]" status) (setq status 'error) @@ -1743,26 +1741,26 @@ If SEND-IF-FORCE, only send authinfo to the server if the ;; ========================================================================== (defvoo nntp-open-telnet-envuser nil - "*If non-nil, telnet session (client and server both) will support the ENVIRON option and not prompt for login name.") + "If non-nil, telnet session (client and server both) will support the ENVIRON option and not prompt for login name.") (defvoo nntp-telnet-shell-prompt "bash\\|[$>] *\r?$" - "*Regular expression to match the shell prompt on the remote machine.") + "Regular expression to match the shell prompt on the remote machine.") (defvoo nntp-rlogin-program "rsh" - "*Program used to log in on remote machines. + "Program used to log in on remote machines. The default is \"rsh\", but \"ssh\" is a popular alternative.") (defvoo nntp-rlogin-parameters '("telnet" "-8" "${NNTPSERVER:=news}" "nntp") - "*Parameters to `nntp-open-rlogin'. + "Parameters to `nntp-open-rlogin'. That function may be used as `nntp-open-connection-function'. In that case, this list will be used as the parameter list given to rsh.") (defvoo nntp-rlogin-user-name nil - "*User name on remote system when using the rlogin connect method.") + "User name on remote system when using the rlogin connect method.") (defvoo nntp-telnet-parameters '("exec" "telnet" "-8" "${NNTPSERVER:=news}" "nntp") - "*Parameters to `nntp-open-telnet'. + "Parameters to `nntp-open-telnet'. That function may be used as `nntp-open-connection-function'. In that case, this list will be executed as a command after logging in via telnet.") diff --git a/lisp/gnus/nnvirtual.el b/lisp/gnus/nnvirtual.el index 397d44ee2ac..777c5c1bbe0 100644 --- a/lisp/gnus/nnvirtual.el +++ b/lisp/gnus/nnvirtual.el @@ -38,7 +38,7 @@ (require 'gnus-start) (require 'gnus-sum) (require 'gnus-msg) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (nnoo-declare nnvirtual) @@ -774,13 +774,13 @@ based on the marks on the component groups." ;; We need to convert the unreads to reads. We compress the ;; sequence as we go, otherwise it could be huge. - (while (and (<= (incf i) nnvirtual-mapping-len) + (while (and (<= (cl-incf i) nnvirtual-mapping-len) unreads) (if (= i (car unreads)) (setq unreads (cdr unreads)) ;; try to get a range. (setq beg i) - (while (and (<= (incf i) nnvirtual-mapping-len) + (while (and (<= (cl-incf i) nnvirtual-mapping-len) (not (= i (car unreads))))) (setq i (- i 1)) (if (= i beg) diff --git a/lisp/gnus/nnweb.el b/lisp/gnus/nnweb.el index cac2dae8ebb..a64f10f98a7 100644 --- a/lisp/gnus/nnweb.el +++ b/lisp/gnus/nnweb.el @@ -24,7 +24,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'nnoo) (require 'message) @@ -33,9 +33,7 @@ (require 'nnmail) (require 'mm-util) (require 'mm-url) -(eval-and-compile - (ignore-errors - (require 'url))) +(require 'url) (nnoo-declare nnweb) @@ -362,11 +360,11 @@ Valid types include `google', `dejanews', and `gmane'.") (current-time-string))) (setq From (match-string 4))) (widen) - (incf i) + (cl-incf i) (unless (nnweb-get-hashtb url) (push (list - (incf (cdr active)) + (cl-incf (cdr active)) (make-full-mail-header (cdr active) (if Newsgroups (concat "(" Newsgroups ") " Subject) @@ -398,7 +396,7 @@ Valid types include `google', `dejanews', and `gmane'.") (nconc nnweb-articles (nnweb-google-parse-1))) ;; Check if there are more articles to fetch (goto-char (point-min)) - (incf i 100) + (cl-incf i 100) (if (or (not (re-search-forward "<a [^>]+href=\"\n?\\([^>\" \n\t]+\\)[^<]*<img[^>]+src=[^>]+next" nil t)) @@ -478,7 +476,7 @@ Valid types include `google', `dejanews', and `gmane'.") (rfc2047-encode-string subject)) (unless (nnweb-get-hashtb (mail-header-xref header)) - (mail-header-set-number header (incf (cdr active))) + (mail-header-set-number header (cl-incf (cdr active))) (push (list (mail-header-number header) header) map) (nnweb-set-hashtb (cadar map) (car map)))))) (forward-line 1))) @@ -525,10 +523,6 @@ Valid types include `google', `dejanews', and `gmane'.") (defun nnweb-insert-html (parse) "Insert HTML based on a w3 parse tree." (if (stringp parse) - ;; We used to call nnheader-string-as-multibyte here, but it cannot - ;; be right, so I removed it. If a bug shows up because of this change, - ;; please do not blindly revert the change, but help me find the real - ;; cause of the bug instead. --Stef (insert parse) (insert "<" (symbol-name (car parse)) " ") (insert (mapconcat diff --git a/lisp/gnus/score-mode.el b/lisp/gnus/score-mode.el index 9ef0598ee09..9bceb4ead90 100644 --- a/lisp/gnus/score-mode.el +++ b/lisp/gnus/score-mode.el @@ -24,7 +24,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (require 'mm-util) ; for mm-universal-coding-system (require 'gnus-util) ; for gnus-pp, gnus-run-mode-hooks @@ -85,7 +84,7 @@ This mode is an extended emacs-lisp mode. (defun gnus-score-edit-insert-date () "Insert date in numerical format." (interactive) - (princ (time-to-days (current-time)) (current-buffer))) + (princ (time-to-days nil) (current-buffer))) (defun gnus-score-pretty-print () "Format the current score file." diff --git a/lisp/gnus/smiley.el b/lisp/gnus/smiley.el index 389ae67d1a4..226a4cecdcb 100644 --- a/lisp/gnus/smiley.el +++ b/lisp/gnus/smiley.el @@ -47,7 +47,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (require 'nnheader) (require 'gnus-art) diff --git a/lisp/gnus/smime.el b/lisp/gnus/smime.el index 3e722d2d82d..ab2a5b0f813 100644 --- a/lisp/gnus/smime.el +++ b/lisp/gnus/smime.el @@ -234,10 +234,12 @@ must be set in `ldap-host-parameters-alist'." If `cache-key' and `password-cache' is non-nil then cache the password under `cache-key'." (let ((passphrase - (password-read-and-add + (password-read "Passphrase for secret key (RET for no passphrase): " cache-key))) (if (string= passphrase "") nil + ;; FIXME test passphrase works before caching it. + (and passphrase cache-key (password-cache-add cache-key passphrase)) passphrase))) ;; OpenSSL wrappers. diff --git a/lisp/gnus/spam.el b/lisp/gnus/spam.el index 1c2b3467237..710e0e83cf9 100644 --- a/lisp/gnus/spam.el +++ b/lisp/gnus/spam.el @@ -38,8 +38,6 @@ ;;{{{ compilation directives and autoloads/requires -(eval-when-compile (require 'cl)) - (require 'message) ;for the message-fetch-field functions (require 'gnus-sum) (require 'gnus-uu) ; because of key prefix issues @@ -51,6 +49,8 @@ ;; for nnimap-split-download-body-default (eval-when-compile (require 'nnimap)) +(eval-when-compile (require 'cl-lib)) + ;; autoload query-dig (autoload 'query-dig "dig") @@ -366,9 +366,6 @@ Only meaningful if you enable `spam-use-blackholes'." (t :inverse-video t)) "Face for spam-marked articles." :group 'spam) -;; backward-compatibility alias -(put 'spam-face 'face-alias 'spam) -(put 'spam-face 'obsolete-face "22.1") (defcustom spam-face 'spam "Face for spam-marked articles." @@ -1167,12 +1164,12 @@ backends)." (defun spam-article-sort-by-spam-status (h1 h2) "Sort articles by score." (let (result) - (dolist (header (spam-necessary-extra-headers)) + (cl-dolist (header (spam-necessary-extra-headers)) (let ((s1 (spam-summary-score h1 header)) (s2 (spam-summary-score h2 header))) (unless (= s1 s2) (setq result (< s1 s2)) - (return)))) + (cl-return)))) result)) (defvar spam-spamassassin-score-regexp @@ -1208,14 +1205,14 @@ Note this has to be fast." With SPECIFIC-HEADER, returns only that header's score. Will not return a nil score." (let (score) - (dolist (header + (cl-dolist (header (if specific-header (list specific-header) (spam-necessary-extra-headers))) (setq score (spam-extra-header-to-number header headers)) (when score - (return))) + (cl-return))) (or score 0))) (defun spam-generic-score (&optional recheck) @@ -1247,73 +1244,40 @@ Will not return a nil score." (setq found backend))) found)) -(defvar spam-list-of-processors - ;; note the nil processors are not defined in gnus.el - '((gnus-group-spam-exit-processor-bogofilter spam spam-use-bogofilter) - (gnus-group-spam-exit-processor-bsfilter spam spam-use-bsfilter) - (gnus-group-spam-exit-processor-blacklist spam spam-use-blacklist) - (gnus-group-spam-exit-processor-ifile spam spam-use-ifile) - (gnus-group-spam-exit-processor-stat spam spam-use-stat) - (gnus-group-spam-exit-processor-spamoracle spam spam-use-spamoracle) - (gnus-group-spam-exit-processor-spamassassin spam spam-use-spamassassin) - (gnus-group-spam-exit-processor-report-gmane spam spam-use-gmane) ;; Buggy? - (gnus-group-ham-exit-processor-ifile ham spam-use-ifile) - (gnus-group-ham-exit-processor-bogofilter ham spam-use-bogofilter) - (gnus-group-ham-exit-processor-bsfilter ham spam-use-bsfilter) - (gnus-group-ham-exit-processor-stat ham spam-use-stat) - (gnus-group-ham-exit-processor-whitelist ham spam-use-whitelist) - (gnus-group-ham-exit-processor-BBDB ham spam-use-BBDB) - (gnus-group-ham-exit-processor-copy ham spam-use-ham-copy) - (gnus-group-ham-exit-processor-spamassassin ham spam-use-spamassassin) - (gnus-group-ham-exit-processor-spamoracle ham spam-use-spamoracle)) - "The OBSOLETE `spam-list-of-processors' list. -This list contains pairs associating the obsolete ham/spam exit -processor variables with a classification and a spam-use-* -variable. When the processor variable is nil, just the -classification and spam-use-* check variable are used. This is -superseded by the new spam backend code, so it's only consulted -for backwards compatibility.") -(make-obsolete-variable 'spam-list-of-processors nil "22.1") - (defun spam-group-processor-p (group backend &optional classification) "Checks if GROUP has a BACKEND with CLASSIFICATION registered. -Also accepts the obsolete processors, which can be found in -gnus.el and in spam-list-of-processors. In the case of mover -backends, checks the setting of `spam-summary-exit-behavior' in -addition to the set values for the group." +In the case of mover backends, checks the setting of +`spam-summary-exit-behavior' in addition to the set values for the group." (if (and (stringp group) (symbolp backend)) - (let ((old-style (assq backend spam-list-of-processors)) - (parameters (nth 0 (gnus-parameter-spam-process group))) + (let ((parameters (nth 0 (gnus-parameter-spam-process group))) found) - (if old-style ; old-style processor - (spam-group-processor-p group (nth 2 old-style) (nth 1 old-style)) - ;; now search for the parameter - (dolist (parameter parameters) - (when (and (null found) - (listp parameter) - (eq classification (nth 0 parameter)) - (eq backend (nth 1 parameter))) - (setq found t))) - - ;; now, if the parameter was not found, do the - ;; spam-summary-exit-behavior-logic for mover backends - (unless found - (when (spam-backend-mover-p backend) - (setq - found - (cond - ((eq spam-summary-exit-behavior 'move-all) t) - ((eq spam-summary-exit-behavior 'move-none) nil) - ((eq spam-summary-exit-behavior 'default) - (or (eq classification 'spam) ;move spam out of all groups - ;; move ham out of spam groups - (and (eq classification 'ham) - (spam-group-spam-contents-p group)))) - (t (gnus-error 5 "Unknown spam-summary-exit-behavior: %s" - spam-summary-exit-behavior)))))) - - found)) + ;; now search for the parameter + (dolist (parameter parameters) + (when (and (null found) + (listp parameter) + (eq classification (nth 0 parameter)) + (eq backend (nth 1 parameter))) + (setq found t))) + + ;; now, if the parameter was not found, do the + ;; spam-summary-exit-behavior-logic for mover backends + (unless found + (when (spam-backend-mover-p backend) + (setq + found + (cond + ((eq spam-summary-exit-behavior 'move-all) t) + ((eq spam-summary-exit-behavior 'move-none) nil) + ((eq spam-summary-exit-behavior 'default) + (or (eq classification 'spam) ;move spam out of all groups + ;; move ham out of spam groups + (and (eq classification 'ham) + (spam-group-spam-contents-p group)))) + (t (gnus-error 5 "Unknown spam-summary-exit-behavior: %s" + spam-summary-exit-behavior)))))) + + found) nil)) ;;}}} @@ -1697,10 +1661,10 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." article-cannot-be-faked) - (dolist (backend methods) + (cl-dolist (backend methods) (when (spam-backend-statistical-p backend) (setq article-cannot-be-faked t) - (return))) + (cl-return))) (when (memq 'default methods) (setq article-cannot-be-faked t)) @@ -1785,7 +1749,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." ;; eliminate duplicates (dolist (article (copy-sequence ulist)) (when (memq article rlist) - (incf delcount) + (cl-incf delcount) (setq rlist (delq article rlist)) (setq ulist (delq article ulist)))) @@ -2335,10 +2299,10 @@ With a non-nil REMOVE, remove the ADDRESSES." (when (stringp from) (spam-filelist-build-cache type) (let (found) - (dolist (address (gethash type spam-caches)) + (cl-dolist (address (gethash type spam-caches)) (when (and address (string-match address from)) (setq found t) - (return))) + (cl-return))) found))) ;;; returns t if the sender is in the whitelist, nil or |