diff options
Diffstat (limited to 'lisp/gnus')
49 files changed, 398 insertions, 399 deletions
diff --git a/lisp/gnus/deuglify.el b/lisp/gnus/deuglify.el index 82dbbab5e0d..647f643c962 100644 --- a/lisp/gnus/deuglify.el +++ b/lisp/gnus/deuglify.el @@ -266,21 +266,21 @@ "\\(On \\|Am \\)?\\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\),[^,]+, " "Regular expression matching the beginning of an attribution line that should be cut off." :version "22.1" - :type 'string + :type 'regexp :group 'gnus-outlook-deuglify) (defcustom gnus-outlook-deuglify-attrib-verb-regexp "wrote\\|writes\\|says\\|schrieb\\|schreibt\\|meinte\\|skrev\\|a écrit\\|schreef\\|escribió" "Regular expression matching the verb used in an attribution line." :version "22.1" - :type 'string + :type 'regexp :group 'gnus-outlook-deuglify) (defcustom gnus-outlook-deuglify-attrib-end-regexp ": *\\|\\.\\.\\." "Regular expression matching the end of an attribution line." :version "22.1" - :type 'string + :type 'regexp :group 'gnus-outlook-deuglify) (defcustom gnus-outlook-display-hook nil @@ -403,9 +403,9 @@ NODISPLAY is non-nil, don't redisplay the article buffer." (gnus-with-article-buffer (article-goto-body) (when (re-search-forward - (concat "^[" cite-marks " \t]*--* ?[^-]+ [^-]+ ?--*\\s *\n" + (concat "^[" cite-marks " \t]*--*[^-]+ [^-]+--*\\s *\n" "[^\n:]+:[ \t]*\\([^\n]+\\)\n" - "\\([^\n:]+:[ \t]*[^\n]+\n\\)+") + "\\([^\n:]+:[^\n]+\n\\)+") nil t) (gnus-kill-all-overlays) (replace-match "\\1 wrote:\n") diff --git a/lisp/gnus/gmm-utils.el b/lisp/gnus/gmm-utils.el index 2df098bc0bf..6d24b409ed0 100644 --- a/lisp/gnus/gmm-utils.el +++ b/lisp/gnus/gmm-utils.el @@ -168,9 +168,9 @@ ARGS are passed to `message'." (defcustom gmm-tool-bar-style (if (and (boundp 'tool-bar-mode) tool-bar-mode - (memq (display-visual-class) - (list 'static-gray 'gray-scale - 'static-color 'pseudo-color))) + (not (memq (display-visual-class) + (list 'static-gray 'gray-scale + 'static-color 'pseudo-color)))) 'gnome 'retro) "Preferred tool bar style." diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el index cf705ae5dc1..1ed5000eb36 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -799,7 +799,7 @@ be a select method." (let ((gnus-command-method method) (gnus-agent nil)) (when (file-exists-p (gnus-agent-lib-file "flags")) - (set-buffer (get-buffer-create " *Gnus Agent flag synchronize*")) + (set-buffer (gnus-get-buffer-create " *Gnus Agent flag synchronize*")) (erase-buffer) (nnheader-insert-file-contents (gnus-agent-lib-file "flags")) (cond ((null gnus-plugged) diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 6b9610d3121..614651afff9 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -5833,6 +5833,7 @@ all parts." "" "...")) (gnus-tmp-length (with-current-buffer (mm-handle-buffer handle) (buffer-size))) + (help-echo "mouse-2: toggle the MIME part; down-mouse-3: more options") gnus-tmp-type-long b e) (when (string-match ".*/" gnus-tmp-name) (setq gnus-tmp-name (replace-match "" t t gnus-tmp-name))) @@ -5841,6 +5842,16 @@ all parts." (concat "; " gnus-tmp-name)))) (unless (equal gnus-tmp-description "") (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long))) + (when (zerop gnus-tmp-length) + (setq gnus-tmp-type-long + (concat + gnus-tmp-type-long + (substitute-command-keys + (concat "\\<gnus-summary-mode-map> (not downloaded, " + "\\[gnus-summary-show-complete-article] to fetch.)")))) + (setq help-echo + (concat "Type \\[gnus-summary-show-complete-article] " + "to download complete article. " help-echo))) (setq b (point)) (gnus-eval-format gnus-mime-button-line-format gnus-mime-button-line-format-alist @@ -5859,8 +5870,7 @@ all parts." 'keymap gnus-mime-button-map 'face gnus-article-button-face 'follow-link t - 'help-echo - "mouse-2: toggle the MIME part; down-mouse-3: more options"))) + 'help-echo help-echo))) (defvar gnus-displaying-mime nil) diff --git a/lisp/gnus/gnus-bookmark.el b/lisp/gnus/gnus-bookmark.el index ea4af2df0c4..1b00bbbc69c 100644 --- a/lisp/gnus/gnus-bookmark.el +++ b/lisp/gnus/gnus-bookmark.el @@ -242,7 +242,7 @@ So the cdr of each bookmark is an alist too.") (save-window-excursion ;; Avoid warnings? ;; (message "Saving Gnus bookmarks to file %s..." gnus-bookmark-default-file) - (set-buffer (get-buffer-create " *Gnus bookmarks*")) + (set-buffer (gnus-get-buffer-create " *Gnus bookmarks*")) (erase-buffer) (gnus-bookmark-insert-file-format-version-stamp) (pp gnus-bookmark-alist (current-buffer)) @@ -357,8 +357,8 @@ deletion, or > if it is flagged for displaying." (interactive) (gnus-bookmark-maybe-load-default-file) (if (called-interactively-p 'any) - (switch-to-buffer (get-buffer-create "*Gnus Bookmark List*")) - (set-buffer (get-buffer-create "*Gnus Bookmark List*"))) + (switch-to-buffer (gnus-get-buffer-create "*Gnus Bookmark List*")) + (set-buffer (gnus-get-buffer-create "*Gnus Bookmark List*"))) (let ((inhibit-read-only t) alist name start end) (erase-buffer) @@ -648,7 +648,7 @@ reposition and try again, else return nil." (details gnus-bookmark-bookmark-details) detail) (save-excursion - (pop-to-buffer (get-buffer-create "*Gnus Bookmark Annotation*") t) + (pop-to-buffer (gnus-get-buffer-create "*Gnus Bookmark Annotation*") t) (erase-buffer) (while details (setq detail (pop details)) diff --git a/lisp/gnus/gnus-cloud.el b/lisp/gnus/gnus-cloud.el index cecfaef2f4f..673a4d22988 100644 --- a/lisp/gnus/gnus-cloud.el +++ b/lisp/gnus/gnus-cloud.el @@ -223,13 +223,10 @@ easy interactive way to set this from the Server buffer." (t (gnus-message 1 "Unknown type %s; ignoring" type)))))) -(defun gnus-cloud-update-newsrc-data (group elem &optional force-older) - "Update the newsrc data for GROUP from ELEM. -Use old data if FORCE-OLDER is not nil." +(defun gnus-cloud-update-newsrc-data (group elem) + "Update the newsrc data for GROUP from ELEM." (let* ((contents (plist-get elem :contents)) (date (or (plist-get elem :timestamp) "0")) - (now (gnus-cloud-timestamp nil)) - (newer (string-lessp date now)) (group-info (gnus-get-info group))) (if (and contents (stringp (nth 0 contents)) @@ -238,15 +235,13 @@ Use old data if FORCE-OLDER is not nil." (if (equal (format "%S" group-info) (format "%S" contents)) (gnus-message 3 "Skipping cloud update of group %s, the info is the same" group) - (if (and newer (not force-older)) - (gnus-message 3 "Skipping outdated cloud info for group %s, the info is from %s (now is %s)" group date now) - (when (or (not gnus-cloud-interactive) - (gnus-y-or-n-p - (format "%s has older different info in the cloud as of %s, update it here? " - group date)))) - (gnus-message 2 "Installing cloud update of group %s" group) - (gnus-set-info group contents) - (gnus-group-update-group group))) + (when (or (not gnus-cloud-interactive) + (gnus-y-or-n-p + (format "%s has different info in the cloud from %s, update it here? " + group date))) + (gnus-message 2 "Installing cloud update of group %s" group) + (gnus-set-info group contents) + (gnus-group-update-group group))) (gnus-error 1 "Sorry, group %s is not subscribed" group)) (gnus-error 1 "Sorry, could not update newsrc for group %s (invalid data %S)" group elem)))) @@ -285,8 +280,8 @@ Use old data if FORCE-OLDER is not nil." (insert new-contents) (when (file-exists-p file-name) (rename-file file-name (car (find-backup-file-name file-name)))) - (write-region (point-min) (point-max) file-name) - (set-file-times file-name (parse-iso8601-time-string date)))) + (write-region (point-min) (point-max) file-name nil nil nil 'excl) + (set-file-times file-name (parse-iso8601-time-string date) 'nofollow))) (defun gnus-cloud-file-covered-p (file-name) (let ((matched nil)) @@ -380,8 +375,9 @@ When FULL is t, upload everything, not just a difference from the last full." (gnus-cloud-files-to-upload full) (gnus-cloud-collect-full-newsrc))) (group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method))) + (setq gnus-cloud-sequence (1+ (or gnus-cloud-sequence 0))) (insert (format "Subject: (sequence: %s type: %s storage-method: %s)\n" - (or gnus-cloud-sequence "UNKNOWN") + gnus-cloud-sequence (if full :full :partial) gnus-cloud-storage-method)) (insert "From: nobody@gnus.cloud.invalid\n") @@ -390,7 +386,6 @@ When FULL is t, upload everything, not just a difference from the last full." (if (gnus-request-accept-article gnus-cloud-group-name gnus-cloud-method t t) (progn - (setq gnus-cloud-sequence (1+ (or gnus-cloud-sequence 0))) (gnus-cloud-add-timestamps elems) (gnus-message 3 "Uploaded Gnus Cloud data successfully to %s" group) (gnus-group-refresh-group group)) @@ -459,18 +454,21 @@ instead of `gnus-cloud-sequence'. When UPDATE is t, returns the result of calling `gnus-cloud-update-all'. Otherwise, returns the Gnus Cloud data chunks." (let ((articles nil) + (highest-sequence-seen gnus-cloud-sequence) chunks) (dolist (header (gnus-cloud-available-chunks)) - (when (> (gnus-cloud-chunk-sequence (mail-header-subject header)) - (or sequence-override gnus-cloud-sequence -1)) - - (if (string-match (format "storage-method: %s" gnus-cloud-storage-method) - (mail-header-subject header)) - (push (mail-header-number header) articles) - (gnus-message 1 "Skipping article %s because it didn't match the Gnus Cloud method %s: %s" - (mail-header-number header) - gnus-cloud-storage-method - (mail-header-subject header))))) + (let ((this-sequence (gnus-cloud-chunk-sequence (mail-header-subject header)))) + (when (> this-sequence (or sequence-override gnus-cloud-sequence -1)) + + (if (string-match (format "storage-method: %s" gnus-cloud-storage-method) + (mail-header-subject header)) + (progn + (push (mail-header-number header) articles) + (setq highest-sequence-seen (max highest-sequence-seen this-sequence))) + (gnus-message 1 "Skipping article %s because it didn't match the Gnus Cloud method %s: %s" + (mail-header-number header) + gnus-cloud-storage-method + (mail-header-subject header)))))) (when articles (nnimap-request-articles (nreverse articles) gnus-cloud-group-name) (with-current-buffer nntp-server-buffer @@ -480,7 +478,8 @@ Otherwise, returns the Gnus Cloud data chunks." (push (gnus-cloud-parse-chunk) chunks) (forward-line 1)))) (if update - (mapcar #'gnus-cloud-update-all chunks) + (prog1 (mapcar #'gnus-cloud-update-all chunks) + (setq gnus-cloud-sequence highest-sequence-seen)) chunks))) (defun gnus-cloud-server-p (server) diff --git a/lisp/gnus/gnus-delay.el b/lisp/gnus/gnus-delay.el index 8dae4ef5c17..63e938e7453 100644 --- a/lisp/gnus/gnus-delay.el +++ b/lisp/gnus/gnus-delay.el @@ -75,7 +75,11 @@ DELAY is a string, giving the length of the time. Possible values are: variable `gnus-delay-default-hour', minute and second are zero. * hh:mm for a specific time. Use 24h format. If it is later than this - time, then the deadline is tomorrow, else today." + time, then the deadline is tomorrow, else today. + +The value of `message-draft-headers' determines which headers are +generated when the article is delayed. Remaining headers are +generated when the article is sent." (interactive (list (read-string "Target date (YYYY-MM-DD), time (hh:mm), or length of delay (units in [mhdwMY]): " diff --git a/lisp/gnus/gnus-draft.el b/lisp/gnus/gnus-draft.el index 1b25d247389..3a9bf2a7e8f 100644 --- a/lisp/gnus/gnus-draft.el +++ b/lisp/gnus/gnus-draft.el @@ -248,7 +248,7 @@ If DONT-POP is nil, display the buffer after setting it up." (let ((article narticle)) (message-mail nil nil nil nil (if dont-pop - (lambda (buf) (set-buffer (get-buffer-create buf))))) + (lambda (buf) (set-buffer (gnus-get-buffer-create buf))))) (let ((inhibit-read-only t)) (erase-buffer)) (if (not (gnus-request-restore-buffer article group)) diff --git a/lisp/gnus/gnus-eform.el b/lisp/gnus/gnus-eform.el index 54118aad1e6..1bc1261ee8f 100644 --- a/lisp/gnus/gnus-eform.el +++ b/lisp/gnus/gnus-eform.el @@ -50,13 +50,13 @@ (defvar gnus-edit-form-buffer "*Gnus edit form*") (defvar gnus-edit-form-done-function nil) -(defvar gnus-edit-form-mode-map nil) -(unless gnus-edit-form-mode-map - (setq gnus-edit-form-mode-map (make-sparse-keymap)) - (set-keymap-parent gnus-edit-form-mode-map emacs-lisp-mode-map) - (gnus-define-keys gnus-edit-form-mode-map - "\C-c\C-c" gnus-edit-form-done - "\C-c\C-k" gnus-edit-form-exit)) +(defvar gnus-edit-form-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map emacs-lisp-mode-map) + (gnus-define-keys map + "\C-c\C-c" gnus-edit-form-done + "\C-c\C-k" gnus-edit-form-exit) + map)) (defun gnus-edit-form-make-menu-bar () (unless (boundp 'gnus-edit-form-menu) @@ -67,9 +67,9 @@ ["Exit" gnus-edit-form-exit t])) (gnus-run-hooks 'gnus-edit-form-menu-hook))) -(define-derived-mode gnus-edit-form-mode fundamental-mode "Edit Form" +(define-derived-mode gnus-edit-form-mode lisp-data-mode "Edit Form" "Major mode for editing forms. -It is a slightly enhanced emacs-lisp-mode. +It is a slightly enhanced `lisp-data-mode'. \\{gnus-edit-form-mode-map}" (when (gnus-visual-p 'group-menu 'menu) diff --git a/lisp/gnus/gnus-fun.el b/lisp/gnus/gnus-fun.el index 33cbf4a54a9..c95449762e4 100644 --- a/lisp/gnus/gnus-fun.el +++ b/lisp/gnus/gnus-fun.el @@ -40,7 +40,7 @@ "Regexp to match faces in `gnus-x-face-directory' to be omitted." :version "25.1" :group 'gnus-fun - :type '(choice (const nil) string)) + :type '(choice (const nil) regexp)) (defcustom gnus-face-directory (expand-file-name "faces" gnus-directory) "Directory where Face PNG files are stored." @@ -52,7 +52,7 @@ "Regexp to match faces in `gnus-face-directory' to be omitted." :version "25.1" :group 'gnus-fun - :type '(choice (const nil) string)) + :type '(choice (const nil) regexp)) (defcustom gnus-convert-pbm-to-x-face-command "pbmtoxbm %s | compface" "Command for converting a PBM to an X-Face." diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index b89f040b435..da7db589ec3 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -3761,10 +3761,10 @@ group line." (newsrc ;; Toggle subscription flag. (gnus-group-change-level - newsrc (if level level (if (<= (gnus-info-level (nth 1 newsrc)) - gnus-level-subscribed) - (1+ gnus-level-subscribed) - gnus-level-default-subscribed))) + newsrc (or level (if (<= (gnus-info-level (nth 1 newsrc)) + gnus-level-subscribed) + (1+ gnus-level-subscribed) + gnus-level-default-subscribed))) (unless silent (gnus-group-update-group group))) ((and (stringp group) @@ -3773,7 +3773,7 @@ group line." ;; Add new newsgroup. (gnus-group-change-level group - (if level level gnus-level-default-subscribed) + (or level gnus-level-default-subscribed) (or (and (member group gnus-zombie-list) gnus-level-zombie) gnus-level-killed) diff --git a/lisp/gnus/gnus-icalendar.el b/lisp/gnus/gnus-icalendar.el index ee556a32080..305e17fd8fc 100644 --- a/lisp/gnus/gnus-icalendar.el +++ b/lisp/gnus/gnus-icalendar.el @@ -814,7 +814,7 @@ These will be used to retrieve the RSVP information from ical events." (let ((subject (concat (capitalize (symbol-name status)) ": " (gnus-icalendar-event:summary event)))) - (with-current-buffer (get-buffer-create gnus-icalendar-reply-bufname) + (with-current-buffer (gnus-get-buffer-create gnus-icalendar-reply-bufname) (delete-region (point-min) (point-max)) (insert reply) (fold-icalendar-buffer) diff --git a/lisp/gnus/gnus-int.el b/lisp/gnus/gnus-int.el index c304f575d92..60ebc07c343 100644 --- a/lisp/gnus/gnus-int.el +++ b/lisp/gnus/gnus-int.el @@ -253,7 +253,7 @@ If it is down, start it up (again)." (defun gnus-backend-trace (type form) (when gnus-backend-trace - (with-current-buffer (get-buffer-create "*gnus trace*") + (with-current-buffer (gnus-get-buffer-create "*gnus trace*") (buffer-disable-undo) (goto-char (point-max)) (insert (format-time-string "%H:%M:%S") diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el index fd2b44f7424..f306889a7fc 100644 --- a/lisp/gnus/gnus-registry.el +++ b/lisp/gnus/gnus-registry.el @@ -1,4 +1,4 @@ -;;; gnus-registry.el --- article registry for Gnus +;;; gnus-registry.el --- article registry for Gnus -*- lexical-binding: t; -*- ;; Copyright (C) 2002-2020 Free Software Foundation, Inc. @@ -62,10 +62,10 @@ ;; show the marks as single characters (see the :char property in ;; `gnus-registry-marks'): -;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars) +;; (defalias 'gnus-user-format-function-M #'gnus-registry-article-marks-to-chars) ;; show the marks by name (see `gnus-registry-marks'): -;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names) +;; (defalias 'gnus-user-format-function-M #'gnus-registry-article-marks-to-names) ;; TODO: @@ -485,23 +485,25 @@ This is not required after changing `gnus-registry-cache-file'." (when from (setq entry (cons (delete from (assoc 'group entry)) (assq-delete-all 'group entry)))) - - (dolist (kv `((group ,to) - (sender ,sender) - (recipient ,@recipients) - (subject ,subject))) - (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 (car kv) entry)))))) - (gnus-message 10 "Gnus registry: new entry for %s is %S" - id - entry) - (gnus-registry-insert db id entry))) + ;; Only keep the entry if the message is going to a new group, or + ;; it's still in some previous group. + (when (or to (alist-get 'group entry)) + (dolist (kv `((group ,to) + (sender ,sender) + (recipient ,@recipients) + (subject ,subject))) + (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 (car kv) entry)))))) + (gnus-message 10 "Gnus registry: new entry for %s is %S" + id + entry) + (gnus-registry-insert db id entry)))) ;; Function for nn{mail|imap}-split-fancy: look up all references in ;; the cache and if a match is found, return that group. @@ -588,7 +590,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." subject (< gnus-registry-minimum-subject-length (length subject))) (let ((groups (apply - 'append + #'append (mapcar (lambda (reference) (gnus-registry-get-id-key reference 'group)) @@ -615,7 +617,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." sender gnus-registry-unfollowed-addresses))) (let ((groups (apply - 'append + #'append (mapcar (lambda (reference) (gnus-registry-get-id-key reference 'group)) @@ -644,7 +646,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (not (gnus-grep-in-list recp gnus-registry-unfollowed-addresses))) - (let ((groups (apply 'append + (let ((groups (apply #'append (mapcar (lambda (reference) (gnus-registry-get-id-key reference 'group)) @@ -663,7 +665,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." ;; filter the found groups and return them ;; the found groups are NOT the full groups (setq found (gnus-registry-post-process-groups - "recipients" (mapconcat 'identity recipients ", ") found))) + "recipients" (mapconcat #'identity recipients ", ") found))) ;; after the (cond) we extract the actual value safely (car-safe found))) @@ -791,7 +793,8 @@ Consults `gnus-registry-ignored-groups' and ((stringp g) g) ((and (listp g) (nth 1 g)) (nth 0 g)) - (t nil))) gnus-registry-ignored-groups))) + (t nil))) + gnus-registry-ignored-groups))) ;; only use `gnus-parameter-registry-ignore' if ;; `gnus-registry-ignored-groups' is a list of lists ;; (it can be a list of regexes) @@ -871,7 +874,7 @@ Addresses without a name will say \"noname\"." (defun gnus-registry-sort-addresses (&rest addresses) "Return a normalized and sorted list of ADDRESSES." - (sort (mapcan 'gnus-registry-extract-addresses addresses) 'string-lessp)) + (sort (mapcan #'gnus-registry-extract-addresses addresses) 'string-lessp)) (defun gnus-registry-simplify-subject (subject) (if (stringp subject) @@ -961,16 +964,15 @@ Uses `gnus-registry-marks' to find what shortcuts to install." (intern (format function-format variant-name))) (shortcut (format "%c" (if remove (upcase data) data)))) (defalias function-name - ;; If it weren't for the function's docstring, we could - ;; use a closure, with lexical-let :-( - `(lambda (&rest articles) - ,(format - "%s the %s mark over process-marked ARTICLES." - (upcase-initials variant-name) - mark) - (interactive - (gnus-summary-work-articles current-prefix-arg)) - (gnus-registry--set/remove-mark ',mark ',remove articles))) + (lambda (&rest articles) + (:documentation + (format + "%s the %s mark over process-marked ARTICLES." + (upcase-initials variant-name) + mark)) + (interactive + (gnus-summary-work-articles current-prefix-arg)) + (gnus-registry--set/remove-mark mark remove articles))) (push function-name keys-plist) (push shortcut keys-plist) (push (vector (format "%s %s" @@ -990,14 +992,11 @@ Uses `gnus-registry-marks' to find what shortcuts to install." nil (cons "Registry Marks" gnus-registry-misc-menus)))))) -(make-obsolete 'gnus-registry-user-format-function-M - 'gnus-registry-article-marks-to-chars "24.1") ? - -(defalias 'gnus-registry-user-format-function-M - 'gnus-registry-article-marks-to-chars) +(define-obsolete-function-alias 'gnus-registry-user-format-function-M + #'gnus-registry-article-marks-to-chars "24.1") ;; use like this: -;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars) +;; (defalias 'gnus-user-format-function-M #'gnus-registry-article-marks-to-chars) (defun gnus-registry-article-marks-to-chars (headers) "Show the marks for an article by the :char property." (if gnus-registry-enabled @@ -1013,20 +1012,20 @@ Uses `gnus-registry-marks' to find what shortcuts to install." "")) ;; use like this: -;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names) +;; (defalias 'gnus-user-format-function-M #'gnus-registry-article-marks-to-names) (defun gnus-registry-article-marks-to-names (headers) "Show the marks for an article by name." (if gnus-registry-enabled (let* ((id (mail-header-message-id headers)) (marks (when id (gnus-registry-get-id-key id 'mark)))) - (mapconcat (lambda (mark) (symbol-name mark)) marks ",")) + (mapconcat #'symbol-name marks ",")) "")) (defun gnus-registry-read-mark () "Read a mark name from the user with completion." (let ((mark (gnus-completing-read "Label" - (mapcar 'symbol-name (mapcar 'car gnus-registry-marks)) + (mapcar #'symbol-name (mapcar #'car gnus-registry-marks)) nil nil nil (symbol-name gnus-registry-default-mark)))) (when (stringp mark) @@ -1050,7 +1049,7 @@ Uses `gnus-registry-marks' to find what shortcuts to install." show-message) "Apply or remove MARK across a list of ARTICLES." (let ((article-id-list - (mapcar 'gnus-registry-fetch-message-id-fast articles))) + (mapcar #'gnus-registry-fetch-message-id-fast articles))) (dolist (id article-id-list) (let* ((marks (delq mark (gnus-registry-get-id-key id 'mark))) (marks (if remove marks (cons mark marks)))) @@ -1173,34 +1172,34 @@ only the last one's marks are returned." (gnus-registry-install-shortcuts) (if (gnus-alive-p) (gnus-registry-load) - (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-load))) + (add-hook 'gnus-read-newsrc-el-hook #'gnus-registry-load))) (defun gnus-registry-install-hooks () "Install the registry hooks." (setq gnus-registry-enabled t) - (add-hook 'gnus-summary-article-move-hook 'gnus-registry-action) - (add-hook 'gnus-summary-article-delete-hook 'gnus-registry-action) - (add-hook 'gnus-summary-article-expire-hook 'gnus-registry-action) - (add-hook 'nnmail-spool-hook 'gnus-registry-spool-action) + (add-hook 'gnus-summary-article-move-hook #'gnus-registry-action) + (add-hook 'gnus-summary-article-delete-hook #'gnus-registry-action) + (add-hook 'gnus-summary-article-expire-hook #'gnus-registry-action) + (add-hook 'nnmail-spool-hook #'gnus-registry-spool-action) - (add-hook 'gnus-save-newsrc-hook 'gnus-registry-save) + (add-hook 'gnus-save-newsrc-hook #'gnus-registry-save) - (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)) + (add-hook 'gnus-summary-prepare-hook #'gnus-registry-register-message-ids)) (defun gnus-registry-unload-hook () "Uninstall the registry hooks." - (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action) - (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action) - (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action) - (remove-hook 'nnmail-spool-hook 'gnus-registry-spool-action) + (remove-hook 'gnus-summary-article-move-hook #'gnus-registry-action) + (remove-hook 'gnus-summary-article-delete-hook #'gnus-registry-action) + (remove-hook 'gnus-summary-article-expire-hook #'gnus-registry-action) + (remove-hook 'nnmail-spool-hook #'gnus-registry-spool-action) - (remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save) - (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-load) + (remove-hook 'gnus-save-newsrc-hook #'gnus-registry-save) + (remove-hook 'gnus-read-newsrc-el-hook #'gnus-registry-load) - (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids) + (remove-hook 'gnus-summary-prepare-hook #'gnus-registry-register-message-ids) (setq gnus-registry-enabled nil)) -(add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook) +(add-hook 'gnus-registry-unload-hook #'gnus-registry-unload-hook) (defun gnus-registry-install-p () "Return non-nil if the registry is enabled (and maybe enable it first). @@ -1234,7 +1233,7 @@ data stored in the registry." (seen-groups (list (gnus-group-group-name)))) (catch 'found - (dolist (group (mapcar 'gnus-simplify-group-name groups)) + (dolist (group (mapcar #'gnus-simplify-group-name groups)) ;; skip over any groups we really don't want to warp to. (unless (or (member group seen-groups) @@ -1270,7 +1269,7 @@ EXTRA is a list of symbols. Valid symbols are those contained in the docs of `gnus-registry-track-extra'. This command is useful when you stop tracking some extra data and now want to purge it from your existing entries." - (interactive (list (mapcar 'intern + (interactive (list (mapcar #'intern (completing-read-multiple "Extra data: " '("subject" "sender" "recipient"))))) diff --git a/lisp/gnus/gnus-sieve.el b/lisp/gnus/gnus-sieve.el index 278e3a5d6f3..5d8f9b55deb 100644 --- a/lisp/gnus/gnus-sieve.el +++ b/lisp/gnus/gnus-sieve.el @@ -29,8 +29,6 @@ (require 'gnus) (require 'gnus-sum) -(require 'format-spec) -(autoload 'sieve-mode "sieve-mode") (eval-when-compile (require 'sieve)) @@ -88,10 +86,10 @@ See the documentation for these variables and functions for details." (save-buffer) (shell-command (format-spec gnus-sieve-update-shell-command - (format-spec-make ?f gnus-sieve-file - ?s (or (cadr (gnus-server-get-method - nil gnus-sieve-select-method)) - ""))))) + `((?f . ,gnus-sieve-file) + (?s . ,(or (cadr (gnus-server-get-method + nil gnus-sieve-select-method)) + "")))))) ;;;###autoload (defun gnus-sieve-generate () diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el index d58bd7a73b5..095e05408d6 100644 --- a/lisp/gnus/gnus-srvr.el +++ b/lisp/gnus/gnus-srvr.el @@ -309,7 +309,7 @@ The following commands are available: ;; `gnus-server-buffer' selected as the current buffer, but not always (I ;; bumped into it when starting from a dedicated *Group* frame, and ;; gnus-configure-windows opened *Server* into its own dedicated frame). - (with-current-buffer (get-buffer-create gnus-server-buffer) + (with-current-buffer (gnus-get-buffer-create gnus-server-buffer) (gnus-server-mode) (gnus-server-prepare))) diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el index 61319266ced..873923e6c57 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el @@ -1256,19 +1256,19 @@ INFO-LIST), otherwise it's a list in the format of the `gnus-newsrc-hashtb' entries. LEVEL is the new level of the group, OLDLEVEL is the old level and PREVIOUS is the group (a string name) to insert this group before." - (let (group info active num) - ;; Glean what info we can from the arguments. - (if (consp entry) - (setq group (if fromkilled (nth 1 entry) (car (nth 1 entry)))) - (setq group entry)) + ;; Glean what info we can from the arguments. + (let ((group (if (consp entry) + (if fromkilled (nth 1 entry) (car (nth 1 entry))) + entry)) + info active num) (when (and (stringp entry) oldlevel (< oldlevel gnus-level-zombie)) (setq entry (gnus-group-entry entry))) - (if (and (not oldlevel) - (consp entry)) - (setq oldlevel (gnus-info-level (nth 1 entry))) - (setq oldlevel (or oldlevel gnus-level-killed))) + (setq oldlevel (if (and (not oldlevel) + (consp entry)) + (gnus-info-level (nth 1 entry)) + (or oldlevel gnus-level-killed))) ;; This table is used for completion, so put a dummy entry there. (unless (gethash group gnus-active-hashtb) @@ -2812,7 +2812,7 @@ values from `gnus-newsrc-hashtb', and write a new value of (file-exists-p working-file))) (unwind-protect - (progn + (with-file-modes (file-modes startup-file) (gnus-with-output-to-file working-file (gnus-gnus-to-quick-newsrc-format) (gnus-run-hooks 'gnus-save-quick-newsrc-hook)) @@ -2822,14 +2822,12 @@ values from `gnus-newsrc-hashtb', and write a new value of ;; file. (let ((buffer-backed-up nil) (buffer-file-name startup-file) - (file-precious-flag t) - (setmodes (file-modes startup-file))) + (file-precious-flag t)) ;; 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 (file-attribute-modification-time (file-attributes startup-file))))) @@ -3004,14 +3002,14 @@ SPECIFIC-VARIABLES, or those in `gnus-variable-list'." (defun gnus-slave-save-newsrc () (with-current-buffer gnus-dribble-buffer - (let ((slave-name - (make-temp-file (concat gnus-current-startup-file "-slave-"))) - (modes (ignore-errors - (file-modes (concat gnus-current-startup-file ".eld"))))) - (let ((coding-system-for-write gnus-ding-file-coding-system)) - (gnus-write-buffer slave-name)) - (when modes - (gnus-set-file-modes slave-name modes))))) + (with-file-modes (or (ignore-errors + (file-modes + (concat gnus-current-startup-file ".eld"))) + (default-file-modes)) + (let ((slave-name + (make-temp-file (concat gnus-current-startup-file "-slave-")))) + (let ((coding-system-for-write gnus-ding-file-coding-system)) + (gnus-write-buffer slave-name)))))) (defun gnus-master-read-slave-newsrc () (let ((slave-files diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index 9b11d5878d9..341f04ad772 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -1501,9 +1501,9 @@ the type of the variable (string, integer, character, etc).") ;; This is here rather than in gnus-art for compilation reasons. (defvar gnus-article-mode-line-format-alist - (nconc '((?w (gnus-article-wash-status) ?s) - (?m (gnus-article-mime-part-status) ?s)) - gnus-summary-mode-line-format-alist)) + (append '((?w (gnus-article-wash-status) ?s) + (?m (gnus-article-mime-part-status) ?s)) + gnus-summary-mode-line-format-alist)) (defvar gnus-last-search-regexp nil "Default regexp for article search command.") @@ -9493,16 +9493,6 @@ The 1st element is the button named by `gnus-collect-urls-primary-text'." (push primary urls)) (delete-dups urls))) -;; cf. `ediff-truncate-string-left', to become `string-truncate-left' -;; in Emacs 28 -(defun gnus--string-truncate-left (string length) - "Truncate STRING to LENGTH, replacing initial surplus with \"...\"." - (let ((strlen (length string))) - (if (<= strlen length) - string - (setq length (max 0 (- length 3))) - (concat "..." (substring string (max 0 (- strlen 1 length))))))) - (defun gnus-shorten-url (url max) "Return an excerpt from URL not exceeding MAX characters." (if (<= (length url) max) @@ -9512,7 +9502,7 @@ The 1st element is the button named by `gnus-collect-urls-primary-text'." (rest (concat (url-filename parsed) (when-let ((target (url-target parsed))) (concat "#" target))))) - (concat host (gnus--string-truncate-left rest (- max (length host))))))) + (concat host (string-truncate-left rest (- max (length host))))))) (defun gnus-summary-browse-url (&optional external) "Scan the current article body for links, and offer to browse them. @@ -12320,7 +12310,7 @@ no matter what the properties `:decode' and `:headers' are." (buffer-string)))))) (put 'gnus-summary-save-in-pipe :headers headers)) (unless (zerop (length result)) - (if (with-current-buffer (get-buffer-create result-buffer) + (if (with-current-buffer (gnus-get-buffer-create result-buffer) (erase-buffer) (insert result) (prog1 @@ -12508,7 +12498,7 @@ save those articles instead." (gnus-activate-group to-newsgroup nil nil to-method) (gnus-subscribe-group to-newsgroup)) (error "Couldn't create group %s" to-newsgroup))) - (error "No such group: %s" to-newsgroup)) + (user-error "No such group: %s" to-newsgroup)) to-newsgroup))) (defvar gnus-summary-save-parts-counter) diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index 3429d6560b7..8d8956f1fb9 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -768,7 +768,7 @@ nil. See also `gnus-bind-print-variables'." If there's no subdirectory, delete DIRECTORY as well." (when (file-directory-p directory) (let ((files (directory-files - directory t (rx (or (not ".") "...")))) + directory t directory-files-no-dot-files-regexp)) file dir) (while files (setq file (pop files)) @@ -950,7 +950,7 @@ FILENAME exists and is Babyl format." (setq rmail-default-rmail-file filename) ; 22 (setq rmail-default-file filename)) ; 23 (let ((artbuf (current-buffer)) - (tmpbuf (get-buffer-create " *Gnus-output*")) + (tmpbuf (gnus-get-buffer-create " *Gnus-output*")) ;; Babyl rmail.el defines this, mbox does not. (babyl (fboundp 'rmail-insert-rmail-file-header))) (save-excursion @@ -1036,7 +1036,7 @@ FILENAME exists and is Babyl format." (require 'nnmail) (setq filename (expand-file-name filename)) (let ((artbuf (current-buffer)) - (tmpbuf (get-buffer-create " *Gnus-output*"))) + (tmpbuf (gnus-get-buffer-create " *Gnus-output*"))) (save-excursion ;; Create the file, if it doesn't exist. (when (and (not (get-file-buffer filename)) @@ -1457,7 +1457,7 @@ CHOICE is a list of the choice char and help message at IDX." (setq tchar (read-char)) (when (not (assq tchar choice)) (setq tchar nil) - (setq buf (get-buffer-create "*Gnus Help*")) + (setq buf (gnus-get-buffer-create "*Gnus Help*")) (pop-to-buffer buf) (fundamental-mode) (buffer-disable-undo) @@ -1601,10 +1601,10 @@ empty directories from OLD-PATH." (file-truename (concat old-dir ".."))))))))) -(defun gnus-set-file-modes (filename mode) +(defun gnus-set-file-modes (filename mode &optional flag) "Wrapper for set-file-modes." (ignore-errors - (set-file-modes filename mode))) + (set-file-modes filename mode flag))) (defun gnus-rescale-image (image size) "Rescale IMAGE to SIZE if possible. diff --git a/lisp/gnus/gnus-uu.el b/lisp/gnus/gnus-uu.el index 5902f2b37a7..70aeac00d7f 100644 --- a/lisp/gnus/gnus-uu.el +++ b/lisp/gnus/gnus-uu.el @@ -1674,7 +1674,7 @@ Gnus might fail to display all of it.") did-unpack)) (defun gnus-uu-dir-files (dir) - (let ((dirs (directory-files dir t (rx (or (not ".") "...")))) + (let ((dirs (directory-files dir t directory-files-no-dot-files-regexp)) files file) (while dirs (if (file-directory-p (setq file (car dirs))) @@ -1781,8 +1781,8 @@ Gnus might fail to display all of it.") gnus-uu-tmp-dir))) (setq gnus-uu-work-dir - (make-temp-file (concat gnus-uu-tmp-dir "gnus") 'dir)) - (gnus-set-file-modes gnus-uu-work-dir 448) + (with-file-modes #o700 + (make-temp-file (concat gnus-uu-tmp-dir "gnus") 'dir))) (setq gnus-uu-work-dir (file-name-as-directory gnus-uu-work-dir)) (push (cons gnus-newsgroup-name gnus-uu-work-dir) gnus-uu-tmp-alist)))) diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index 6df26b4af8c..caeab7f55af 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -660,7 +660,7 @@ be used directly.") (defun gnus-add-buffer () "Add the current buffer to the list of Gnus buffers." (gnus-prune-buffers) - (push (current-buffer) gnus-buffers)) + (cl-pushnew (current-buffer) gnus-buffers)) (defmacro gnus-kill-buffer (buffer) "Kill BUFFER and remove from the list of Gnus buffers." diff --git a/lisp/gnus/gssapi.el b/lisp/gnus/gssapi.el index 218a1542e3a..485d58ad94e 100644 --- a/lisp/gnus/gssapi.el +++ b/lisp/gnus/gssapi.el @@ -25,8 +25,6 @@ ;;; Code: -(require 'format-spec) - (defcustom gssapi-program (list (concat "gsasl %s %p " "--mechanism GSSAPI " @@ -53,12 +51,9 @@ tried until a successful connection is made." (coding-system-for-write 'binary) (process (start-process name buffer shell-file-name shell-command-switch - (format-spec - cmd - (format-spec-make - ?s server - ?p (number-to-string port) - ?l user)))) + (format-spec cmd `((?s . ,server) + (?p . ,(number-to-string port)) + (?l . ,user))))) response) (when process (while (and (memq (process-status process) '(open run)) diff --git a/lisp/gnus/mail-source.el b/lisp/gnus/mail-source.el index 52343d4fa37..43180726c45 100644 --- a/lisp/gnus/mail-source.el +++ b/lisp/gnus/mail-source.el @@ -24,7 +24,6 @@ ;;; Code: -(require 'format-spec) (eval-when-compile (require 'cl-lib) (require 'imap)) @@ -695,7 +694,7 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) mail-source-movemail-program nil errors nil from to))))) (when (file-exists-p to) - (set-file-modes to mail-source-default-file-modes)) + (set-file-modes to mail-source-default-file-modes 'nofollow)) (if (and (or (not (buffer-modified-p errors)) (zerop (buffer-size errors))) (and (numberp result) @@ -740,9 +739,11 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) (when delay (sleep-for delay))) +(declare-function gnus-get-buffer-create "gnus" (name)) (defun mail-source-call-script (script) + (require 'gnus) (let ((background nil) - (stderr (get-buffer-create " *mail-source-stderr*")) + (stderr (gnus-get-buffer-create " *mail-source-stderr*")) result) (when (string-match "& *$" script) (setq script (substring script 0 (match-beginning 0)) @@ -767,14 +768,14 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) "Fetcher for single-file sources." (mail-source-bind (file source) (mail-source-run-script - prescript (format-spec-make ?t mail-source-crash-box) + prescript `((?t . ,mail-source-crash-box)) prescript-delay) (let ((mail-source-string (format "file:%s" path))) (if (mail-source-movemail path mail-source-crash-box) (prog1 (mail-source-callback callback path) (mail-source-run-script - postscript (format-spec-make ?t mail-source-crash-box)) + postscript `((?t . ,mail-source-crash-box))) (mail-source-delete-crash-box)) 0)))) @@ -782,7 +783,7 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) "Fetcher for directory sources." (mail-source-bind (directory source) (mail-source-run-script - prescript (format-spec-make ?t path) prescript-delay) + prescript `((?t . ,path)) prescript-delay) (let ((found 0) (mail-source-string (format "directory:%s" path))) (dolist (file (directory-files @@ -791,7 +792,7 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) (funcall predicate file) (mail-source-movemail file mail-source-crash-box)) (cl-incf found (mail-source-callback callback file)) - (mail-source-run-script postscript (format-spec-make ?t path)) + (mail-source-run-script postscript `((?t . ,path))) (mail-source-delete-crash-box))) found))) @@ -801,8 +802,8 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) ;; fixme: deal with stream type in format specs (mail-source-run-script prescript - (format-spec-make ?p password ?t mail-source-crash-box - ?s server ?P port ?u user) + `((?p . ,password) (?t . ,mail-source-crash-box) + (?s . ,server) (?P . ,port) (?u . ,user)) prescript-delay) (let ((from (format "%s:%s:%s" server user port)) (mail-source-string (format "pop:%s@%s" user server)) @@ -823,8 +824,8 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) (mail-source-fetch-with-program (format-spec program - (format-spec-make ?p password ?t mail-source-crash-box - ?s server ?P port ?u user)))) + `((?p . ,password) (?t . ,mail-source-crash-box) + (?s . ,server) (?P . ,port) (?u . ,user))))) (function (funcall function mail-source-crash-box)) ;; The default is to use pop3.el. @@ -861,8 +862,8 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) (setq mail-source-new-mail-available nil)) (mail-source-run-script postscript - (format-spec-make ?p password ?t mail-source-crash-box - ?s server ?P port ?u user)) + `((?p . ,password) (?t . ,mail-source-crash-box) + (?s . ,server) (?P . ,port) (?u . ,user))) (mail-source-delete-crash-box))) ;; We nix out the password in case the error ;; was because of a wrong password being given. @@ -1075,8 +1076,9 @@ This only works when `display-time' is enabled." "Fetcher for imap sources." (mail-source-bind (imap source) (mail-source-run-script - prescript (format-spec-make ?p password ?t mail-source-crash-box - ?s server ?P port ?u user) + prescript + `((?p . ,password) (?t . ,mail-source-crash-box) + (?s . ,server) (?P . ,port) (?u . ,user)) prescript-delay) (let ((from (format "%s:%s:%s" server user port)) (found 0) @@ -1141,8 +1143,8 @@ This only works when `display-time' is enabled." (kill-buffer buf) (mail-source-run-script postscript - (format-spec-make ?p password ?t mail-source-crash-box - ?s server ?P port ?u user)) + `((?p . ,password) (?t . ,mail-source-crash-box) + (?s . ,server) (?P . ,port) (?u . ,user))) found))) (provide 'mail-source) diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index cbdd329f3ec..fb560f0eab8 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -42,13 +42,12 @@ (require 'mail-parse) (require 'mml) (require 'rfc822) -(require 'format-spec) (require 'dired) (require 'mm-util) (require 'rfc2047) (require 'puny) -(require 'rmc) ; read-multiple-choice -(eval-when-compile (require 'subr-x)) ; when-let* +(require 'rmc) ; read-multiple-choice +(eval-when-compile (require 'subr-x)) (autoload 'mailclient-send-it "mailclient") @@ -215,9 +214,9 @@ Also see `message-required-news-headers' and :link '(custom-manual "(message)Message Headers") :type '(repeat sexp)) -(defcustom message-draft-headers '(References From Date) +(defcustom message-draft-headers '(References From) "Headers to be generated when saving a draft message." - :version "22.1" + :version "28.1" :group 'message-news :group 'message-headers :link '(custom-manual "(message)Message Headers") @@ -322,7 +321,7 @@ used." :group 'message-various) (defcustom message-subject-trailing-was-ask-regexp - "[ \t]*\\([[(]+[Ww][Aa][Ss]:?[ \t]*.*[])]+\\)" + "[ \t]*\\([[(]+[Ww][Aa][Ss].*[])]+\\)" "Regexp matching \"(was: <old subject>)\" in the subject line. The function `message-strip-subject-trailing-was' uses this regexp if @@ -337,7 +336,7 @@ It is okay to create some false positives here, as the user is asked." :type 'regexp) (defcustom message-subject-trailing-was-regexp - "[ \t]*\\((*[Ww][Aa][Ss]:[ \t]*.*)\\)" + "[ \t]*\\((*[Ww][Aa][Ss]:.*)\\)" "Regexp matching \"(was: <old subject>)\" in the subject line. If `message-subject-trailing-was-query' is set to t, the subject is @@ -440,8 +439,8 @@ whitespace)." (defcustom message-elide-ellipsis "\n[...]\n\n" "The string which is inserted for elided text. -This is a format-spec string, and you can use %l to say how many -lines were removed, and %c to say how many characters were +This is a `format-spec' string, and you can use %l to say how +many lines were removed, and %c to say how many characters were removed." :type 'string :link '(custom-manual "(message)Various Commands") @@ -1986,6 +1985,7 @@ You must have the \"hashcash\" binary installed, see `hashcash-path'." (autoload 'gnus-delay-article "gnus-delay") (autoload 'gnus-extract-address-components "gnus-util") (autoload 'gnus-find-method-for-group "gnus") +(autoload 'gnus-get-buffer-create "gnus") (autoload 'gnus-group-name-charset "gnus-group") (autoload 'gnus-group-name-decode "gnus-group") (autoload 'gnus-groups-from-server "gnus") @@ -3976,7 +3976,6 @@ This function uses `mail-citation-hook' if that is non-nil." "Cite function in the standard Message manner." (message-cite-original-1 nil)) -(autoload 'format-spec "format-spec") (autoload 'gnus-date-get-time "gnus-util") (defun message-insert-formatted-citation-line (&optional from date tz) @@ -4001,20 +4000,18 @@ See `message-citation-line-format'." (when (or message-reply-headers (and from date)) (unless from (setq from (mail-header-from message-reply-headers))) - (let* ((data (condition-case () - (funcall (if (boundp 'gnus-extract-address-components) - gnus-extract-address-components - 'mail-extract-address-components) - from) - (error nil))) + (let* ((data (ignore-errors + (funcall (or (bound-and-true-p + gnus-extract-address-components) + #'mail-extract-address-components) + from))) (name (car data)) (fname name) (lname name) - (net (car (cdr data))) - (name-or-net (or (car data) - (car (cdr data)) from)) + (net (cadr data)) + (name-or-net (or name net from)) (time - (when (string-match "%[^fnNFL]" message-citation-line-format) + (when (string-match-p "%[^FLNfn]" message-citation-line-format) (cond ((numberp (car-safe date)) date) ;; backward compatibility (date (gnus-date-get-time date)) (t @@ -4023,68 +4020,53 @@ See `message-citation-line-format'." (tz (or tz (when (stringp date) (nth 8 (parse-time-string date))))) - (flist - (let ((i ?A) lst) - (when (stringp name) - ;; Guess first name and last name: - (let* ((names (delq - nil - (mapcar - (lambda (x) - (if (string-match "\\`\\(\\w\\|[-.]\\)+\\'" - x) - x - nil)) - (split-string name "[ \t]+")))) - (count (length names))) - (cond ((= count 1) - (setq fname (car names) - lname "")) - ((or (= count 2) (= count 3)) - (setq fname (car names) - lname (mapconcat 'identity (cdr names) " "))) - ((> count 3) - (setq fname (mapconcat 'identity - (butlast names (- count 2)) - " ") - lname (mapconcat 'identity - (nthcdr 2 names) - " ")))) - (when (string-match "\\(.*\\),\\'" fname) - (let ((newlname (match-string 1 fname))) - (setq fname lname lname newlname))))) - ;; The following letters are not used in `format-time-string': - (push ?E lst) (push "<E>" lst) - (push ?F lst) (push (or fname name-or-net) lst) - ;; We might want to use "" instead of "<X>" later. - (push ?J lst) (push "<J>" lst) - (push ?K lst) (push "<K>" lst) - (push ?L lst) (push lname lst) - (push ?N lst) (push name-or-net lst) - (push ?O lst) (push "<O>" lst) - (push ?P lst) (push "<P>" lst) - (push ?Q lst) (push "<Q>" lst) - (push ?f lst) (push from lst) - (push ?i lst) (push "<i>" lst) - (push ?n lst) (push net lst) - (push ?o lst) (push "<o>" lst) - (push ?q lst) (push "<q>" lst) - (push ?t lst) (push "<t>" lst) - (push ?v lst) (push "<v>" lst) - ;; Delegate the rest to `format-time-string': - (while (<= i ?z) - (when (and (not (memq i lst)) - ;; Skip (Z,a) - (or (<= i ?Z) - (>= i ?a))) - (push i lst) - (push (condition-case nil - (format-time-string (format "%%%c" i) time tz) - (error (format ">%c<" i))) - lst)) - (setq i (1+ i))) - (reverse lst))) - (spec (apply 'format-spec-make flist))) + spec) + (when (stringp name) + ;; Guess first name and last name: + (let* ((names (seq-filter + (lambda (s) + (string-match-p (rx bos (+ (in word ?. ?-)) eos) s)) + (split-string name "[ \t]+"))) + (count (length names))) + (cond ((= count 1) + (setq fname (car names) + lname "")) + ((or (= count 2) (= count 3)) + (setq fname (car names) + lname (string-join (cdr names) " "))) + ((> count 3) + (setq fname (string-join (butlast names (- count 2)) + " ") + lname (string-join (nthcdr 2 names) " ")))) + (when (string-match "\\(.*\\),\\'" fname) + (let ((newlname (match-string 1 fname))) + (setq fname lname lname newlname))))) + ;; The following letters are not used in `format-time-string': + (push (cons ?E "<E>") spec) + (push (cons ?F (or fname name-or-net)) spec) + ;; We might want to use "" instead of "<X>" later. + (push (cons ?J "<J>") spec) + (push (cons ?K "<K>") spec) + (push (cons ?L lname) spec) + (push (cons ?N name-or-net) spec) + (push (cons ?O "<O>") spec) + (push (cons ?P "<P>") spec) + (push (cons ?Q "<Q>") spec) + (push (cons ?f from) spec) + (push (cons ?i "<i>") spec) + (push (cons ?n net) spec) + (push (cons ?o "<o>") spec) + (push (cons ?q "<q>") spec) + (push (cons ?t "<t>") spec) + (push (cons ?v "<v>") spec) + ;; Delegate the rest to `format-time-string': + (dolist (c (nconc (number-sequence ?A ?Z) + (number-sequence ?a ?z))) + (unless (assq c spec) + (push (cons c (condition-case nil + (format-time-string (format "%%%c" c) time tz) + (error (format ">%c<" c)))) + spec))) (insert (format-spec message-citation-line-format spec))) (newline))) @@ -7310,7 +7292,7 @@ If ARG, allow editing of the cancellation message." ;; Make control message. (if arg (message-news) - (setq buf (set-buffer (get-buffer-create " *message cancel*")))) + (setq buf (set-buffer (gnus-get-buffer-create " *message cancel*")))) (erase-buffer) (insert "Newsgroups: " newsgroups "\n" "From: " from "\n" @@ -7731,7 +7713,7 @@ is for the internal use." gcc beg) ;; We first set up a normal mail buffer. (unless (message-mail-user-agent) - (set-buffer (get-buffer-create " *message resend*")) + (set-buffer (gnus-get-buffer-create " *message resend*")) (let ((inhibit-read-only t)) (erase-buffer))) (let ((message-this-is-mail t) @@ -7983,7 +7965,7 @@ See `gmm-tool-bar-from-list' for details on the format of the list." (defcustom message-tool-bar-retro '(;; Old Emacs 21 icon for consistency. - (message-send-and-exit "gnus/mail-send") + (message-send-and-exit "mail/send") (message-kill-buffer "close") (message-dont-send "cancel") (mml-attach-file "attach" mml-mode-map) diff --git a/lisp/gnus/mm-archive.el b/lisp/gnus/mm-archive.el index 6b4308e9790..56253afa193 100644 --- a/lisp/gnus/mm-archive.el +++ b/lisp/gnus/mm-archive.el @@ -24,6 +24,7 @@ (require 'mm-decode) (autoload 'gnus-recursive-directory-files "gnus-util") +(autoload 'gnus-get-buffer-create "gnus") (autoload 'mailcap-extension-to-mime "mailcap") (defvar mm-archive-decoders @@ -41,8 +42,9 @@ dir) (unless decoder (error "No decoder found for %s" type)) - (setq dir (make-temp-file (expand-file-name "emm." mm-tmp-directory) 'dir)) - (set-file-modes dir #o700) + (with-file-modes #o700 + (setq dir (make-temp-file (expand-file-name "emm." mm-tmp-directory) + 'dir))) (unwind-protect (progn (mm-with-unibyte-buffer @@ -56,7 +58,7 @@ (append (cdr decoder) (list dir))) (delete-file file)) (apply 'call-process-region (point-min) (point-max) (car decoder) - nil (get-buffer-create "*tnef*") + nil (gnus-get-buffer-create "*tnef*") nil (append (cdr decoder) (list dir))))) `("multipart/mixed" ,handle diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el index d33bb56dc9e..96695aabfde 100644 --- a/lisp/gnus/mm-decode.el +++ b/lisp/gnus/mm-decode.el @@ -602,11 +602,10 @@ files left at the next time." (push temp fails))) (if fails ;; Schedule the deletion of the files left at the next time. - (progn + (with-file-modes #o600 (write-region (concat (mapconcat 'identity (nreverse fails) "\n") "\n") - nil cache-file nil 'silent) - (set-file-modes cache-file #o600)) + nil cache-file nil 'silent)) (when (file-exists-p cache-file) (ignore-errors (delete-file cache-file)))) (setq mm-temp-files-to-be-deleted nil))) @@ -911,8 +910,10 @@ external if displayed external." ;; The function is a string to be executed. (mm-insert-part handle) (mm-add-meta-html-tag handle) - (let* ((dir (make-temp-file - (expand-file-name "emm." mm-tmp-directory) 'dir)) + ;; We create a private sub-directory where we store our files. + (let* ((dir (with-file-modes #o700 + (make-temp-file + (expand-file-name "emm." mm-tmp-directory) 'dir))) (filename (or (mail-content-type-get (mm-handle-disposition handle) 'filename) @@ -924,8 +925,6 @@ external if displayed external." (assoc "needsterminal" mime-info))) (copiousoutput (assoc "copiousoutput" mime-info)) file buffer) - ;; We create a private sub-directory where we store our files. - (set-file-modes dir #o700) (if filename (setq file (expand-file-name (gnus-map-function mm-file-name-rewrite-functions @@ -941,14 +940,15 @@ external if displayed external." ;; `mailcap-mime-extensions'. (setq suffix (car (rassoc (mm-handle-media-type handle) mailcap-mime-extensions)))) - (setq file (make-temp-file (expand-file-name "mm." dir) - nil suffix)))) + (setq file (with-file-modes #o600 + (make-temp-file (expand-file-name "mm." dir) + nil suffix))))) (let ((coding-system-for-write mm-binary-coding-system)) (write-region (point-min) (point-max) file nil 'nomesg)) ;; The file is deleted after the viewer exists. If the users edits ;; the file, changes will be lost. Set file to read-only to make it ;; clear. - (set-file-modes file #o400) + (set-file-modes file #o400 'nofollow) (message "Viewing with %s" method) (cond (needsterm diff --git a/lisp/gnus/mm-uu.el b/lisp/gnus/mm-uu.el index e6fdc93da24..aedd6c948c2 100644 --- a/lisp/gnus/mm-uu.el +++ b/lisp/gnus/mm-uu.el @@ -192,7 +192,7 @@ This can be either \"inline\" or \"attachment\".") ,(lambda () (mm-uu-verbatim-marks-extract 0 0)) nil) (LaTeX - "^\\([\\\\%][^\n]+\n\\)*\\\\documentclass.*[[{%]" + "^\\([\\%][^\n]+\n\\)*\\\\documentclass.*[[{%]" "^\\\\end{document}" ,#'mm-uu-latex-extract nil @@ -251,19 +251,23 @@ The value should be nil on displays where the face (((type tty) (class color) (background dark)) - (:background "dark blue")) + (:background "dark blue" + :extend t)) (((class color) (background dark)) (:foreground "light yellow" - :background "dark green")) + :background "dark green" + :extend t)) (((type tty) (class color) (background light)) - (:foreground "dark blue")) + (:foreground "dark blue" + :extend t)) (((class color) (background light)) (:foreground "dark green" - :background "light yellow")) + :background "light yellow" + :extend t)) (t ())) "Face for extracted buffers." diff --git a/lisp/gnus/mml-smime.el b/lisp/gnus/mml-smime.el index 3cc463d5d4c..4754f37a2da 100644 --- a/lisp/gnus/mml-smime.el +++ b/lisp/gnus/mml-smime.el @@ -154,14 +154,9 @@ Whether the passphrase is cached at all is controlled by (write-region (point-min) (point-max) file)) (push file certfiles) (push file tmpfiles))) - (if (smime-encrypt-buffer certfiles) - (progn - (while (setq tmp (pop tmpfiles)) - (delete-file tmp)) - t) - (while (setq tmp (pop tmpfiles)) - (delete-file tmp)) - nil)) + (smime-encrypt-buffer certfiles) + (while (setq tmp (pop tmpfiles)) + (delete-file tmp))) (goto-char (point-max))) (defvar gnus-extract-address-components) diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el index 556cf0804a5..21491499eb8 100644 --- a/lisp/gnus/mml.el +++ b/lisp/gnus/mml.el @@ -487,11 +487,8 @@ type detected." (= (length cont) 1) content-type) (setcdr (assq 'type (cdr (car cont))) content-type)) - (when (and (consp (car cont)) - (= (length cont) 1) - (fboundp 'libxml-parse-html-region) - (equal (cdr (assq 'type (car cont))) "text/html")) - (setq cont (mml-expand-html-into-multipart-related (car cont)))) + (when (fboundp 'libxml-parse-html-region) + (setq cont (mapcar 'mml-expand-all-html-into-multipart-related cont))) (prog1 (with-temp-buffer (set-buffer-multibyte nil) @@ -510,6 +507,18 @@ type detected." (buffer-string)) (setq message-options options))))) +(defun mml-expand-all-html-into-multipart-related (cont) + (cond ((and (eq (car cont) 'part) + (equal (cdr (assq 'type cont)) "text/html")) + (mml-expand-html-into-multipart-related cont)) + ((eq (car cont) 'multipart) + (let ((cur (cdr cont))) + (while (consp cur) + (setcar cur (mml-expand-all-html-into-multipart-related (car cur))) + (setf cur (cdr cur)))) + cont) + (t cont))) + (defun mml-expand-html-into-multipart-related (cont) (let ((new-parts nil) (cid 1)) @@ -538,8 +547,7 @@ type detected." new-parts)) (setq cid (1+ cid))))))) ;; We have local images that we want to include. - (if (not new-parts) - (list cont) + (when new-parts (setcdr (assq 'contents cont) (buffer-string)) (setq cont (nconc (list 'multipart (cons 'type "related")) @@ -552,8 +560,8 @@ type detected." (nth 1 new-part) (nth 2 new-part)) (id . ,(concat "<" (nth 0 new-part) - ">"))))))) - cont)))) + ">")))))))) + cont))) (autoload 'image-property "image") diff --git a/lisp/gnus/mml2015.el b/lisp/gnus/mml2015.el index 1e72f681797..d1d150ad2ee 100644 --- a/lisp/gnus/mml2015.el +++ b/lisp/gnus/mml2015.el @@ -293,6 +293,8 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." (substring alg (match-end 0)) alg)))) +(autoload 'gnus-get-buffer-create "gnus") + (defun mml2015-mailcrypt-verify (handle ctl) (catch 'error (let (part) @@ -330,7 +332,7 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." (replace-match "-----BEGIN PGP SIGNATURE-----" t t)) (if (re-search-forward "^-----END PGP [^-]+-----\r?$" nil t) (replace-match "-----END PGP SIGNATURE-----" t t))) - (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*"))) + (let ((mc-gpg-debug-buffer (gnus-get-buffer-create " *gnus gpg debug*"))) (unless (condition-case err (prog1 (funcall mml2015-verify-function) @@ -359,7 +361,7 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." handle))) (defun mml2015-mailcrypt-clear-verify () - (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*"))) + (let ((mc-gpg-debug-buffer (gnus-get-buffer-create " *gnus gpg debug*"))) (if (condition-case err (prog1 (funcall mml2015-verify-function) @@ -725,6 +727,8 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." (autoload 'epg-expand-group "epg-config") (autoload 'epa-select-keys "epa") +(autoload 'gnus-create-image "gnus-util") + (defun mml2015-epg-key-image (key-id) "Return the image of a key, if any." (with-temp-buffer @@ -949,7 +953,6 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." ;;; General wrapper (autoload 'gnus-buffer-live-p "gnus-util") -(autoload 'gnus-get-buffer-create "gnus") (defun mml2015-clean-buffer () (if (gnus-buffer-live-p mml2015-result-buffer) diff --git a/lisp/gnus/nnbabyl.el b/lisp/gnus/nnbabyl.el index 6890f1dceeb..480d794b9ac 100644 --- a/lisp/gnus/nnbabyl.el +++ b/lisp/gnus/nnbabyl.el @@ -293,7 +293,7 @@ (deffoo nnbabyl-request-move-article (article group server accept-form &optional last move-is-internal) - (let ((buf (get-buffer-create " *nnbabyl move*")) + (let ((buf (gnus-get-buffer-create " *nnbabyl move*")) result) (and (nnbabyl-request-article article group server) @@ -544,7 +544,7 @@ (setq buffer-file-name nnbabyl-mbox-file) (insert "BABYL OPTIONS:\n\n\^_") (nnmail-write-region - (point-min) (point-max) nnbabyl-mbox-file t 'nomesg)))) + (point-min) (point-max) nnbabyl-mbox-file t 'nomesg nil 'excl)))) (defun nnbabyl-read-mbox () (nnmail-activate 'nnbabyl) diff --git a/lisp/gnus/nndiary.el b/lisp/gnus/nndiary.el index 24a3df1e27a..945ef0351e5 100644 --- a/lisp/gnus/nndiary.el +++ b/lisp/gnus/nndiary.el @@ -597,7 +597,7 @@ all. This may very well take some time.") (deffoo nndiary-request-move-article (article group server accept-form &optional last move-is-internal) - (let ((buf (get-buffer-create " *nndiary move*")) + (let ((buf (gnus-get-buffer-create " *nndiary move*")) result) (nndiary-possibly-change-directory group server) (nndiary-update-file-alist) @@ -831,7 +831,7 @@ all. This may very well take some time.") ;; Find an article number in the current group given the Message-ID. (defun nndiary-find-group-number (id) - (with-current-buffer (get-buffer-create " *nndiary id*") + (with-current-buffer (gnus-get-buffer-create " *nndiary id*") (let ((alist nndiary-group-alist) number) ;; We want to look through all .overview files, but we want to @@ -999,8 +999,8 @@ all. This may very well take some time.") (defun nndiary-open-nov (group) (or (cdr (assoc group nndiary-nov-buffer-alist)) - (let ((buffer (get-buffer-create (format " *nndiary overview %s*" - group)))) + (let ((buffer (gnus-get-buffer-create + (format " *nndiary overview %s*" group)))) (with-current-buffer buffer (set (make-local-variable 'nndiary-nov-buffer-file-name) (expand-file-name @@ -1086,7 +1086,7 @@ all. This may very well take some time.") (defun nndiary-generate-nov-file (dir files) (let* ((dir (file-name-as-directory dir)) (nov (concat dir nndiary-nov-file-name)) - (nov-buffer (get-buffer-create " *nov*")) + (nov-buffer (gnus-get-buffer-create " *nov*")) chars file headers) ;; Init the nov buffer. (with-current-buffer nov-buffer @@ -1115,7 +1115,7 @@ all. This may very well take some time.") (widen)) (setq files (cdr files))) (with-current-buffer nov-buffer - (nnmail-write-region 1 (point-max) nov nil 'nomesg) + (nnmail-write-region 1 (point-max) nov nil 'nomesg nil 'excl) (kill-buffer (current-buffer)))))) (defun nndiary-nov-delete-article (group article) diff --git a/lisp/gnus/nndoc.el b/lisp/gnus/nndoc.el index 0ba63915c94..36b67a8fd13 100644 --- a/lisp/gnus/nndoc.el +++ b/lisp/gnus/nndoc.el @@ -347,7 +347,7 @@ from the document.") (file-exists-p nndoc-address) (not (file-directory-p nndoc-address)))) (push (cons group (setq nndoc-current-buffer - (get-buffer-create + (gnus-get-buffer-create (concat " *nndoc " group "*")))) nndoc-group-alist) (setq nndoc-dissection-alist nil) diff --git a/lisp/gnus/nndraft.el b/lisp/gnus/nndraft.el index a1337e8d7fa..a3c26ea4ac0 100644 --- a/lisp/gnus/nndraft.el +++ b/lisp/gnus/nndraft.el @@ -231,7 +231,7 @@ are generated if and only if they are also in `message-draft-headers'." (deffoo nndraft-request-move-article (article group server accept-form &optional last move-is-internal) (nndraft-possibly-change-group group) - (let ((buf (get-buffer-create " *nndraft move*")) + (let ((buf (gnus-get-buffer-create " *nndraft move*")) result) (and (nndraft-request-article article group server) @@ -325,7 +325,7 @@ are generated if and only if they are also in `message-draft-headers'." (save-excursion (prog1 (progn - (set-buffer (get-buffer-create " *draft tmp*")) + (set-buffer (gnus-get-buffer-create " *draft tmp*")) (setq buffer-file-name file) (make-auto-save-file-name)) (kill-buffer (current-buffer))))) diff --git a/lisp/gnus/nneething.el b/lisp/gnus/nneething.el index 9e190515f18..9f1fdbae5ae 100644 --- a/lisp/gnus/nneething.el +++ b/lisp/gnus/nneething.el @@ -381,7 +381,7 @@ included.") (defun nneething-get-head (file) "Either find the head in FILE or make a head for FILE." - (with-current-buffer (get-buffer-create nneething-work-buffer) + (with-current-buffer (gnus-get-buffer-create nneething-work-buffer) (setq case-fold-search nil) (buffer-disable-undo) (erase-buffer) diff --git a/lisp/gnus/nnfolder.el b/lisp/gnus/nnfolder.el index 342ac48ba85..c27af1742d8 100644 --- a/lisp/gnus/nnfolder.el +++ b/lisp/gnus/nnfolder.el @@ -465,7 +465,7 @@ all. This may very well take some time.") (deffoo nnfolder-request-move-article (article group server accept-form &optional last move-is-internal) (save-excursion - (let ((buf (get-buffer-create " *nnfolder move*")) + (let ((buf (gnus-get-buffer-create " *nnfolder move*")) result) (and (nnfolder-request-article article group server) @@ -735,7 +735,7 @@ deleted. Point is left where the deleted region was." (or nnfolder-file-coding-system-for-write nnfolder-file-coding-system-for-write))) (nnmail-write-region (point-min) (point-min) - file t 'nomesg))) + file t 'nomesg nil 'excl))) (when (setq nnfolder-current-buffer (nnfolder-read-folder group)) (set-buffer nnfolder-current-buffer) (push (list group nnfolder-current-buffer) @@ -1096,7 +1096,7 @@ This command does not work if you use short group names." (defun nnfolder-open-nov (group) (or (cdr (assoc group nnfolder-nov-buffer-alist)) - (let ((buffer (get-buffer-create (format " *nnfolder overview %s*" group)))) + (let ((buffer (gnus-get-buffer-create (format " *nnfolder overview %s*" group)))) (with-current-buffer buffer (set (make-local-variable 'nnfolder-nov-buffer-file-name) (nnfolder-group-nov-pathname group)) diff --git a/lisp/gnus/nnheader.el b/lisp/gnus/nnheader.el index 03b08854b11..fee7a169ff9 100644 --- a/lisp/gnus/nnheader.el +++ b/lisp/gnus/nnheader.el @@ -209,7 +209,7 @@ on your system, you could say something like: ;; about twice as fast, even though it looks messier. You ;; can't have everything, I guess. Speed and elegance don't ;; always go hand in hand. - (vector + (make-full-mail-header ;; Number. (or number 0) ;; Subject. @@ -487,8 +487,8 @@ the line could be found." (< num article))) (forward-line 1) (setq found (point)) - (or (eobp) - (= (setq num (read cur)) article))) + (unless (eobp) + (setq num (read cur)))) (unless (eq num article) (goto-char found))) (beginning-of-line) @@ -502,10 +502,12 @@ the line could be found." "Coding system used in file backends of Gnus.") (defvar nnheader-callback-function nil) +(autoload 'gnus-get-buffer-create "gnus") + (defun nnheader-init-server-buffer () "Initialize the Gnus-backend communication buffer." (unless (gnus-buffer-live-p nntp-server-buffer) - (setq nntp-server-buffer (get-buffer-create " *nntpd*"))) + (setq nntp-server-buffer (gnus-get-buffer-create " *nntpd*"))) (with-current-buffer nntp-server-buffer (erase-buffer) (mm-enable-multibyte) @@ -630,7 +632,7 @@ the line could be found." (defun nnheader-set-temp-buffer (name &optional noerase) "Set-buffer to an empty (possibly new) buffer called NAME with undo disabled." - (set-buffer (get-buffer-create name)) + (set-buffer (gnus-get-buffer-create name)) (buffer-disable-undo) (unless noerase (erase-buffer)) diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index c383e0146f3..3c4e75ede82 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -1937,7 +1937,7 @@ Return the server's response to the SELECT or EXAMINE command." (defun nnimap-log-buffer () (let ((name "*imap log*")) (or (get-buffer name) - (with-current-buffer (get-buffer-create name) + (with-current-buffer (gnus-get-buffer-create name) (setq-local window-point-insertion-type t) (current-buffer))))) diff --git a/lisp/gnus/nnir.el b/lisp/gnus/nnir.el index f1e31a0cd10..722969c21ba 100644 --- a/lisp/gnus/nnir.el +++ b/lisp/gnus/nnir.el @@ -617,7 +617,8 @@ A non-nil `specs' arg must be an alist with `nnir-query-spec' and (list (gnus-group-group-name)) (mapcar (lambda (entry) (gnus-info-group (cadr entry))) - (gnus-topic-find-groups (gnus-group-topic-name))))) + (gnus-topic-find-groups (gnus-group-topic-name) + nil t nil t)))) gnus-group-server)))) (query-spec (or (cdr (assq 'nnir-query-spec specs)) @@ -1234,7 +1235,7 @@ Windows NT 4.0." (when (equal "" qstring) (error "swish++: You didn't enter anything")) - (set-buffer (get-buffer-create nnir-tmp-buffer)) + (set-buffer (gnus-get-buffer-create nnir-tmp-buffer)) (erase-buffer) (if groupspec @@ -1316,7 +1317,7 @@ Tested with swish-e-2.0.1 on Windows NT 4.0." (when (equal "" qstring) (error "swish-e: You didn't enter anything")) - (set-buffer (get-buffer-create nnir-tmp-buffer)) + (set-buffer (gnus-get-buffer-create nnir-tmp-buffer)) (erase-buffer) (message "Doing swish-e query %s..." query) @@ -1401,7 +1402,7 @@ Tested with swish-e-2.0.1 on Windows NT 4.0." (setq groupspec (regexp-opt (mapcar (lambda (x) (gnus-group-real-name x)) group)))) - (set-buffer (get-buffer-create nnir-tmp-buffer)) + (set-buffer (gnus-get-buffer-create nnir-tmp-buffer)) (erase-buffer) (message "Doing hyrex-search query %s..." query) (let* ((cp-list @@ -1480,7 +1481,7 @@ Tested with Namazu 2.0.6 on a GNU/Linux system." score group article (process-environment (copy-sequence process-environment))) (setenv "LC_MESSAGES" "C") - (set-buffer (get-buffer-create nnir-tmp-buffer)) + (set-buffer (gnus-get-buffer-create nnir-tmp-buffer)) (erase-buffer) (let* ((cp-list `( ,nnir-namazu-program @@ -1561,7 +1562,7 @@ construct path: search terms (see the variable (when (equal "" qstring) (error "notmuch: You didn't enter anything")) - (set-buffer (get-buffer-create nnir-tmp-buffer)) + (set-buffer (gnus-get-buffer-create nnir-tmp-buffer)) (erase-buffer) (if groups @@ -1635,7 +1636,7 @@ construct path: search terms (see the variable (message "Searching %s using find-grep..." (or group server)) (save-window-excursion - (set-buffer (get-buffer-create nnir-tmp-buffer)) + (set-buffer (gnus-get-buffer-create nnir-tmp-buffer)) (if (> gnus-verbose 6) (pop-to-buffer (current-buffer))) (cd directory) ; Using relative paths simplifies diff --git a/lisp/gnus/nnmail.el b/lisp/gnus/nnmail.el index d64d0ed0006..3be843c91f1 100644 --- a/lisp/gnus/nnmail.el +++ b/lisp/gnus/nnmail.el @@ -1047,7 +1047,7 @@ will be copied over from that buffer." (list (list group "")) nnmail-split-methods))) ;; Insert the incoming file. - (with-current-buffer (get-buffer-create nnmail-article-buffer) + (with-current-buffer (gnus-get-buffer-create nnmail-article-buffer) (erase-buffer) (if (bufferp incoming) (insert-buffer-substring incoming) @@ -1574,7 +1574,7 @@ See the documentation for the variable `nnmail-split-fancy' for details." () ; The buffer is open. (with-current-buffer (setq nnmail-cache-buffer - (get-buffer-create " *nnmail message-id cache*")) + (gnus-get-buffer-create " *nnmail message-id cache*")) (gnus-add-buffer) (when (file-exists-p nnmail-message-id-cache-file) (nnheader-insert-file-contents nnmail-message-id-cache-file)) @@ -1953,12 +1953,14 @@ If TIME is nil, then return the cutoff time for oldness instead." (unless (re-search-forward "^Message-ID[ \t]*:" nil t) (insert "Message-ID: " (nnmail-message-id) "\n"))))) -(defun nnmail-write-region (start end filename &optional append visit lockname) +(defun nnmail-write-region (start end filename + &optional append visit lockname mustbenew) "Do a `write-region', and then set the file modes." (let ((coding-system-for-write nnmail-file-coding-system) (file-name-coding-system nnmail-pathname-coding-system)) - (write-region start end filename append visit lockname) - (set-file-modes filename nnmail-default-file-modes))) + (write-region start end filename append visit lockname mustbenew) + (set-file-modes filename nnmail-default-file-modes + (when (eq mustbenew 'excl) 'nofollow)))) ;;; ;;; Status functions @@ -2065,7 +2067,7 @@ Doesn't change point." (when nnmail-split-tracing (push split nnmail-split-trace)) (when nnmail-debug-splitting - (with-current-buffer (get-buffer-create "*nnmail split*") + (with-current-buffer (gnus-get-buffer-create "*nnmail split*") (goto-char (point-max)) (insert (format-time-string "%FT%T") " " diff --git a/lisp/gnus/nnmaildir.el b/lisp/gnus/nnmaildir.el index b0e79d4f238..9c7b1254413 100644 --- a/lisp/gnus/nnmaildir.el +++ b/lisp/gnus/nnmaildir.el @@ -1,4 +1,4 @@ -;;; nnmaildir.el --- maildir backend for Gnus +;;; nnmaildir.el --- maildir backend for Gnus -*- lexical-binding:t -*- ;; This file is in the public domain. @@ -261,7 +261,7 @@ This variable is set by `nnmaildir-request-article'.") (defun nnmaildir--param (pgname param) (setq param (gnus-group-find-parameter pgname param 'allow-list)) (if (vectorp param) (setq param (aref param 0))) - (eval param)) + (eval param t)) (defmacro nnmaildir--with-nntp-buffer (&rest body) (declare (debug (body))) @@ -269,15 +269,15 @@ This variable is set by `nnmaildir-request-article'.") ,@body)) (defmacro nnmaildir--with-work-buffer (&rest body) (declare (debug (body))) - `(with-current-buffer (get-buffer-create " *nnmaildir work*") + `(with-current-buffer (gnus-get-buffer-create " *nnmaildir work*") ,@body)) (defmacro nnmaildir--with-nov-buffer (&rest body) (declare (debug (body))) - `(with-current-buffer (get-buffer-create " *nnmaildir nov*") + `(with-current-buffer (gnus-get-buffer-create " *nnmaildir nov*") ,@body)) (defmacro nnmaildir--with-move-buffer (&rest body) (declare (debug (body))) - `(with-current-buffer (get-buffer-create " *nnmaildir move*") + `(with-current-buffer (gnus-get-buffer-create " *nnmaildir move*") ,@body)) (defsubst nnmaildir--subdir (dir subdir) @@ -690,7 +690,7 @@ This variable is set by `nnmaildir-request-article'.") "You must set \"directory\" in the select method") (throw 'return nil)) (setq dir (cadr dir) - dir (eval dir) + dir (eval dir t) ;FIXME: Why `eval'? dir (expand-file-name dir) dir (file-name-as-directory dir)) (unless (file-exists-p dir) @@ -717,13 +717,13 @@ This variable is set by `nnmaildir-request-article'.") (if x (progn (setq x (cadr x) - x (eval x)) + x (eval x t)) ;FIXME: Why `eval'? (setf (nnmaildir--srv-target-prefix server) x)) (setq x (assq 'create-directory defs)) (if x (progn (setq x (cadr x) - x (eval x) + x (eval x t) ;FIXME: Why `eval'? x (file-name-as-directory x)) (setf (nnmaildir--srv-target-prefix server) x)) (setf (nnmaildir--srv-target-prefix server) ""))) @@ -1428,7 +1428,7 @@ This variable is set by `nnmaildir-request-article'.") (nnmaildir--with-move-buffer (erase-buffer) (nnheader-insert-file-contents nnmaildir--file) - (setq result (eval accept-form))) + (setq result (eval accept-form t))) (unless (or (null result) (nnmaildir--param pgname 'read-only)) (nnmaildir--unlink nnmaildir--file) (nnmaildir--expired-article group article)) @@ -1544,7 +1544,7 @@ This variable is set by `nnmaildir-request-article'.") (defun nnmaildir-request-expire-articles (ranges &optional gname server force) (let ((no-force (not force)) (group (nnmaildir--prepare server gname)) - pgname time boundary high low target dir nlist + pgname time boundary target dir nlist didnt nnmaildir--file nnmaildir-article-file-name deactivate-mark) (catch 'return @@ -1720,18 +1720,23 @@ This variable is set by `nnmaildir-request-article'.") (defun nnmaildir-close-group (gname &optional server) (let ((group (nnmaildir--prepare server gname)) - pgname ls dir msgdir files flist dirs) + pgname ls dir msgdir files dirs + (fset (make-hash-table :test #'equal))) (if (null group) (progn (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "No such group: " gname)) nil) + ;; Delete the now obsolete NOV files. + ;; FIXME: This can take a somewhat long time, so maybe it's better + ;; to do it asynchronously (i.e. in an idle timer). (setq pgname (nnmaildir--pgname nnmaildir--cur-server gname) ls (nnmaildir--group-ls nnmaildir--cur-server pgname) dir (nnmaildir--srv-dir nnmaildir--cur-server) dir (nnmaildir--srvgrp-dir dir gname) msgdir (if (nnmaildir--param pgname 'read-only) (nnmaildir--new dir) (nnmaildir--cur dir)) + ;; The dir with the NOV files. dir (nnmaildir--nndir dir) dirs (cons (nnmaildir--nov-dir dir) (funcall ls (nnmaildir--marks-dir dir) 'full "\\`[^.]" @@ -1744,14 +1749,15 @@ This variable is set by `nnmaildir-request-article'.") (save-match-data (dolist (file files) (string-match "\\`\\([^:]*\\)\\(:.*\\)?\\'" file) - (push (match-string 1 file) flist))) + (puthash (match-string 1 file) t fset))) + ;; Not sure why, but we specifically avoid deleting the `:' file. + (puthash ":" t fset) (dolist (dir dirs) (setq files (cdr dir) dir (file-name-as-directory (car dir))) (dolist (file files) - (unless (or (member file flist) (string= file ":")) - (setq file (concat dir file)) - (delete-file file)))) + (unless (gethash file fset) + (delete-file (concat dir file))))) t))) (defun nnmaildir-close-server (&optional server _defs) diff --git a/lisp/gnus/nnmairix.el b/lisp/gnus/nnmairix.el index b3329212f84..dcecfcf6519 100644 --- a/lisp/gnus/nnmairix.el +++ b/lisp/gnus/nnmairix.el @@ -1249,7 +1249,7 @@ Marks propagation has to be enabled for this to work." If THREADS is non-nil, enable full threads." (let ((args (cons (car command) '(nil t nil)))) (with-current-buffer - (get-buffer-create nnmairix-mairix-output-buffer) + (gnus-get-buffer-create nnmairix-mairix-output-buffer) (erase-buffer) (when (> (length command) 1) (setq args (append args (cdr command)))) @@ -1267,7 +1267,7 @@ If THREADS is non-nil, enable full threads." "Call mairix binary with COMMAND and QUERY in raw mode." (let ((args (cons (car command) '(nil t nil)))) (with-current-buffer - (get-buffer-create nnmairix-mairix-output-buffer) + (gnus-get-buffer-create nnmairix-mairix-output-buffer) (erase-buffer) (when (> (length command) 1) (setq args (append args (cdr command)))) @@ -1404,7 +1404,7 @@ TYPE is either `nov' or `headers'." (nnheader-message 7 "nnmairix: Rewriting headers...") (cond ((eq type 'nov) - (let ((buf (get-buffer-create " *nnmairix buffer*")) + (let ((buf (gnus-get-buffer-create " *nnmairix buffer*")) (corr (not (zerop numc))) (name (buffer-name nntp-server-buffer)) header cur xref) diff --git a/lisp/gnus/nnmbox.el b/lisp/gnus/nnmbox.el index eb8fcf37a25..8b3d80266e7 100644 --- a/lisp/gnus/nnmbox.el +++ b/lisp/gnus/nnmbox.el @@ -280,7 +280,7 @@ (deffoo nnmbox-request-move-article (article group server accept-form &optional last move-is-internal) - (let ((buf (get-buffer-create " *nnmbox move*")) + (let ((buf (gnus-get-buffer-create " *nnmbox move*")) result) (and (nnmbox-request-article article group server) @@ -613,7 +613,7 @@ (dir (file-name-directory nnmbox-mbox-file))) (and dir (gnus-make-directory dir)) (nnmail-write-region (point-min) (point-min) - nnmbox-mbox-file t 'nomesg)))) + nnmbox-mbox-file t 'nomesg nil 'excl)))) (defun nnmbox-read-mbox () (nnmail-activate 'nnmbox) diff --git a/lisp/gnus/nnmh.el b/lisp/gnus/nnmh.el index 8e7f0565e67..581a408009d 100644 --- a/lisp/gnus/nnmh.el +++ b/lisp/gnus/nnmh.el @@ -296,7 +296,7 @@ as unread by Gnus.") (deffoo nnmh-request-move-article (article group server accept-form &optional last move-is-internal) - (let ((buf (get-buffer-create " *nnmh move*")) + (let ((buf (gnus-get-buffer-create " *nnmh move*")) result) (and (nnmh-deletable-article-p group article) diff --git a/lisp/gnus/nnml.el b/lisp/gnus/nnml.el index 6c7b25b5e76..baf5d54b74d 100644 --- a/lisp/gnus/nnml.el +++ b/lisp/gnus/nnml.el @@ -361,7 +361,7 @@ non-nil.") (deffoo nnml-request-move-article (article group server accept-form &optional last move-is-internal) - (let ((buf (get-buffer-create " *nnml move*")) + (let ((buf (gnus-get-buffer-create " *nnml move*")) (file-name-coding-system nnmail-pathname-coding-system) result) (nnml-possibly-change-directory group server) @@ -572,7 +572,7 @@ non-nil.") ;; Find an article number in the current group given the Message-ID. (defun nnml-find-group-number (id server) - (with-current-buffer (get-buffer-create " *nnml id*") + (with-current-buffer (gnus-get-buffer-create " *nnml id*") (let ((alist nnml-group-alist) number) ;; We want to look through all .overview files, but we want to @@ -772,11 +772,10 @@ article number. This function is called narrowed to an article." headers)))) (defun nnml-get-nov-buffer (group &optional incrementalp) - (let ((buffer (get-buffer-create (format " *nnml %soverview %s*" - (if incrementalp - "incremental " - "") - group))) + (let ((buffer (gnus-get-buffer-create + (format " *nnml %soverview %s*" + (if incrementalp "incremental " "") + group))) (file-name-coding-system nnmail-pathname-coding-system)) (with-current-buffer buffer (set (make-local-variable 'nnml-nov-buffer-file-name) @@ -873,7 +872,7 @@ Unless no-active is non-nil, update the active file too." (defun nnml-generate-nov-file (dir files) (let* ((dir (file-name-as-directory dir)) (nov (concat dir nnml-nov-file-name)) - (nov-buffer (get-buffer-create " *nov*")) + (nov-buffer (gnus-get-buffer-create " *nov*")) chars file headers) (with-current-buffer nov-buffer ;; Init the nov buffer. @@ -902,7 +901,7 @@ Unless no-active is non-nil, update the active file too." (nnheader-insert-nov headers))) (widen)))) (with-current-buffer nov-buffer - (nnmail-write-region (point-min) (point-max) nov nil 'nomesg) + (nnmail-write-region (point-min) (point-max) nov nil 'nomesg nil 'excl) (kill-buffer (current-buffer)))))) (defun nnml-nov-delete-article (group article) diff --git a/lisp/gnus/nnrss.el b/lisp/gnus/nnrss.el index fa4d22fb1cc..116d7ee9fb2 100644 --- a/lisp/gnus/nnrss.el +++ b/lisp/gnus/nnrss.el @@ -739,7 +739,7 @@ Read the file and attempt to subscribe to each Feed in the file." "OPML subscription export. Export subscriptions to a buffer in OPML Format." (interactive) - (with-current-buffer (get-buffer-create "*OPML Export*") + (with-current-buffer (gnus-get-buffer-create "*OPML Export*") (set-buffer-file-coding-system 'utf-8) (insert "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n" "<!-- OPML generated by Emacs Gnus' nnrss.el -->\n" diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el index 6ce8724cbbb..02d90603b40 100644 --- a/lisp/gnus/nntp.el +++ b/lisp/gnus/nntp.el @@ -309,7 +309,7 @@ backend doesn't catch this error.") (defun nntp-record-command (string) "Record the command STRING." - (with-current-buffer (get-buffer-create "*nntp-log*") + (with-current-buffer (gnus-get-buffer-create "*nntp-log*") (goto-char (point-max)) (insert (format-time-string "%Y%m%dT%H%M%S.%3N") " " nntp-address " " string "\n"))) @@ -1247,8 +1247,8 @@ If SEND-IF-FORCE, only send authinfo to the server if the (and nntp-connection-timeout (run-at-time nntp-connection-timeout nil - `(lambda () - (nntp-kill-buffer ,pbuffer))))) + (lambda () + (nntp-kill-buffer pbuffer))))) (process (condition-case err (let ((coding-system-for-read 'binary) diff --git a/lisp/gnus/nnvirtual.el b/lisp/gnus/nnvirtual.el index e1290a9c774..54c2f7be820 100644 --- a/lisp/gnus/nnvirtual.el +++ b/lisp/gnus/nnvirtual.el @@ -97,7 +97,7 @@ component group will show up when you enter the virtual group.") (if (stringp (car articles)) 'headers (let ((vbuf (nnheader-set-temp-buffer - (get-buffer-create " *virtual headers*"))) + (gnus-get-buffer-create " *virtual headers*"))) (carticles (nnvirtual-partition-sequence articles)) (sysname (system-name)) cgroup carticle article result prefix) diff --git a/lisp/gnus/spam.el b/lisp/gnus/spam.el index 5632bdaf250..96a7da2313c 100644 --- a/lisp/gnus/spam.el +++ b/lisp/gnus/spam.el @@ -579,7 +579,7 @@ This must be a list. For example, `(\"-C\" \"configfile\")'." (defcustom spam-spamassassin-positive-spam-flag-header "YES" "The regex on `spam-spamassassin-spam-flag-header' for positive spam identification." - :type 'string + :type 'regexp :group 'spam-spamassassin) (defcustom spam-spamassassin-spam-status-header "X-Spam-Status" |