commit 9f2d21ca536ea7ca1da98e7bd57ae535ab394997 (HEAD, refs/remotes/origin/master) Author: Philipp Stephani Date: Sun Apr 15 23:45:27 2018 -0700 Avoid undefined behavior in 'defvar' (Bug#31072) * src/eval.c (Fdefvar): Check that first argument is a symbol. * test/src/eval-tests.el (defvar/bug31072): New unit test. diff --git a/src/eval.c b/src/eval.c index a6e1d86c4a..90d8c33518 100644 --- a/src/eval.c +++ b/src/eval.c @@ -737,6 +737,8 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */) sym = XCAR (args); tail = XCDR (args); + CHECK_SYMBOL (sym); + if (!NILP (tail)) { if (!NILP (XCDR (tail)) && !NILP (XCDR (XCDR (tail)))) diff --git a/test/src/eval-tests.el b/test/src/eval-tests.el index 59da6b7cc3..319dd91c86 100644 --- a/test/src/eval-tests.el +++ b/test/src/eval-tests.el @@ -113,4 +113,8 @@ crash/abort/malloc assert failure on the next test." (signal-hook-function #'ignore)) (should-error (eval-tests--exceed-specbind-limit)))) +(ert-deftest defvar/bug31072 () + "Check that Bug#31072 is fixed." + (should-error (eval '(defvar 1) t) :type 'wrong-type-argument)) + ;;; eval-tests.el ends here commit 836dce63c3274eaa84a26c09a5b6dcb1522dba98 Author: Stefan Monnier Date: Wed Mar 14 20:06:47 2018 -0400 EUDC: Enable lexical binding and do some cleanups * lisp/net/eudc.el: Enable lexical binding. (cl-lib): Always require cl-lib, not only when byte compiling. (eudc-mode-map): Set parent keymap within let form. (eudc-update-local-variables): Use #' read syntax for function argument to map function. (eudc-select): Likewise. (eudc-format-attribute-name-for-display): Likewise (eudc-filter-duplicate-attributes): Likewise. (eudc-format-query): Likewise. (eudc-expand-inline): Likewise. (eudc-query-form): Likewise. (eudc-print-attribute-value): Use mapc instead of mapcar. (eudc-filter-partial-records): Use cl-every. (eudc-distribute-field-on-records): Use delete-dups to simplify function. (eudc-expand-inline): Replace while with dolist and let form. (eudc-query-form): Set inhibit-read-only after switching buffers. Remove useless and call. (eudc-load-eudc): Add a FIXME comment. diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el index 8d1071af72..98f70bd1f7 100644 --- a/lisp/net/eudc.el +++ b/lisp/net/eudc.el @@ -1,4 +1,4 @@ -;;; eudc.el --- Emacs Unified Directory Client +;;; eudc.el --- Emacs Unified Directory Client -*- lexical-binding:t -*- ;; Copyright (C) 1998-2018 Free Software Foundation, Inc. @@ -47,7 +47,7 @@ (require 'wid-edit) -(eval-when-compile (require 'cl-lib)) +(require 'cl-lib) (eval-and-compile (if (not (fboundp 'make-overlay)) @@ -68,6 +68,7 @@ (defvar eudc-mode-map (let ((map (make-sparse-keymap))) + (set-keymap-parent map widget-keymap) (define-key map "q" 'kill-current-buffer) (define-key map "x" 'kill-current-buffer) (define-key map "f" 'eudc-query-form) @@ -75,7 +76,6 @@ (define-key map "n" 'eudc-move-to-next-record) (define-key map "p" 'eudc-move-to-previous-record) map)) -(set-keymap-parent eudc-mode-map widget-keymap) (defvar mode-popup-menu) @@ -314,7 +314,7 @@ accordingly. Otherwise it is set to its EUDC default binding" (defun eudc-update-local-variables () "Update all EUDC variables according to their local settings." (interactive) - (mapcar 'eudc-update-variable eudc-local-vars)) + (mapcar #'eudc-update-variable eudc-local-vars)) (eudc-default-set 'eudc-query-function nil) (eudc-default-set 'eudc-list-attributes-function nil) @@ -378,7 +378,7 @@ BEG and END delimit the text which is to be replaced." (let ((replacement)) (setq replacement (completing-read "Multiple matches found; choose one: " - (mapcar 'list choices))) + (mapcar #'list choices))) (delete-region beg end) (insert replacement))) @@ -415,7 +415,7 @@ underscore characters are replaced by spaces." (if match (cdr match) (capitalize - (mapconcat 'identity + (mapconcat #'identity (split-string (symbol-name attribute) "_") " "))))) @@ -432,7 +432,7 @@ if any, is called to print the value in cdr of FIELD." (progn (eval (list (cdr match) val)) (insert "\n")) - (mapcar + (mapc (function (lambda (val-elem) (indent-to col) @@ -598,9 +598,10 @@ otherwise they are formatted according to `eudc-user-attribute-names-alist'." (setq result (eudc-add-field-to-records (cons (car field) (mapconcat - 'identity + #'identity (cdr field) - "\n")) result))) + "\n")) + result))) ((eq 'duplicate method) (setq result (eudc-distribute-field-on-records field result))))))) @@ -613,12 +614,9 @@ otherwise they are formatted according to `eudc-user-attribute-names-alist'." (mapcar (function (lambda (rec) - (if (eval (cons 'and - (mapcar - (function - (lambda (attr) - (consp (assq attr rec)))) - attrs))) + (if (cl-every (lambda (attr) + (consp (assq attr rec))) + attrs) rec))) records))) @@ -632,25 +630,14 @@ otherwise they are formatted according to `eudc-user-attribute-names-alist'." (defun eudc-distribute-field-on-records (field records) "Duplicate each individual record in RECORDS according to value of FIELD. Each copy is added a new field containing one of the values of FIELD." - (let (result - (values (cdr field))) - ;; Uniquify values first - (while values - (setcdr values (delete (car values) (cdr values))) - (setq values (cdr values))) - (mapc - (function - (lambda (value) - (let ((result-list (copy-sequence records))) - (setq result-list (eudc-add-field-to-records - (cons (car field) value) - result-list)) - (setq result (append result-list result)) - ))) - (cdr field)) + (let (result) + (dolist (value (delete-dups (cdr field))) ;; Uniquify values first. + (setq result (nconc (eudc-add-field-to-records + (cons (car field) value) + records) + result))) result)) - (define-derived-mode eudc-mode special-mode "EUDC" "Major mode used in buffers displaying the results of directory queries. There is no sense in calling this command from a buffer other than @@ -776,8 +763,8 @@ otherwise a list of symbols is returned." (setq query-alist (cdr query-alist))) query) (if eudc-protocol-has-default-query-attributes - (mapconcat 'identity words " ") - (list (cons 'name (mapconcat 'identity words " "))))))) + (mapconcat #'identity words " ") + (list (cons 'name (mapconcat #'identity words " "))))))) (defun eudc-extract-n-word-formats (format-list n) "Extract a list of N-long formats from FORMAT-LIST. @@ -836,7 +823,6 @@ see `eudc-inline-expansion-servers'" "[ \t]+")) query-formats response - response-string response-strings (eudc-former-server eudc-server) (eudc-former-protocol eudc-protocol) @@ -894,20 +880,18 @@ see `eudc-inline-expansion-servers'" (error "No match") ;; Process response through eudc-inline-expansion-format - (while response - (setq response-string - (apply 'format - (car eudc-inline-expansion-format) - (mapcar (function - (lambda (field) - (or (cdr (assq field (car response))) - ""))) - (eudc-translate-attribute-list - (cdr eudc-inline-expansion-format))))) - (if (> (length response-string) 0) - (setq response-strings - (cons response-string response-strings))) - (setq response (cdr response))) + (dolist (r response) + (let ((response-string + (apply #'format + (car eudc-inline-expansion-format) + (mapcar (function + (lambda (field) + (or (cdr (assq field r)) + ""))) + (eudc-translate-attribute-list + (cdr eudc-inline-expansion-format)))))) + (if (> (length response-string) 0) + (push response-string response-strings)))) (if (or (and replace (not eudc-expansion-overwrites-query)) @@ -923,7 +907,7 @@ see `eudc-inline-expansion-servers'" (eudc-select response-strings beg end)) ((eq eudc-multiple-match-handling-method 'all) (delete-region beg end) - (insert (mapconcat 'identity response-strings ", "))) + (insert (mapconcat #'identity response-strings ", "))) ((eq eudc-multiple-match-handling-method 'abort) (error "There is more than one match for the query"))))) (or (and (equal eudc-server eudc-former-server) @@ -943,10 +927,9 @@ queries the server for the existing fields and displays a corresponding form." prompts widget (width 0) - inhibit-read-only pt) (switch-to-buffer buffer) - (setq inhibit-read-only t) + (let ((inhibit-read-only t)) (erase-buffer) (kill-all-local-variables) (make-local-variable 'eudc-form-widget-list) @@ -960,11 +943,10 @@ queries the server for the existing fields and displays a corresponding form." (widget-insert "Protocol : " (symbol-name eudc-protocol) "\n") ;; Build the list of prompts (setq prompts (if eudc-use-raw-directory-names - (mapcar 'symbol-name (eudc-translate-attribute-list fields)) + (mapcar #'symbol-name (eudc-translate-attribute-list fields)) (mapcar (function (lambda (field) - (or (and (assq field eudc-user-attribute-names-alist) - (cdr (assq field eudc-user-attribute-names-alist))) + (or (cdr (assq field eudc-user-attribute-names-alist)) (capitalize (symbol-name field))))) fields))) ;; Loop over prompt strings to find the longest one @@ -1008,7 +990,7 @@ queries the server for the existing fields and displays a corresponding form." "Quit") (goto-char pt) (use-local-map widget-keymap) - (widget-setup)) + (widget-setup))) ) (defun eudc-bookmark-server (server protocol) @@ -1207,25 +1189,29 @@ queries the server for the existing fields and displays a corresponding form." ;;; Load time initializations : -;;; Load the options file +;; Load the options file (if (and (not noninteractive) (and (locate-library eudc-options-file) (progn (message "") t)) ; Remove mode line message (not (featurep 'eudc-options-file))) (load eudc-options-file)) -;;; Install the full menu +;; Install the full menu (unless (featurep 'infodock) (eudc-install-menu)) -;;; The following installs a short menu for EUDC at XEmacs startup. +;; The following installs a short menu for EUDC at XEmacs startup. ;;;###autoload (defun eudc-load-eudc () "Load the Emacs Unified Directory Client. This does nothing except loading eudc by autoload side-effect." (interactive) + ;; FIXME: By convention, loading a file should "do nothing significant" + ;; since Emacs may occasionally load a file for "frivolous" reasons + ;; (e.g. to find a docstring), so having a function which just loads + ;; the file doesn't seem very useful. nil) ;;;###autoload commit 7d0fa6081e7e307055b5dc47566061c0682e3ab7 Author: Rüdiger Sonderfeld Date: Sun Apr 15 23:56:24 2018 +0200 In HTML mode, don't match

... Date: Sun Apr 15 23:44:56 2018 +0200 Use quit-buffer instead of semantic-symref-hide-buffer * lisp/cedet/semantic/symref/list.el (semantic-symref-hide-buffer): Removed (bug#15857). (semantic-symref-results-mode-map): Use quit-buffer instead. diff --git a/lisp/cedet/semantic/symref/list.el b/lisp/cedet/semantic/symref/list.el index 1be2b0ed39..31487d01c7 100644 --- a/lisp/cedet/semantic/symref/list.el +++ b/lisp/cedet/semantic/symref/list.el @@ -114,7 +114,7 @@ Display the references in `semantic-symref-results-mode'." (define-key km "+" 'semantic-symref-list-toggle-showing) (define-key km "n" 'semantic-symref-list-next-line) (define-key km "p" 'semantic-symref-list-prev-line) - (define-key km "q" 'semantic-symref-hide-buffer) + (define-key km "q" 'quit-buffer) (define-key km "\C-c\C-e" 'semantic-symref-list-expand-all) (define-key km "\C-c\C-r" 'semantic-symref-list-contract-all) (define-key km "R" 'semantic-symref-list-rename-open-hits) @@ -193,11 +193,6 @@ Display the references in `semantic-symref-results-mode'." (set (make-local-variable 'font-lock-global-modes) nil) (font-lock-mode -1)) -(defun semantic-symref-hide-buffer () - "Hide buffer with semantic-symref results." - (interactive) - (bury-buffer)) - (defcustom semantic-symref-results-summary-function 'semantic-format-tag-prototype "Function to use when creating items in Imenu. Some useful functions are found in `semantic-format-tag-functions'." commit 9e4cae7bc91120ef54b80505ad7914b2cb4d49e8 Author: Lars Ingebrigtsen Date: Sun Apr 15 23:12:26 2018 +0200 Doc string update for gnus-extract-address-components * lisp/gnus/gnus-util.el (gnus-extract-address-components): Doc update. diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index 1001d11df4..b30e4d125b 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -141,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 commit 003a89b6c8eb5e62b4ba2f2f3d4d3e3f6a8b7484 Author: Lars Ingebrigtsen Date: Sun Apr 15 22:48:28 2018 +0200 Add an undo command to url-cookie-mode * lisp/url/url-cookie.el (url-cookie-undo): New command and keystroke (bug#16650). diff --git a/lisp/url/url-cookie.el b/lisp/url/url-cookie.el index 535a98c9c7..3adca26d76 100644 --- a/lisp/url/url-cookie.el +++ b/lisp/url/url-cookie.el @@ -395,6 +395,8 @@ instead delete all cookies that do not match REGEXP." ;;; Mode for listing and editing cookies. +(defvar url-cookie--deleted-cookies nil) + (defun url-cookie-list () "Display a buffer listing the current URL cookies, if there are any. Use \\\\[url-cookie-delete] to remove cookies." @@ -466,12 +468,37 @@ Use \\\\[url-cookie-delete] to remove cookies." (let ((point (point))) (erase-buffer) (url-cookie--generate-buffer) + (goto-char point)) + (push cookie url-cookie--deleted-cookies))) + +(defun url-cookie-undo () + "Undo deletion of a cookie." + (interactive) + (unless url-cookie--deleted-cookies + (error "No cookie deletions to undo")) + (let* ((cookie (pop url-cookie--deleted-cookies)) + (variable (if (url-cookie-secure cookie) + 'url-cookie-secure-storage + 'url-cookie-storage)) + (list (symbol-value variable)) + (elem (assoc (url-cookie-domain cookie) list))) + (if elem + (nconc elem (list cookie)) + (setq elem (list (url-cookie-domain cookie) cookie)) + (set variable (cons elem list))) + (setq url-cookies-changed-since-last-save t) + (url-cookie-write-file) + (let ((point (point)) + (inhibit-read-only t)) + (erase-buffer) + (url-cookie--generate-buffer) (goto-char point)))) (defvar url-cookie-mode-map (let ((map (make-sparse-keymap))) (define-key map [delete] 'url-cookie-delete) (define-key map [(control k)] 'url-cookie-delete) + (define-key map [(control _)] 'url-cookie-undo) map)) (define-derived-mode url-cookie-mode special-mode "URL Cookie" commit f262b10b46c0f7daef9e433e95ce565191e6841d Author: Lars Ingebrigtsen Date: Sun Apr 15 22:36:16 2018 +0200 Tweak the look of the cookie buffer after cookie deletion * lisp/url/url-cookie.el (url-cookie--generate-buffer): Factor out into its own function. (url-cookie-delete): Use it to make the buffer look consistent after deleting a cookie. diff --git a/lisp/url/url-cookie.el b/lisp/url/url-cookie.el index 29487e83c6..535a98c9c7 100644 --- a/lisp/url/url-cookie.el +++ b/lisp/url/url-cookie.el @@ -404,6 +404,11 @@ Use \\\\[url-cookie-delete] to remove cookies." (error "No cookies are defined")) (pop-to-buffer "*url cookies*") + (url-cookie-mode) + (url-cookie--generate-buffer) + (goto-char (point-min))) + +(defun url-cookie--generate-buffer () (let ((inhibit-read-only t) (domains (sort (copy-sequence @@ -414,7 +419,6 @@ Use \\\\[url-cookie-delete] to remove cookies." (domain-length 0) start name format domain) (erase-buffer) - (url-cookie-mode) (dolist (elem domains) (setq domain-length (max domain-length (length (car elem))))) (setq format (format "%%-%ds %%-20s %%s" domain-length) @@ -426,16 +430,15 @@ Use \\\\[url-cookie-delete] to remove cookies." (lambda (c1 c2) (string< (url-cookie-name c1) (url-cookie-name c2))))) - (setq start (point) + (setq start (point) name (url-cookie-name cookie)) - (when (> (length name) 20) + (when (> (length name) 20) (setq name (substring name 0 20))) - (insert (format format domain name - (url-cookie-value cookie)) - "\n") - (setq domain "") - (put-text-property start (1+ start) 'url-cookie cookie))) - (goto-char (point-min)))) + (insert (format format domain name + (url-cookie-value cookie)) + "\n") + (setq domain "") + (put-text-property start (1+ start) 'url-cookie cookie))))) (defun url-cookie-delete () "Delete the cookie on the current line." @@ -459,7 +462,11 @@ Use \\\\[url-cookie-delete] to remove cookies." (delete-region (line-beginning-position) (progn (forward-line 1) - (point))))) + (point))) + (let ((point (point))) + (erase-buffer) + (url-cookie--generate-buffer) + (goto-char point)))) (defvar url-cookie-mode-map (let ((map (make-sparse-keymap))) commit a37a14e0a8ee16b7ae53b4dba9b60329e3b4308d Author: Lars Ingebrigtsen Date: Sun Apr 15 22:20:28 2018 +0200 Make eww handle "http://a/../../../g" * lisp/net/eww.el (eww): Strip leading elements off URLs on the form "http://a/../../../g", because that's what all the other browsers do (bug#8622). diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 49bf10d4eb..f737189612 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -269,8 +269,13 @@ word(s) will be searched for via `eww-search-prefix'." (let ((parsed (url-generic-parse-url url))) (when (url-host parsed) (unless (puny-highly-restrictive-domain-p (url-host parsed)) - (setf (url-host parsed) (puny-encode-domain (url-host parsed))) - (setq url (url-recreate-url parsed))))) + (setf (url-host parsed) (puny-encode-domain (url-host parsed))))) + ;; When the URL is on the form "http://a/../../../g", chop off all + ;; the leading "/.."s. + (when (url-filename parsed) + (while (string-match "\\`/[.][.]/" (url-filename parsed)) + (setf (url-filename parsed) (substring (url-filename parsed) 3)))) + (setq url (url-recreate-url parsed))) (plist-put eww-data :url url) (plist-put eww-data :title "") (eww-update-header-line-format) commit 1c16fbd1b281a46b07028ca78dbaab9a0ec6fd2f Author: Lars Ingebrigtsen Date: Sun Apr 15 21:50:38 2018 +0200 Make url-cookie-write-file be more permissive * lisp/url/url-cookie.el (url-cookie-write-file): If `url-cookie-file' isn't set (due to url.el not being used yet), don't error out in this function (bug#23183). diff --git a/lisp/url/url-cookie.el b/lisp/url/url-cookie.el index 76c18b756f..29487e83c6 100644 --- a/lisp/url/url-cookie.el +++ b/lisp/url/url-cookie.el @@ -139,7 +139,8 @@ i.e. 1970-1-1) are loaded as expiring one year from now instead." (set var new))) (defun url-cookie-write-file (&optional fname) - (when url-cookies-changed-since-last-save + (when (and url-cookies-changed-since-last-save + url-cookie-file) (or fname (setq fname (expand-file-name url-cookie-file))) (if (condition-case nil (progn commit 2e1caf3254ba6bf6bd764b60b24e298995ec2cb9 Author: Lars Ingebrigtsen Date: Sun Apr 15 21:03:34 2018 +0200 Don't warn the user about large files if they are unreadable * lisp/files.el (abort-if-file-too-large): There's no point in warning the user about a too-large file if we're not able to read it (bug#29549). Hopefully this doesn't introduce a race condition between this test and the `file-readable-p' test later. diff --git a/lisp/files.el b/lisp/files.el index 67a9abfa76..d98d09bb1e 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -2019,6 +2019,8 @@ think it does, because \"free\" is pretty hard to define in practice." OP-TYPE specifies the file operation being performed (for message to user)." (when (and large-file-warning-threshold size (> size large-file-warning-threshold) + ;; No point in warning if we can't read it. + (file-readable-p filename) (not (y-or-n-p (format "File %s is large (%s), really %s? " (file-name-nondirectory filename) (file-size-human-readable size) op-type)))) commit b72de45eb00b6a1c35a3d11914fb862ebb30034a Author: Lars Ingebrigtsen Date: Sun Apr 15 20:42:44 2018 +0200 Only save the mailer choice after sending the mail * lisp/mail/sendmail.el (sendmail-query-once): Only save the mailer choice after we've sent the mail, so that if that fails, the user has an easy way to back out of the choice and make another (bug#14487). (sendmail-query-user-about-smtp): Return the choice; don't save it. diff --git a/lisp/mail/sendmail.el b/lisp/mail/sendmail.el index cfbefd91d9..c9f8fec1e1 100644 --- a/lisp/mail/sendmail.el +++ b/lisp/mail/sendmail.el @@ -505,9 +505,13 @@ This also saves the value of `send-mail-function' via Customize." ;; If send-mail-function is already setup, we're incorrectly called ;; a second time, probably because someone's using an old value ;; of send-mail-function. - (when (eq send-mail-function 'sendmail-query-once) - (sendmail-query-user-about-smtp)) - (funcall send-mail-function)) + (if (not (eq send-mail-function 'sendmail-query-once)) + (funcall send-mail-function) + (let ((function (sendmail-query-user-about-smtp))) + (funcall function) + (when (y-or-n-p "Save this mail sending choice?") + (setq send-mail-function function) + (customize-save-variable 'send-mail-function function))))) (defun sendmail-query-user-about-smtp () (let* ((options `(("mail client" . mailclient-send-it) @@ -552,8 +556,8 @@ This also saves the value of `send-mail-function' via Customize." (completing-read (format "Send mail via (default %s): " (caar options)) options nil 'require-match nil nil (car options)))))) - (customize-save-variable 'send-mail-function - (cdr (assoc-string choice options t))))) + ;; Return the choice. + (cdr (assoc-string choice options t)))) (defun sendmail-sync-aliases () (when mail-personal-alias-file commit 54f7ec01c336d315c3b9e69c60ef18100840dd54 Author: Lars Ingebrigtsen Date: Sun Apr 15 20:06:27 2018 +0200 (compose-mail): Give a better error message for `mail-user-agent' * lisp/simple.el (compose-mail): Give a better error message for invalid values for `mail-user-agent' (bug#17979). diff --git a/lisp/simple.el b/lisp/simple.el index dada65d4ee..7d94b64913 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -7895,6 +7895,8 @@ To disable this warning, set `compose-mail-user-agent-warnings' to nil." warn-vars " ")))))) (let ((function (get mail-user-agent 'composefunc))) + (unless function + (error "Invalid value for `mail-user-agent'")) (funcall function to subject other-headers continue switch-function yank-action send-actions return-action))) commit 1143906b79dc7ffb39ce98f06a7540a1deed7da4 Author: Lars Ingebrigtsen Date: Sun Apr 15 19:53:27 2018 +0200 Fix typo in gnus.texi * doc/misc/gnus.texi (Summary Message Commands): Fix typo in last change. diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi index 77c02182b4..7cb980fddf 100644 --- a/doc/misc/gnus.texi +++ b/doc/misc/gnus.texi @@ -5854,7 +5854,7 @@ process/prefix convention (@pxref{Process/Prefix}). @kindex S A @r{(Summary)} @findex gnus-summary-attach-article Attach the current article into an already existing Message -composition buffer (@code{gnus-summary-yank-message}). If no such +composition buffer (@code{gnus-summary-attach-message}). If no such buffer exists, a new one is created. This command prompts for what message buffer you want to yank into, and understands the process/prefix convention (@pxref{Process/Prefix}). commit 652ce40c50dd22b06c2a670693cc6effc490b0b3 Author: Lars Ingebrigtsen Date: Sun Apr 15 19:49:47 2018 +0200 Update doc string after previous ietf-drums change * lisp/mail/ietf-drums.el (ietf-drums-parse-address): Doc fix after previous change. diff --git a/lisp/mail/ietf-drums.el b/lisp/mail/ietf-drums.el index 9bdb945742..0af3221fc3 100644 --- a/lisp/mail/ietf-drums.el +++ b/lisp/mail/ietf-drums.el @@ -185,8 +185,12 @@ STRING is assumed to be a string that is extracted from the Content-Transfer-Encoding header of a mail." (ietf-drums-remove-garbage (inline (ietf-drums-strip string)))) +(declare-function rfc2047-decode-string "rfc2047" (string &optional address-mime)) + (defun ietf-drums-parse-address (string &optional decode) - "Parse STRING and return a MAILBOX / DISPLAY-NAME pair." + "Parse STRING and return a MAILBOX / DISPLAY-NAME pair. +If DECODE, the DISPLAY-NAME will have RFC2047 decoding performed +(that's the \"=?utf...q...=?\") stuff." (with-temp-buffer (let (display-name mailbox c display-string) (ietf-drums-init string) commit 47d52c22559da40003dcd02ad32097562a8573d5 Author: Lars Ingebrigtsen Date: Sun Apr 15 19:45:05 2018 +0200 mail-extr.el: Mention `mail-header-parse-address' in the doc string * lisp/mail/mail-extr.el (mail-extract-address-components): Mention `mail-header-parse-address' in the doc string. diff --git a/lisp/mail/mail-extr.el b/lisp/mail/mail-extr.el index 3e8a41fb24..0175c687b2 100644 --- a/lisp/mail/mail-extr.el +++ b/lisp/mail/mail-extr.el @@ -712,7 +712,13 @@ one recipients, all but the first is ignored. ADDRESS may be a string or a buffer. If it is a buffer, the visible \(narrowed) portion of the buffer will be interpreted as the address. \(This feature exists so that the clever caller might be able to avoid -consing a string.)" +consing a string.) + +This function is primarily meant for when you're displaying the +result to the user: Many prettifications are applied to the +result returned. If you want to decode an address for further +non-display use, you should probably use +`mail-header-parse-address' instead." (let ((canonicalization-buffer (get-buffer-create " *canonical address*")) (extraction-buffer (get-buffer-create " *extract address components*")) value-list) commit a38f79a8fd9c48b8911cad34159a64e97811a0ee Author: Lars Ingebrigtsen Date: Sun Apr 15 19:42:10 2018 +0200 Allow `mail-header-parse-address' to decode encoded words * lisp/mail/ietf-drums.el (ietf-drums-parse-address): Take an optional parameter to decode the display name. diff --git a/lisp/mail/ietf-drums.el b/lisp/mail/ietf-drums.el index 83042b42e8..9bdb945742 100644 --- a/lisp/mail/ietf-drums.el +++ b/lisp/mail/ietf-drums.el @@ -185,7 +185,7 @@ STRING is assumed to be a string that is extracted from the Content-Transfer-Encoding header of a mail." (ietf-drums-remove-garbage (inline (ietf-drums-strip string)))) -(defun ietf-drums-parse-address (string) +(defun ietf-drums-parse-address (string &optional decode) "Parse STRING and return a MAILBOX / DISPLAY-NAME pair." (with-temp-buffer (let (display-name mailbox c display-string) @@ -236,7 +236,9 @@ the Content-Transfer-Encoding header of a mail." (cons (mapconcat 'identity (nreverse display-name) "") (ietf-drums-get-comment string))) - (cons mailbox display-string))))) + (cons mailbox (if decode + (rfc2047-decode-string display-string) + display-string)))))) (defun ietf-drums-parse-addresses (string &optional rawp) "Parse STRING and return a list of MAILBOX / DISPLAY-NAME pairs. commit a3a9d5434d56f8736cc47e379a1d011d4c779b7c Author: Lars Ingebrigtsen Date: Sun Apr 15 19:28:04 2018 +0200 Revert "Make mail-extract-address-components return the user name more" This reverts commit 8b50ae8b2284b5652c2843a9d0d076f4f657be28. According to tests in bug#27656 by OGAWA Hirofumi, this patch led to wrong results when binding (dolist (addr '("Rasmus " "Rasmus ")) (dolist (ignore-single '(t nil)) (dolist (ignore-same '(t nil)) (let ((mail-extr-ignore-single-names ignore-single) (mail-extr-ignore-realname-equals-mailbox-name ignore-same)) (message "%s" (mail-extract-address-components addr)))))) in combination. diff --git a/lisp/mail/mail-extr.el b/lisp/mail/mail-extr.el index 1e18c6d055..3e8a41fb24 100644 --- a/lisp/mail/mail-extr.el +++ b/lisp/mail/mail-extr.el @@ -1406,26 +1406,25 @@ consing a string.)" (insert (upcase mi) ". "))) ;; Nuke name if it is the same as mailbox name. - (when mail-extr-ignore-single-names - (let ((buffer-length (- (point-max) (point-min))) - (i 0) - (names-match-flag t)) - (when (and (> buffer-length 0) - (eq buffer-length (- mbox-end mbox-beg))) - (goto-char (point-max)) - (insert-buffer-substring canonicalization-buffer - mbox-beg mbox-end) - (while (and names-match-flag - (< i buffer-length)) - (or (eq (downcase (char-after (+ i (point-min)))) - (downcase - (char-after (+ i buffer-length (point-min))))) - (setq names-match-flag nil)) - (setq i (1+ i))) - (delete-region (+ (point-min) buffer-length) (point-max)) - (and names-match-flag - mail-extr-ignore-realname-equals-mailbox-name - (narrow-to-region (point) (point)))))) + (let ((buffer-length (- (point-max) (point-min))) + (i 0) + (names-match-flag t)) + (when (and (> buffer-length 0) + (eq buffer-length (- mbox-end mbox-beg))) + (goto-char (point-max)) + (insert-buffer-substring canonicalization-buffer + mbox-beg mbox-end) + (while (and names-match-flag + (< i buffer-length)) + (or (eq (downcase (char-after (+ i (point-min)))) + (downcase + (char-after (+ i buffer-length (point-min))))) + (setq names-match-flag nil)) + (setq i (1+ i))) + (delete-region (+ (point-min) buffer-length) (point-max)) + (and names-match-flag + mail-extr-ignore-realname-equals-mailbox-name + (narrow-to-region (point) (point))))) ;; Nuke name if it's just one word. (goto-char (point-min)) commit 60ec0c7960985bf6e849e2ea4c3888127f8e9bef Author: Lars Ingebrigtsen Date: Sun Apr 15 19:01:32 2018 +0200 Query the user whether to increase stack depth in shr * lisp/net/shr.el (shr-insert-document): Bind `max-specpdl-size' here... (bug#30675). (shr-descend): So that we can increase it temporarily here if the user wants to. diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 655f1420b0..275b36f900 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -274,6 +274,7 @@ DOM should be a parse tree as generated by (not (shr--have-one-fringe-p))) (* (frame-char-width) 2) 0))))) + (max-specpdl-size max-specpdl-size) bidi-display-reordering) ;; If the window was hscrolled for some reason, shr-fill-lines ;; below will misbehave, because it silently assumes that it @@ -523,8 +524,11 @@ size, and full-buffer size." (shr-depth (1+ shr-depth)) (start (point))) ;; shr uses many frames per nested node. - (if (> shr-depth (/ max-specpdl-size 15)) - (setq shr-warning "Too deeply nested to render properly; consider increasing `max-specpdl-size'") + (if (and (> shr-depth (/ max-specpdl-size 15)) + (not (and (y-or-n-p "Too deeply nested to render properly; increase `max-specpdl-size'?") + (setq max-specpdl-size (* max-specpdl-size 2))))) + (setq shr-warning + "Not rendering the complete page because of too-deep nesting") (when style (if (string-match "color\\|display\\|border-collapse" style) (setq shr-stylesheet (nconc (shr-parse-style style) commit e348910c7fe1d256a1d360bb2380221b1409d496 Author: Lars Ingebrigtsen Date: Sun Apr 15 18:33:37 2018 +0200 Minor copy edit of etc/NEWS diff --git a/etc/NEWS b/etc/NEWS index 1303379726..5aa92e2991 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -204,8 +204,8 @@ from 'gnus-score-find-favourite-words'. has a search engine. +++ -*** Splitting mail on common mailing list has been added. See the -concept index in the Gnus manual for the `match-list' entry. +*** Splitting mail on common mailing list headers has been added. See +the concept index in the Gnus manual for the `match-list' entry. +++ *** nil is no longer an allowed value for `mm-text-html-renderer'. commit 7cbe9628d145d222ddcb2cb9b036a9c2d5017fe8 Author: Lars Ingebrigtsen Date: Sun Apr 15 18:14:49 2018 +0200 * src/lread.c (openp): Add a comment before the now-obscure loop. diff --git a/src/lread.c b/src/lread.c index 5fe4d26fd9..65d22af693 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1587,6 +1587,8 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, absolute = complete_filename_p (str); + /* Go through all entries in the path and see whether we find the + executable. */ do { ptrdiff_t baselen, prefixlen; commit 874a724734ddc0332a3a82c7a29c5cf850ede420 Author: Lars Ingebrigtsen Date: Sun Apr 15 18:13:23 2018 +0200 Clarify menu entry in previous check-in * lisp/gnus/gnus-sum.el (gnus-summary-make-menu-bar): Menu bar entry for it. diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index 165d8f9649..b68dfdf6b7 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -2629,7 +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 a message" gnus-summary-attach-article 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"] commit bea6ae4e3e0814a4dbc81655d9e5ac36064bec1d Author: Lars Ingebrigtsen Date: Sun Apr 15 18:02:50 2018 +0200 Add new command `gnus-summary-attach-article' * doc/misc/gnus.texi (Summary Message Commands): Document it. * lisp/gnus/gnus-msg.el (gnus-summary-attach-article): New command and keystroke (bug#19788). * lisp/gnus/gnus-sum.el (gnus-summary-make-menu-bar): Menu bar entry for it. diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi index efda7f20b5..77c02182b4 100644 --- a/doc/misc/gnus.texi +++ b/doc/misc/gnus.texi @@ -5850,6 +5850,15 @@ buffer (@code{gnus-summary-yank-message}). This command prompts for what message buffer you want to yank into, and understands the process/prefix convention (@pxref{Process/Prefix}). +@item S A +@kindex S A @r{(Summary)} +@findex gnus-summary-attach-article +Attach the current article into an already existing Message +composition buffer (@code{gnus-summary-yank-message}). If no such +buffer exists, a new one is created. This command prompts for what +message buffer you want to yank into, and understands the +process/prefix convention (@pxref{Process/Prefix}). + @end table diff --git a/etc/NEWS b/etc/NEWS index 0c4daee9ac..1303379726 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -210,6 +210,12 @@ concept index in the Gnus manual for the `match-list' entry. +++ *** nil is no longer an allowed value for `mm-text-html-renderer'. ++++ +*** A new Gnus summary mode command, `S A' +(`gnus-summary-attach-article') can be used to attach the current +article(s) to a pre-existing Message buffer, or create a new Message +buffer with the article(s) attached. + ** erc --- diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el index d5610bff73..6505f90d3e 100644 --- a/lisp/gnus/gnus-msg.el +++ b/lisp/gnus/gnus-msg.el @@ -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 @@ -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-sum.el b/lisp/gnus/gnus-sum.el index aed5aaf01e..165d8f9649 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -2629,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 a 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"] commit c3ca885f4931a3b17b7e826cc866550d264d685a Author: Daiki Ueno Date: Sun Apr 15 16:11:46 2018 +0200 Divert to call `gnus-activate-group' with the SCAN argument set * lisp/gnus/gnus-group.el (gnus-group-get-new-news-this-group): Divert to call `gnus-activate-group' with the SCAN argument set, if request-group-scan is not defined for the backend. Ensure that the server is open when calling `gnus-request-group-scan' (bug#22649). diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index 1a3646800e..d1f258fd92 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -4105,9 +4105,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 commit eceb047cdb33b26422a95c97697ee78f8e3478e3 Author: Lars Ingebrigtsen Date: Sun Apr 15 15:48:44 2018 +0200 Abort Gnus exit if we have unsaved Message buffers * lisp/gnus/gnus-group.el (gnus--abort-on-unsaved-message-buffers): New function (bug#28843). (gnus-group-exit): Use it to abort exit if we have unsaved Message buffers. diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index b4f482b60a..1a3646800e 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -4371,6 +4371,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). @@ -4382,6 +4385,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." commit a5f2403cc2d1fb81fa64d2e3650d3a59d47a5637 Author: Lars Ingebrigtsen Date: Sun Apr 15 15:17:15 2018 +0200 Avoid an infloop in shr filling when not using fonts * lisp/net/shr.el (shr-fill-line): If we have an indentation that's wider than the width of what we're trying to fill, just give up. This avoids an infloop when `shr-use-fonts' in nil. diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 5eb35b74dd..655f1420b0 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -719,44 +719,47 @@ size, and full-buffer size." `,(shr-face-background face)))) (setq start (point)) (setq shr-indentation (or continuation shr-indentation)) - (shr-vertical-motion shr-internal-width) - (when (looking-at " $") - (delete-region (point) (line-end-position))) - (while (not (eolp)) - ;; We have to do some folding. First find the first - ;; previous point suitable for folding. - (if (or (not (shr-find-fill-point (line-beginning-position))) - (= (point) start)) - ;; We had unbreakable text (for this width), so just go to - ;; the first space and carry on. - (progn - (beginning-of-line) - (skip-chars-forward " ") - (search-forward " " (line-end-position) 'move))) - ;; Success; continue. - (when (= (preceding-char) ?\s) - (delete-char -1)) - (let ((gap-start (point))) - (insert "\n") - (shr-indent) - (when (and (> (1- gap-start) (point-min)) - ;; The link on both sides of the newline are the - ;; same... - (equal (get-text-property (point) 'shr-url) - (get-text-property (1- gap-start) 'shr-url))) - ;; ... so we join the two bits into one link logically, but - ;; not visually. This makes navigation between links work - ;; well, but avoids underscores before the link on the next - ;; line when indented. - (let ((props (copy-sequence (text-properties-at (point))))) - ;; We don't want to use the faces on the indentation, because - ;; that's ugly. - (setq props (plist-put props 'face nil)) - (add-text-properties gap-start (point) props)))) - (setq start (point)) + ;; If we have an indentation that's wider than the width we're + ;; trying to fill to, then just give up and don't do any filling. + (when (< shr-indentation shr-internal-width) (shr-vertical-motion shr-internal-width) (when (looking-at " $") - (delete-region (point) (line-end-position)))))) + (delete-region (point) (line-end-position))) + (while (not (eolp)) + ;; We have to do some folding. First find the first + ;; previous point suitable for folding. + (if (or (not (shr-find-fill-point (line-beginning-position))) + (= (point) start)) + ;; We had unbreakable text (for this width), so just go to + ;; the first space and carry on. + (progn + (beginning-of-line) + (skip-chars-forward " ") + (search-forward " " (line-end-position) 'move))) + ;; Success; continue. + (when (= (preceding-char) ?\s) + (delete-char -1)) + (let ((gap-start (point))) + (insert "\n") + (shr-indent) + (when (and (> (1- gap-start) (point-min)) + ;; The link on both sides of the newline are the + ;; same... + (equal (get-text-property (point) 'shr-url) + (get-text-property (1- gap-start) 'shr-url))) + ;; ... so we join the two bits into one link logically, but + ;; not visually. This makes navigation between links work + ;; well, but avoids underscores before the link on the next + ;; line when indented. + (let ((props (copy-sequence (text-properties-at (point))))) + ;; We don't want to use the faces on the indentation, because + ;; that's ugly. + (setq props (plist-put props 'face nil)) + (add-text-properties gap-start (point) props)))) + (setq start (point)) + (shr-vertical-motion shr-internal-width) + (when (looking-at " $") + (delete-region (point) (line-end-position))))))) (defun shr-find-fill-point (start) (let ((bp (point))