commit 96de0503cd04f3cba7c4db94789b958e9775e2c6 (HEAD, refs/remotes/origin/master) Merge: 109da684c5 521470987b Author: Marcin Borkowski Date: Wed Jan 24 10:32:40 2018 +0100 Merge branch 'fix/bug-20871-cur' commit 109da684c5124e22505917fe0255ca66f2a6bfc9 Author: Glenn Morris Date: Tue Jan 23 20:55:09 2018 -0500 Avoid kill-emacs-hook errors hanging batch mode * src/emacs.c (Fkill_emacs): Prevent errors from kill-emacs-hook hanging Emacs in batch mode. (Bug#29955) diff --git a/src/emacs.c b/src/emacs.c index 84cd3ac8c8..8ea61b71fb 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -2024,7 +2024,10 @@ all of which are called before Emacs is actually killed. */ /* Fsignal calls emacs_abort () if it sees that waiting_for_input is set. */ waiting_for_input = 0; - run_hook (Qkill_emacs_hook); + if (noninteractive) + safe_run_hooks (Qkill_emacs_hook); + else + run_hook (Qkill_emacs_hook); #ifdef HAVE_X_WINDOWS /* Transfer any clipboards we own to the clipboard manager. */ commit 4c998b4e4f5f468264d3ea0bee5da586f32938e1 Author: Philipp Stephani Date: Tue Jan 23 23:39:18 2018 +0100 Add unit test for Bug#30005. * test/src/callint-tests.el (call-interactively/embedded-nulls): New unit test. diff --git a/test/src/callint-tests.el b/test/src/callint-tests.el index 8fc7edf010..9a812223ad 100644 --- a/test/src/callint-tests.el +++ b/test/src/callint-tests.el @@ -35,4 +35,12 @@ (cdr data) '("Invalid control letter `\u00FF' (#o377, #x00ff) in interactive calling string"))))) +(ert-deftest call-interactively/embedded-nulls () + "Check that Bug#30005 is fixed." + (should (equal (let ((unread-command-events '(?a ?b))) + (call-interactively (lambda (a b) + (interactive "ka\0a: \nkb: ") + (list a b)))) + '("a" "b")))) + ;;; callint-tests.el ends here commit 18139139c90574ddc8dcb4d91ffbc48a536c1fe1 Author: Stefan Monnier Date: Tue Jan 23 14:42:43 2018 -0500 Remove final uses of 'cl' in lisp/net * lisp/net/pop3.el: Use lexical-binding and cl-lib. (pop3-write-to-file): Remove unused var 'start'. (pop3-make-date): Remove unused var 'sign'. * lisp/net/rfc2104.el: Use lexical-binding and cl-lib. * lisp/net/shr-color.el: Use lexical-binding and cl-lib. * lisp/net/sieve-manage.el: Use lexical-binding and cl-lib. diff --git a/lisp/net/pop3.el b/lisp/net/pop3.el index c2385f7f7e..2a6807e1ac 100644 --- a/lisp/net/pop3.el +++ b/lisp/net/pop3.el @@ -1,4 +1,4 @@ -;;; pop3.el --- Post Office Protocol (RFC 1460) interface +;;; pop3.el --- Post Office Protocol (RFC 1460) interface -*- lexical-binding:t -*- ;; Copyright (C) 1996-2018 Free Software Foundation, Inc. @@ -32,7 +32,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'mail-utils) (defvar parse-time-months) @@ -237,8 +237,8 @@ Use streaming commands." (setq start-point (pop3-wait-for-messages process pop3-stream-length total-size start-point)) - (incf waited-for pop3-stream-length)) - (incf i)) + (cl-incf waited-for pop3-stream-length)) + (cl-incf i)) (pop3-wait-for-messages process (- count waited-for) total-size start-point))) @@ -249,7 +249,7 @@ Use streaming commands." (or (not total-size) (re-search-forward "^\\.\r?\n" nil t))) (re-search-forward "^-ERR " nil t)) - (decf count) + (cl-decf count) (setq start-point (point))) (unless (memq (process-status process) '(open run)) (error "pop3 process died")) @@ -269,7 +269,6 @@ Use streaming commands." (defun pop3-write-to-file (file messages) (let ((pop-buffer (current-buffer)) - (start (point-min)) beg end temp-buffer) (with-temp-buffer @@ -280,7 +279,6 @@ Use streaming commands." (forward-line 1) (setq beg (point)) (when (re-search-forward "^\\.\r?\n" nil t) - (setq start (point)) (forward-line -1) (setq end (point))) (with-current-buffer temp-buffer @@ -369,7 +367,7 @@ Use streaming commands." (while (> i 0) (unless (member (nth (1- i) pop3-uidl) saved) (push i messages)) - (decf i))) + (cl-decf i))) (when messages (setq list (pop3-list process) size 0) @@ -399,7 +397,7 @@ Return non-nil if it is necessary to update the local UIDL file." (unless (member (setq uidl (nth i pop3-uidl)) (cdr saved)) (push ctime new) (push uidl new)) - (decf i))) + (cl-decf i))) (pop3-uidl (setq new (mapcan (lambda (elt) (list elt ctime)) pop3-uidl)))) (when new (setq mod t)) @@ -424,7 +422,7 @@ Return non-nil if it is necessary to update the local UIDL file." (push uidl new))) ;; Mails having been deleted in the server. (setq mod t)) - (decf i 2)) + (cl-decf i 2)) (cond (saved (setcdr saved new)) (srvr @@ -440,7 +438,7 @@ Return non-nil if it is necessary to update the local UIDL file." (while (> i 0) (when (member (nth (1- i) pop3-uidl) dele) (push i uidl)) - (decf i)) + (cl-decf i)) (when uidl (pop3-send-streaming-command process "DELE" uidl nil))) mod)) @@ -620,10 +618,8 @@ Return the response string if optional second argument is non-nil." If NOW, use that time instead." (require 'parse-time) (let* ((now (or now (current-time))) - (zone (nth 8 (decode-time now))) - (sign "+")) + (zone (nth 8 (decode-time now)))) (when (< zone 0) - (setq sign "-") (setq zone (- zone))) (concat (format-time-string "%d" now) @@ -785,7 +781,7 @@ Otherwise, return the size of the message-id MSG" (pop3-send-command process (format "DELE %s" msg)) (pop3-read-response process)) -(defun pop3-noop (process msg) +(defun pop3-noop (process _msg) "No-operation." (pop3-send-command process "NOOP") (pop3-read-response process)) diff --git a/lisp/net/rfc2104.el b/lisp/net/rfc2104.el index d974ab6a77..57bca2e878 100644 --- a/lisp/net/rfc2104.el +++ b/lisp/net/rfc2104.el @@ -1,4 +1,4 @@ -;;; rfc2104.el --- RFC2104 Hashed Message Authentication Codes +;;; rfc2104.el --- RFC2104 Hashed Message Authentication Codes -*- lexical-binding:t -*- ;; Copyright (C) 1998-2018 Free Software Foundation, Inc. @@ -55,7 +55,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;; Magic character for inner HMAC round. 0x36 == 54 == '6' (defconst rfc2104-ipad ?\x36) @@ -101,7 +101,7 @@ In XEmacs return just STRING." (opad (make-string (+ block-length hash-length) rfc2104-opad)) c partial) ;; Prefix *pad with key, appropriately XORed. - (do ((i 0 (1+ i))) + (cl-do ((i 0 (1+ i))) ((= len i)) (setq c (aref key i)) (aset ipad i (logxor rfc2104-ipad c)) @@ -110,8 +110,8 @@ In XEmacs return just STRING." (setq partial (rfc2104-string-make-unibyte (funcall hash (concat ipad text)))) ;; Pack latter part of opad. - (do ((r 0 (+ 2 r)) - (w block-length (1+ w))) + (cl-do ((r 0 (+ 2 r)) + (w block-length (1+ w))) ((= (* 2 hash-length) r)) (aset opad w (+ (* 16 (aref rfc2104-nybbles (aref partial r))) diff --git a/lisp/net/shr-color.el b/lisp/net/shr-color.el index 60d44b3cd6..31f3d46ed6 100644 --- a/lisp/net/shr-color.el +++ b/lisp/net/shr-color.el @@ -1,4 +1,4 @@ -;;; shr-color.el --- Simple HTML Renderer color management +;;; shr-color.el --- Simple HTML Renderer color management -*- lexical-binding:t -*- ;; Copyright (C) 2010-2018 Free Software Foundation, Inc. @@ -27,7 +27,7 @@ ;;; Code: (require 'color) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defgroup shr-color nil "Simple HTML Renderer colors" @@ -209,8 +209,8 @@ This will convert \"80 %\" to 204, \"100 %\" to 255 but \"123\" to \"123\"." (defun shr-color-hue-to-rgb (x y h) "Convert X Y H to RGB value." - (when (< h 0) (incf h)) - (when (> h 1) (decf h)) + (when (< h 0) (cl-incf h)) + (when (> h 1) (cl-decf h)) (cond ((< h (/ 6.0)) (+ x (* (- y x) h 6))) ((< h 0.5) y) ((< h (/ 2.0 3.0)) (+ x (* (- y x) (- (/ 2.0 3.0) h) 6))) @@ -258,8 +258,7 @@ Like rgb() or hsl()." (let ((h (/ (string-to-number (match-string-no-properties 1 color)) 360.0)) (s (/ (string-to-number (match-string-no-properties 2 color)) 100.0)) (l (/ (string-to-number (match-string-no-properties 3 color)) 100.0))) - (destructuring-bind (r g b) - (shr-color-hsl-to-rgb-fractions h s l) + (pcase-let ((`(,r ,g ,b) (shr-color-hsl-to-rgb-fractions h s l))) (color-rgb-to-hex r g b 2)))) ;; Color names ((cdr (assoc-string color shr-color-html-colors-alist t))) diff --git a/lisp/net/sieve-manage.el b/lisp/net/sieve-manage.el index e6a1e8401d..cd40307238 100644 --- a/lisp/net/sieve-manage.el +++ b/lisp/net/sieve-manage.el @@ -1,4 +1,4 @@ -;;; sieve-manage.el --- Implementation of the managesieve protocol in elisp +;;; sieve-manage.el --- Implementation of the managesieve protocol in elisp -*- lexical-binding:t -*- ;; Copyright (C) 2001-2018 Free Software Foundation, Inc. @@ -75,7 +75,7 @@ (require 'password-cache) (require 'password)) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'sasl) (require 'starttls) (autoload 'sasl-find-mechanism "sasl") @@ -182,7 +182,7 @@ Valid states are `closed', `initial', `nonauth', and `auth'.") (generate-new-buffer (format " *sieve %s:%s*" sieve-manage-server sieve-manage-port)) - (mapc 'make-local-variable sieve-manage-local-variables) + (mapc #'make-local-variable sieve-manage-local-variables) (mm-enable-multibyte) (buffer-disable-undo) (current-buffer))) @@ -206,19 +206,19 @@ Return the buffer associated with the connection." (with-current-buffer buffer (sieve-manage-erase) (setq sieve-manage-state 'initial) - (destructuring-bind (proc . props) - (open-network-stream - "SIEVE" buffer server port - :type stream - :capability-command "CAPABILITY\r\n" - :end-of-command "^\\(OK\\|NO\\).*\n" - :success "^OK.*\n" - :return-list t - :starttls-function - (lambda (capabilities) - (when (and (not sieve-manage-ignore-starttls) - (string-match "\\bSTARTTLS\\b" capabilities)) - "STARTTLS\r\n"))) + (pcase-let ((`(,proc . ,props) + (open-network-stream + "SIEVE" buffer server port + :type stream + :capability-command "CAPABILITY\r\n" + :end-of-command "^\\(OK\\|NO\\).*\n" + :success "^OK.*\n" + :return-list t + :starttls-function + (lambda (capabilities) + (when (and (not sieve-manage-ignore-starttls) + (string-match "\\bSTARTTLS\\b" capabilities)) + "STARTTLS\r\n"))))) (setq sieve-manage-process proc) (setq sieve-manage-capability (sieve-manage-parse-capability (plist-get props :capabilities))) @@ -250,7 +250,7 @@ Return the buffer associated with the connection." ;; somehow. `(lambda (prompt) ,(copy-sequence user-password))) (step (sasl-next-step client nil)) - (tag (sieve-manage-send + (_tag (sieve-manage-send (concat "AUTHENTICATE \"" mech @@ -373,11 +373,11 @@ to work in." ;; Choose authenticator (when (and (null sieve-manage-auth) (not (eq sieve-manage-state 'auth))) - (dolist (auth sieve-manage-authenticators) + (cl-dolist (auth sieve-manage-authenticators) (when (funcall (nth 1 (assq auth sieve-manage-authenticator-alist)) buffer) (setq sieve-manage-auth auth) - (return))) + (cl-return))) (unless sieve-manage-auth (error "Couldn't figure out authenticator for server"))) (sieve-manage-erase) commit e41c1dc99e631886fafc5595d4f4c048f294af33 Author: Stefan Monnier Date: Tue Jan 23 14:13:50 2018 -0500 * lisp/net/imap.el: Use lexical-binding and cl-lib Require packages instead of autoloading their functions. (imap-send-command): Remove unused vars 'stream' and 'eol'. (imap-parse-response): Use pcase. (imap-parse-fetch): Remove unused arg 'response'. * lisp/format-spec.el: Don't require CL. diff --git a/lisp/format-spec.el b/lisp/format-spec.el index 31caf931ed..38ce69b6c4 100644 --- a/lisp/format-spec.el +++ b/lisp/format-spec.el @@ -24,8 +24,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - (defun format-spec (format specification) "Return a string based on FORMAT and SPECIFICATION. FORMAT is a string containing `format'-like specs like \"bash %u %k\", diff --git a/lisp/net/imap.el b/lisp/net/imap.el index 3d2a4f948b..36b96ca10a 100644 --- a/lisp/net/imap.el +++ b/lisp/net/imap.el @@ -1,4 +1,4 @@ -;;; imap.el --- imap library +;;; imap.el --- imap library -*- lexical-binding:t -*- ;; Copyright (C) 1998-2018 Free Software Foundation, Inc. @@ -135,20 +135,16 @@ ;;; Code: -(eval-when-compile (require 'cl)) -(eval-and-compile - ;; For Emacs <22.2 and XEmacs. - (unless (fboundp 'declare-function) (defmacro declare-function (&rest _r))) - (autoload 'sasl-find-mechanism "sasl") - (autoload 'digest-md5-parse-digest-challenge "digest-md5") - (autoload 'digest-md5-digest-response "digest-md5") - (autoload 'digest-md5-digest-uri "digest-md5") - (autoload 'digest-md5-challenge "digest-md5") - (autoload 'rfc2104-hash "rfc2104") - (autoload 'utf7-encode "utf7") - (autoload 'utf7-decode "utf7") - (autoload 'format-spec "format-spec") - (autoload 'format-spec-make "format-spec")) +(eval-when-compile (require 'cl-lib)) +(require 'format-spec) +(require 'utf7) +(require 'rfc2104) +;; Hmm... digest-md5 is not part of Emacs. +;; FIXME: Should/can we use sasl-digest.el instead? +(declare-function digest-md5-parse-digest-challenge "digest-md5") +(declare-function digest-md5-digest-response "digest-md5") +(declare-function digest-md5-digest-uri "digest-md5") +(declare-function digest-md5-challenge "digest-md5") ;; User variables. @@ -1900,9 +1896,7 @@ on failure." (setq cmdstr nil) (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE)) (setq command nil) ;; abort command if no cont-req - (let ((process imap-process) - (stream imap-stream) - (eol imap-client-eol)) + (let ((process imap-process)) (with-current-buffer cmd (imap-log cmd) (process-send-region process (point-min) @@ -1956,7 +1950,7 @@ on failure." 'INCOMPLETE 'OK)))))) -(defun imap-sentinel (process string) +(defun imap-sentinel (process _string) (delete-process process)) (defun imap-find-next-line () @@ -2145,7 +2139,7 @@ Return nil if no complete line has arrived." (imap-forward) (nreverse addresses))) ;; With assert, the code might not be eval'd. - ;; (assert (imap-parse-nil) t "In imap-parse-address-list") + ;; (cl-assert (imap-parse-nil) t "In imap-parse-address-list") (imap-parse-nil))) ;; mailbox = "INBOX" / astring @@ -2218,72 +2212,72 @@ Return nil if no complete line has arrived." (defun imap-parse-response () "Parse an IMAP command response." (let (token) - (case (setq token (read (current-buffer))) - (+ (setq imap-continuation - (or (buffer-substring (min (point-max) (1+ (point))) - (point-max)) - t))) - (* (case (prog1 (setq token (read (current-buffer))) - (imap-forward)) - (OK (imap-parse-resp-text)) - (NO (imap-parse-resp-text)) - (BAD (imap-parse-resp-text)) - (BYE (imap-parse-resp-text)) - (FLAGS (imap-mailbox-put 'flags (imap-parse-flag-list))) - (LIST (imap-parse-data-list 'list)) - (LSUB (imap-parse-data-list 'lsub)) - (SEARCH (imap-mailbox-put - 'search - (read (concat "(" (buffer-substring (point) (point-max)) ")")))) - (STATUS (imap-parse-status)) - (CAPABILITY (setq imap-capability + (pcase (setq token (read (current-buffer))) + ('+ (setq imap-continuation + (or (buffer-substring (min (point-max) (1+ (point))) + (point-max)) + t))) + ('* (pcase (prog1 (setq token (read (current-buffer))) + (imap-forward)) + ('OK (imap-parse-resp-text)) + ('NO (imap-parse-resp-text)) + ('BAD (imap-parse-resp-text)) + ('BYE (imap-parse-resp-text)) + ('FLAGS (imap-mailbox-put 'flags (imap-parse-flag-list))) + ('LIST (imap-parse-data-list 'list)) + ('LSUB (imap-parse-data-list 'lsub)) + ('SEARCH (imap-mailbox-put + 'search + (read (concat "(" (buffer-substring (point) (point-max)) ")")))) + ('STATUS (imap-parse-status)) + ('CAPABILITY (setq imap-capability (read (concat "(" (upcase (buffer-substring (point) (point-max))) ")")))) - (ID (setq imap-id (read (buffer-substring (point) - (point-max))))) - (ACL (imap-parse-acl)) - (t (case (prog1 (read (current-buffer)) - (imap-forward)) - (EXISTS (imap-mailbox-put 'exists token)) - (RECENT (imap-mailbox-put 'recent token)) - (EXPUNGE t) - (FETCH (imap-parse-fetch token)) - (t (message "Garbage: %s" (buffer-string))))))) - (t (let (status) + ('ID (setq imap-id (read (buffer-substring (point) + (point-max))))) + ('ACL (imap-parse-acl)) + (_ (pcase (prog1 (read (current-buffer)) + (imap-forward)) + ('EXISTS (imap-mailbox-put 'exists token)) + ('RECENT (imap-mailbox-put 'recent token)) + ('EXPUNGE t) + ('FETCH (imap-parse-fetch)) + (_ (message "Garbage: %s" (buffer-string))))))) + (_ (let (status) (if (not (integerp token)) (message "Garbage: %s" (buffer-string)) - (case (prog1 (setq status (read (current-buffer))) - (imap-forward)) - (OK (progn - (setq imap-reached-tag (max imap-reached-tag token)) - (imap-parse-resp-text))) - (NO (progn - (setq imap-reached-tag (max imap-reached-tag token)) - (save-excursion - (imap-parse-resp-text)) - (let (code text) - (when (eq (char-after) ?\[) - (setq code (buffer-substring (point) - (search-forward "]"))) - (imap-forward)) - (setq text (buffer-substring (point) (point-max))) - (push (list token status code text) - imap-failed-tags)))) - (BAD (progn - (setq imap-reached-tag (max imap-reached-tag token)) - (save-excursion - (imap-parse-resp-text)) - (let (code text) - (when (eq (char-after) ?\[) - (setq code (buffer-substring (point) - (search-forward "]"))) - (imap-forward)) - (setq text (buffer-substring (point) (point-max))) - (push (list token status code text) imap-failed-tags) - (error "Internal error, tag %s status %s code %s text %s" - token status code text)))) - (t (message "Garbage: %s" (buffer-string)))) + (pcase (prog1 (setq status (read (current-buffer))) + (imap-forward)) + ('OK (progn + (setq imap-reached-tag (max imap-reached-tag token)) + (imap-parse-resp-text))) + ('NO (progn + (setq imap-reached-tag (max imap-reached-tag token)) + (save-excursion + (imap-parse-resp-text)) + (let (code text) + (when (eq (char-after) ?\[) + (setq code (buffer-substring (point) + (search-forward "]"))) + (imap-forward)) + (setq text (buffer-substring (point) (point-max))) + (push (list token status code text) + imap-failed-tags)))) + ('BAD (progn + (setq imap-reached-tag (max imap-reached-tag token)) + (save-excursion + (imap-parse-resp-text)) + (let (code text) + (when (eq (char-after) ?\[) + (setq code (buffer-substring (point) + (search-forward "]"))) + (imap-forward)) + (setq text (buffer-substring (point) (point-max))) + (push (list token status code text) imap-failed-tags) + (error "Internal error, tag %s status %s code %s text %s" + token status code text)))) + (_ (message "Garbage: %s" (buffer-string)))) (when (assq token imap-callbacks) (funcall (cdr (assq token imap-callbacks)) token status) (setq imap-callbacks @@ -2459,7 +2453,7 @@ Return nil if no complete line has arrived." (search-forward "]" nil t)) section))) -(defun imap-parse-fetch (response) +(defun imap-parse-fetch () (when (eq (char-after) ?\() (let (uid flags envelope internaldate rfc822 rfc822header rfc822text rfc822size body bodydetail bodystructure flags-empty) @@ -2593,7 +2587,7 @@ Return nil if no complete line has arrived." (defun imap-parse-flag-list () (let (flag-list start) - (assert (eq (char-after) ?\() nil "In imap-parse-flag-list 1") + (cl-assert (eq (char-after) ?\() nil "In imap-parse-flag-list 1") (while (and (not (eq (char-after) ?\))) (setq start (progn (imap-forward) @@ -2602,7 +2596,7 @@ Return nil if no complete line has arrived." (point))) (> (skip-chars-forward "^ )" (point-at-eol)) 0)) (push (buffer-substring start (point)) flag-list)) - (assert (eq (char-after) ?\)) nil "In imap-parse-flag-list 2") + (cl-assert (eq (char-after) ?\)) nil "In imap-parse-flag-list 2") (imap-forward) (nreverse flag-list))) @@ -2687,7 +2681,7 @@ Return nil if no complete line has arrived." (while (eq (char-after) ?\ ) (imap-forward) (push (imap-parse-body-extension) b-e)) - (assert (eq (char-after) ?\)) nil "In imap-parse-body-extension") + (cl-assert (eq (char-after) ?\)) nil "In imap-parse-body-extension") (imap-forward) (nreverse b-e)) (or (imap-parse-number) @@ -2716,7 +2710,7 @@ Return nil if no complete line has arrived." (push (imap-parse-string-list) dsp) (imap-forward)) ;; With assert, the code might not be eval'd. - ;; (assert (imap-parse-nil) t "In imap-parse-body-ext") + ;; (cl-assert (imap-parse-nil) t "In imap-parse-body-ext") (imap-parse-nil)) (push (nreverse dsp) ext)) (when (eq (char-after) ?\ ) ;; body-fld-lang @@ -2813,7 +2807,7 @@ Return nil if no complete line has arrived." (push (and (imap-parse-nil) nil) body)) (setq body (append (imap-parse-body-ext) body))) ;; body-ext-... - (assert (eq (char-after) ?\)) nil "In imap-parse-body") + (cl-assert (eq (char-after) ?\)) nil "In imap-parse-body") (imap-forward) (nreverse body)) @@ -2879,7 +2873,7 @@ Return nil if no complete line has arrived." (push (imap-parse-nstring) body) ;; body-fld-md5 (setq body (append (imap-parse-body-ext) body))) ;; body-ext-1part.. - (assert (eq (char-after) ?\)) nil "In imap-parse-body 2") + (cl-assert (eq (char-after) ?\)) nil "In imap-parse-body 2") (imap-forward) (nreverse body))))) commit 5ed5f548aaa1f3fa7941895d48f97ad970b38ff1 Author: Stefan Monnier Date: Tue Jan 23 13:55:35 2018 -0500 * lisp/gnus/message.el: Tweak header font-lock and ecomplete completion (message-font-lock-make-header-matcher): Delete. (message-match-to-eoh): New function to replace it. (message-font-lock-keywords): Use it. (message-strip-forbidden-properties): Remove redundant binding. (message-goto-body): Avoid called-interactively-p, only use push-mark when called interactively. (message-goto-body-1): Merge into message-goto-body. Redefine as alias. (message-goto-eoh): Call message-goto-body interactively. (message--in-tocc-p): New function, extracted from message-display-abbrev. (message-ecomplete-capf): New function. diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 93b897b2be..a0adccef7a 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -1544,50 +1544,49 @@ starting with `not' and followed by regexps." "Face used for displaying MML." :group 'message-faces) -(defun message-font-lock-make-header-matcher (regexp) - (let ((form - `(lambda (limit) - (let ((start (point))) - (save-restriction - (widen) - (goto-char (point-min)) - (if (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "$") - nil t) - (setq limit (min limit (match-beginning 0)))) - (goto-char start)) - (and (< start limit) - (re-search-forward ,regexp limit t)))))) - (if (featurep 'bytecomp) - (byte-compile form) - form))) +(defun message-match-to-eoh (_limit) + (let ((start (point))) + (rfc822-goto-eoh) + ;; Typical situation: some temporary change causes the header to be + ;; incorrect, so EOH comes earlier than intended: the last lines of the + ;; intended headers are now not considered part of the header any more, + ;; so they don't have the multiline property set. When the change is + ;; completed and the header has its correct shape again, the lack of the + ;; multiline property means we won't rehighlight the last lines of + ;; the header. + (if (< (point) start) + nil ;No header within start..limit. + ;; Here we disregard LIMIT so that we may extend the area again. + (set-match-data (list start (point))) + (point)))) (defvar message-font-lock-keywords (let ((content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)\n?")) - `((,(message-font-lock-make-header-matcher - (concat "^\\([Tt]o:\\)" content)) - (1 'message-header-name) - (2 'message-header-to nil t)) - (,(message-font-lock-make-header-matcher - (concat "^\\(^[GBF]?[Cc][Cc]:\\|^[Rr]eply-[Tt]o:\\)" content)) - (1 'message-header-name) - (2 'message-header-cc nil t)) - (,(message-font-lock-make-header-matcher - (concat "^\\([Ss]ubject:\\)" content)) - (1 'message-header-name) - (2 'message-header-subject nil t)) - (,(message-font-lock-make-header-matcher - (concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content)) - (1 'message-header-name) - (2 'message-header-newsgroups nil t)) - (,(message-font-lock-make-header-matcher - (concat "^\\(X-[A-Za-z0-9-]+:\\|In-Reply-To:\\)" content)) - (1 'message-header-name) - (2 'message-header-xheader)) - (,(message-font-lock-make-header-matcher - (concat "^\\([A-Z][^: \n\t]+:\\)" content)) - (1 'message-header-name) - (2 'message-header-other nil t)) + `((message-match-to-eoh + (,(concat "^\\([Tt]o:\\)" content) + (progn (goto-char (match-beginning 0)) (match-end 0)) nil + (1 'message-header-name) + (2 'message-header-to nil t)) + (,(concat "^\\(^[GBF]?[Cc][Cc]:\\|^[Rr]eply-[Tt]o:\\)" content) + (progn (goto-char (match-beginning 0)) (match-end 0)) nil + (1 'message-header-name) + (2 'message-header-cc nil t)) + (,(concat "^\\([Ss]ubject:\\)" content) + (progn (goto-char (match-beginning 0)) (match-end 0)) nil + (1 'message-header-name) + (2 'message-header-subject nil t)) + (,(concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content) + (progn (goto-char (match-beginning 0)) (match-end 0)) nil + (1 'message-header-name) + (2 'message-header-newsgroups nil t)) + (,(concat "^\\(X-[A-Za-z0-9-]+:\\|In-Reply-To:\\)" content) + (progn (goto-char (match-beginning 0)) (match-end 0)) nil + (1 'message-header-name) + (2 'message-header-xheader)) + (,(concat "^\\([A-Z][^: \n\t]+:\\)" content) + (progn (goto-char (match-beginning 0)) (match-end 0)) nil + (1 'message-header-name) + (2 'message-header-other nil t))) ,@(if (and mail-header-separator (not (equal mail-header-separator ""))) `((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$") @@ -2821,8 +2820,7 @@ See also `message-forbidden-properties'." (message-display-abbrev)) (when (and message-strip-special-text-properties (message-tamago-not-in-use-p begin)) - (let ((buffer-read-only nil) - (inhibit-read-only t)) + (let ((inhibit-read-only t)) (remove-text-properties begin end message-forbidden-properties)))) (defvar message-smileys '(":-)" ":)" @@ -2929,7 +2927,7 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." (easy-menu-add message-mode-menu message-mode-map) (easy-menu-add message-mode-field-menu message-mode-map) ;; Mmmm... Forbidden properties... - (add-hook 'after-change-functions 'message-strip-forbidden-properties + (add-hook 'after-change-functions #'message-strip-forbidden-properties nil 'local) ;; Allow mail alias things. (cond @@ -2937,7 +2935,9 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." (mail-abbrevs-setup)) ((message-mail-alias-type-p 'ecomplete) (ecomplete-setup))) - (add-hook 'completion-at-point-functions 'message-completion-function nil t) + ;; FIXME: merge the completion tables from ecomplete/bbdb/...? + ;;(add-hook 'completion-at-point-functions #'message-ecomplete-capf nil t) + (add-hook 'completion-at-point-functions #'message-completion-function nil t) (unless buffer-file-name (message-set-auto-save-file-name)) (unless (buffer-base-buffer) @@ -3071,17 +3071,15 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." (push-mark) (message-position-on-field "Summary" "Subject")) -(defun message-goto-body () - "Move point to the beginning of the message body." - (interactive) - (when (and (called-interactively-p 'any) - (looking-at "[ \t]*\n")) +(define-obsolete-function-alias 'message-goto-body-1 'message-goto-body "27.1") +(defun message-goto-body (&optional interactive) + "Move point to the beginning of the message body. +Returns point." + (interactive "p") + (when interactive + (when (looking-at "[ \t]*\n") (expand-abbrev)) - (push-mark) - (message-goto-body-1)) - -(defun message-goto-body-1 () - "Go to the body and return point." + (push-mark)) (goto-char (point-min)) (or (search-forward (concat "\n" mail-header-separator "\n") nil t) ;; If the message is mangled, find the end of the headers the @@ -3100,12 +3098,12 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." "Return t if point is in the message body." (>= (point) (save-excursion - (message-goto-body-1)))) + (message-goto-body)))) -(defun message-goto-eoh () +(defun message-goto-eoh (&optional interactive) "Move point to the end of the headers." - (interactive) - (message-goto-body) + (interactive "p") + (message-goto-body interactive) (forward-line -1)) (defun message-goto-signature () @@ -7882,6 +7880,7 @@ When FORCE, rebuild the tool bar." :type 'regexp) (defcustom message-completion-alist + ;; FIXME: Make it possible to use the standard completion UI. (list (cons message-newgroups-header-regexp 'message-expand-group) '("^\\(Resent-\\)?\\(To\\|B?Cc\\):" . message-expand-name) '("^\\(Reply-To\\|From\\|Mail-Followup-To\\|Mail-Copies-To\\):" @@ -8206,16 +8205,19 @@ From headers in the original article." (autoload 'ecomplete-display-matches "ecomplete") +(defun message--in-tocc-p () + (and (memq (char-after (point-at-bol)) '(?C ?T ?\t ? )) + (message-point-in-header-p) + (save-excursion + (beginning-of-line) + (while (and (memq (char-after) '(?\t ? )) + (zerop (forward-line -1)))) + (looking-at "To:\\|Cc:")))) + (defun message-display-abbrev (&optional choose) "Display the next possible abbrev for the text before point." (interactive (list t)) - (when (and (memq (char-after (point-at-bol)) '(?C ?T ?\t ? )) - (message-point-in-header-p) - (save-excursion - (beginning-of-line) - (while (and (memq (char-after) '(?\t ? )) - (zerop (forward-line -1)))) - (looking-at "To:\\|Cc:"))) + (when (message--in-tocc-p) (let* ((end (point)) (start (save-excursion (and (re-search-backward "[\n\t ]" nil t) @@ -8228,6 +8230,20 @@ From headers in the original article." (delete-region start end) (insert match))))) +(defun message-ecomplete-capf () + "Return completion data for email addresses in Ecomplete. +Meant for use on `completion-at-point-functions'." + (when (and (bound-and-true-p ecomplete-database) + (fboundp 'ecomplete-completion-table) + (message--in-tocc-p)) + (let ((end (save-excursion + (skip-chars-forward "^, \t\n") + (point))) + (start (save-excursion + (skip-chars-backward "^, \t\n") + (point)))) + `(,start ,end ,(apply-partially #'ecomplete-completion-table 'mail))))) + ;; To send pre-formatted letters like the example below, you can use ;; `message-send-form-letter': ;; --8<---------------cut here---------------start------------->8--- commit f2918640bf35d6bb0130f854b2ea8ed4b4fd89d4 Author: Stefan Monnier Date: Tue Jan 23 12:14:48 2018 -0500 * lisp/ecomplete.el: Add completion-table; use lexical-binding and cl-lib Also remove redundant :group args. (ecomplete-database-file): Use locate-user-emacs-file. (ecomplete-completion-table): New completion table. (completion-category-defaults): Set default behavior for that table. diff --git a/etc/NEWS b/etc/NEWS index d30f0b087c..bb84396df9 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -94,6 +94,13 @@ non-text modes. * Changes in Specialized Modes and Packages in Emacs 27.1 +** Ecomplete +*** The ecomplete sorting has changed to a decay-based algorithm. +This can be controlled by the new `ecomplete-sort-predicate' variable. + +*** The 'ecompleterc' file is now placed in ~/.emacs.d/ecompleterc by default +Of course it will still find it if you have it in ~/.ecompleterc + ** Smtpmail Authentication mechanisms can be added via external packages, by defining new cl-defmethod of smtpmail-try-auth-method. @@ -237,9 +244,6 @@ It's a simple convenience function for looking up MIME types based on file name extensions. +++ -** The ecomplete sorting has changed to a decay-based algorithm. This -can be controlled by the new `ecomplete-sort-predicate' variable. - ** The new function 'read-answer' accepts either long or short answers depending on the new customizable variable 'read-answer-short'. diff --git a/lisp/ecomplete.el b/lisp/ecomplete.el index 3f0d21c230..3bfab4743c 100644 --- a/lisp/ecomplete.el +++ b/lisp/ecomplete.el @@ -1,4 +1,4 @@ -;;; ecomplete.el --- electric completion of addresses and the like +;;; ecomplete.el --- electric completion of addresses and the like -*- lexical-binding:t -*- ;; Copyright (C) 2006-2018 Free Software Foundation, Inc. @@ -53,22 +53,20 @@ ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defgroup ecomplete nil "Electric completion of email addresses and the like." :group 'mail) -(defcustom ecomplete-database-file "~/.ecompleterc" +(defcustom ecomplete-database-file + (locate-user-emacs-file "ecompleterc" "~/.ecompleterc") "The name of the file to store the ecomplete data." - :group 'ecomplete :type 'file) (defcustom ecomplete-database-file-coding-system 'iso-2022-7bit "Coding system used for writing the ecomplete database file." - :type '(symbol :tag "Coding system") - :group 'ecomplete) + :type '(symbol :tag "Coding system")) (defcustom ecomplete-sort-predicate 'ecomplete-decay "Predicate to use when sorting matched. @@ -80,8 +78,7 @@ string that was matched." :type '(radio (function-item :tag "Sort by usage and newness" ecomplete-decay) (function-item :tag "Sort by times used" ecomplete-usage) (function-item :tag "Sort by newness" ecomplete-newness) - (function :tag "Other")) - :group 'ecomplete) + (function :tag "Other"))) ;;; Internal variables. @@ -116,13 +113,13 @@ string that was matched." (with-temp-buffer (let ((coding-system-for-write ecomplete-database-file-coding-system)) (insert "(") - (loop for (type . elems) in ecomplete-database - do - (insert (format "(%s\n" type)) - (dolist (entry elems) - (prin1 entry (current-buffer)) - (insert "\n")) - (insert ")\n")) + (cl-loop for (type . elems) in ecomplete-database + do + (insert (format "(%s\n" type)) + (dolist (entry elems) + (prin1 entry (current-buffer)) + (insert "\n")) + (insert ")\n")) (insert ")") (write-region (point-min) (point-max) ecomplete-database-file nil 'silent)))) @@ -132,9 +129,9 @@ string that was matched." (match (regexp-quote match)) (candidates (sort - (loop for (key count time text) in elems - when (string-match match text) - collect (list count time text)) + (cl-loop for (_key count time text) in elems + when (string-match match text) + collect (list count time text)) ecomplete-sort-predicate))) (when (> (length candidates) 10) (setcdr (nthcdr 10 candidates) nil)) @@ -183,9 +180,7 @@ matches." (lookup-key local-map command)) (apply (key-binding command) nil) (setq highlight (ecomplete-highlight-match-line matches line)))) - (if selected - (message selected) - (message "Abort")) + (message (or selected "Abort")) selected))))) (defun ecomplete-highlight-match-line (matches line) @@ -218,6 +213,31 @@ matches." (expt 1.05 (/ (- (float-time) (cadr elem)) (* 7 24 60 60))))) +;; `ecomplete-get-matches' uses substring matching, so also use the `substring' +;; style by default. +(add-to-list 'completion-category-defaults + '(ecomplete (styles basic substring))) + +(defun ecomplete-completion-table (type) + "Return a completion-table suitable for TYPE." + (lambda (string pred action) + (pcase action + (`(boundaries . ,_) nil) + ('metadata `(metadata (category . ecomplete) + (display-sort-function . ,#'identity) + (cycle-sort-function . ,#'identity))) + (_ + (let* ((elems (cdr (assq type ecomplete-database))) + (candidates + (mapcar (lambda (x) (nth 2 x)) + (sort + (cl-loop for x in elems + when (string-prefix-p string (nth 3 x) + completion-ignore-case) + collect (cdr x)) + ecomplete-sort-predicate)))) + (complete-with-action action candidates string pred)))))) + (provide 'ecomplete) ;;; ecomplete.el ends here commit 6d836771da7e9a6a67fcd18e52dd16de1cdc154e Author: Eli Zaretskii Date: Tue Jan 23 17:48:08 2018 +0200 Support null characters in interactive specs * src/callint.c (Fcall_interactively): Support 'interactive' specifications with embedded null characters. (Bug#30005) diff --git a/src/callint.c b/src/callint.c index 2253cdf3b4..3d2ed0016c 100644 --- a/src/callint.c +++ b/src/callint.c @@ -288,7 +288,8 @@ invoke it. If KEYS is omitted or nil, the return value of ptrdiff_t next_event; Lisp_Object prefix_arg; - char *string; + char *string, *string_end; + ptrdiff_t string_len; const char *tem; /* If varies[i] > 0, the i'th argument shouldn't just have its value @@ -396,6 +397,8 @@ invoke it. If KEYS is omitted or nil, the return value of /* SPECS is set to a string; use it as an interactive prompt. Copy it so that STRING will be valid even if a GC relocates SPECS. */ SAFE_ALLOCA_STRING (string, specs); + string_len = SBYTES (specs); + string_end = string + string_len; /* Here if function specifies a string to control parsing the defaults. */ @@ -418,7 +421,7 @@ invoke it. If KEYS is omitted or nil, the return value of if (!NILP (record_flag)) { char *p = string; - while (*p) + while (p < string_end) { if (! (*p == 'r' || *p == 'p' || *p == 'P' || *p == '\n')) @@ -469,7 +472,7 @@ invoke it. If KEYS is omitted or nil, the return value of `funcall-interactively') plus the number of arguments the interactive spec would have us give to the function. */ tem = string; - for (nargs = 2; *tem; ) + for (nargs = 2; tem < string_end; ) { /* 'r' specifications ("point and mark as 2 numeric args") produce *two* arguments. */ @@ -477,7 +480,7 @@ invoke it. If KEYS is omitted or nil, the return value of nargs += 2; else nargs++; - tem = strchr (tem, '\n'); + tem = memchr (tem, '\n', string_len - (tem - string)); if (tem) ++tem; else @@ -503,9 +506,12 @@ invoke it. If KEYS is omitted or nil, the return value of specbind (Qenable_recursive_minibuffers, Qt); tem = string; - for (i = 2; *tem; i++) + for (i = 2; tem < string_end; i++) { - visargs[1] = make_string (tem + 1, strcspn (tem + 1, "\n")); + char *pnl = memchr (tem + 1, '\n', string_len - (tem + 1 - string)); + ptrdiff_t sz = pnl ? pnl - (tem + 1) : string_end - (tem + 1); + + visargs[1] = make_string (tem + 1, sz); callint_message = Fformat_message (i - 1, visargs + 1); switch (*tem) @@ -781,7 +787,7 @@ invoke it. If KEYS is omitted or nil, the return value of { /* How many bytes are left unprocessed in the specs string? (Note that this excludes the trailing null byte.) */ - ptrdiff_t bytes_left = SBYTES (specs) - (tem - string); + ptrdiff_t bytes_left = string_len - (tem - string); unsigned letter; /* If we have enough bytes left to treat the sequence as a @@ -803,9 +809,9 @@ invoke it. If KEYS is omitted or nil, the return value of if (NILP (visargs[i]) && STRINGP (args[i])) visargs[i] = args[i]; - tem = strchr (tem, '\n'); + tem = memchr (tem, '\n', string_len - (tem - string)); if (tem) tem++; - else tem = ""; + else tem = string_end; } unbind_to (speccount, Qnil); commit 521470987b198fcadff294a8e3c700be21b1a15c Author: Marcin Borkowski Date: Tue Jan 2 09:47:52 2018 +0100 Add simple tests for the `fill-polish-nobreak-p' function * test/lisp/textmodes/fill-tests.el: (fill-test-no-fill-polish-nobreak-p): New test diff --git a/test/lisp/textmodes/fill-tests.el b/test/lisp/textmodes/fill-tests.el new file mode 100644 index 0000000000..03323090f9 --- /dev/null +++ b/test/lisp/textmodes/fill-tests.el @@ -0,0 +1,50 @@ +;;; fill-test.el --- ERT tests for fill.el -*- lexical-binding: t -*- + +;; Copyright (C) 2017 Free Software Foundation, Inc. + +;; Author: Marcin Borkowski +;; Keywords: text, wp + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; This package defines tests for the filling feature, specifically +;; the `fill-polish-nobreak-p' function. + +;;; Code: + +(require 'ert) + +(ert-deftest fill-test-no-fill-polish-nobreak-p nil + "Tests of the `fill-polish-nobreak-p' function." + (with-temp-buffer + (insert "Abc d efg (h ijk).") + (setq fill-column 8) + (setq-local fill-nobreak-predicate '()) + (fill-paragraph) + (should (string= (buffer-string) "Abc d\nefg (h\nijk)."))) + (with-temp-buffer + (insert "Abc d efg (h ijk).") + (setq fill-column 8) + (setq-local fill-nobreak-predicate '(fill-polish-nobreak-p)) + (fill-paragraph) + (should (string= (buffer-string) "Abc\nd efg\n(h ijk).")))) + + +(provide 'fill-tests) + +;;; fill-tests.el ends here commit a1f257d81c58eb3069928ed584b06c4bcb2c7111 Author: Marcin Borkowski Date: Wed Apr 27 08:59:15 2016 +0200 Add the function `fill-polish-nobreak-p' * lisp/textmodes/fill.el (fill-polish-nobreak-p): Prevent line-breaking after a single-letter word even if this word is not preceded by a space. Fixes bug #20871. diff --git a/doc/emacs/text.texi b/doc/emacs/text.texi index 846d9fe8c6..2f180f82ca 100644 --- a/doc/emacs/text.texi +++ b/doc/emacs/text.texi @@ -636,8 +636,11 @@ line. If a function returns a non-@code{nil} value, Emacs will not break the line there. Functions you can use there include: @code{fill-single-word-nobreak-p} (don't break after the first word of a sentence or before the last); @code{fill-single-char-nobreak-p} -(don't break after a one-letter word); and @code{fill-french-nobreak-p} -(don't break after @samp{(} or before @samp{)}, @samp{:} or @samp{?}). +(don't break after a one-letter word preceded by a whitespace +character); @code{fill-french-nobreak-p} (don't break after @samp{(} +or before @samp{)}, @samp{:} or @samp{?}); and +@code{fill-polish-nobreak-p} (don't break after a one letter word, +even if preceded by a non-whitespace character). @node Fill Prefix @subsection The Fill Prefix diff --git a/etc/NEWS b/etc/NEWS index 1d546c4ec1..ed1f931547 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -69,6 +69,11 @@ detect built-in libxml support, instead of testing for that indirectly, e.g., by checking that functions like 'libxml-parse-html-region' return nil. ++++ +** New function 'fill-polish-nobreak-p', to be used in 'fill-nobreak-predicate'. +It blocks line breaking after a one-letter word, also in the case when +this word is preceded by a non-space, but non-alphanumeric character. + * Editing Changes in Emacs 27.1 diff --git a/lisp/textmodes/fill.el b/lisp/textmodes/fill.el index a46f0b2a4c..6d37be870b 100644 --- a/lisp/textmodes/fill.el +++ b/lisp/textmodes/fill.el @@ -339,6 +339,18 @@ places." (and (memq (preceding-char) '(?\t ?\s)) (eq (char-syntax (following-char)) ?w))))))) +(defun fill-polish-nobreak-p () + "Return nil if Polish style allows breaking the line at point. +This function may be used in the `fill-nobreak-predicate' hook. +It is almost the same as `fill-single-char-nobreak-p', with the +exception that it does not require the one-letter word to be +preceded by a space. This blocks line-breaking in cases like +\"(a jednak)\"." + (save-excursion + (skip-chars-backward " \t") + (backward-char 2) + (looking-at "[^[:alpha:]]\\cl"))) + (defun fill-single-char-nobreak-p () "Return non-nil if a one-letter word is before point. This function is suitable for adding to the hook `fill-nobreak-predicate',