commit 5dff4905d73d0d42447ff4b114d1af726a689c6a (HEAD, refs/remotes/origin/master) Author: Paul Eggert Date: Tue Apr 17 16:23:16 2018 -0700 Fix signal for large integers with valid syntax * src/lread.c (read_integer): If a radixed integer has valid syntax but is waayyy too large, signal overflow instead of invalid syntax. * test/src/lread-tests.el (lread-long-hex-integer): New test. diff --git a/src/lread.c b/src/lread.c index 65d22af693..6eda740540 100644 --- a/src/lread.c +++ b/src/lread.c @@ -2644,14 +2644,13 @@ read_integer (Lisp_Object readcharfun, EMACS_INT radix) Also, room for invalid syntax diagnostic. */ char buf[max (1 + 1 + UINTMAX_WIDTH + 1, sizeof "integer, radix " + INT_STRLEN_BOUND (EMACS_INT))]; - + char *p = buf; int valid = -1; /* 1 if valid, 0 if not, -1 if incomplete. */ if (radix < 2 || radix > 36) valid = 0; else { - char *p = buf; int c, digit; c = READCHAR; @@ -2679,17 +2678,12 @@ read_integer (Lisp_Object readcharfun, EMACS_INT radix) valid = 0; if (valid < 0) valid = 1; - - if (p < buf + sizeof buf - 1) - *p++ = c; - else - valid = 0; - + *p = c; + p += p < buf + sizeof buf; c = READCHAR; } UNREAD (c); - *p = '\0'; } if (valid != 1) @@ -2698,6 +2692,13 @@ read_integer (Lisp_Object readcharfun, EMACS_INT radix) invalid_syntax (buf); } + if (p == buf + sizeof buf) + { + memset (p - 3, '.', 3); + xsignal1 (Qoverflow_error, make_unibyte_string (buf, sizeof buf)); + } + + *p = '\0'; return string_to_number (buf, radix, 0); } diff --git a/test/src/lread-tests.el b/test/src/lread-tests.el index daf5343881..708701a888 100644 --- a/test/src/lread-tests.el +++ b/test/src/lread-tests.el @@ -194,4 +194,9 @@ literals (Bug#20852)." (lread--substitute-object-in-subtree x 1 t) (should (eq x (cdr x))))) +(ert-deftest lread-long-hex-integer () + (should-error + (read "#xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff") + :type 'overflow-error)) + ;;; lread-tests.el ends here commit 2457d10ebfedbd24040e30e70cca90c6e523afe0 Author: Lars Ingebrigtsen Date: Wed Apr 18 01:22:49 2018 +0200 (sql-stop): Don't bug out if the SQL buffer is killed * lisp/progmodes/sql.el (sql-stop): Don't bug out if the SQL buffer is killed (bug#30244). diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el index f907a01d8c..ebbef8d89e 100644 --- a/lisp/progmodes/sql.el +++ b/lisp/progmodes/sql.el @@ -4031,15 +4031,16 @@ Writes the input history to a history file using This function is a sentinel watching the SQL interpreter process. Sentinels will always get the two parameters PROCESS and EVENT." - (with-current-buffer (process-buffer process) - (let - ((comint-input-ring-separator sql-input-ring-separator) - (comint-input-ring-file-name sql-input-ring-file-name)) - (comint-write-input-ring)) - - (if (not buffer-read-only) - (insert (format "\nProcess %s %s\n" process event)) - (message "Process %s %s" process event)))) + (when (buffer-live-p (process-buffer process)) + (with-current-buffer (process-buffer process) + (let + ((comint-input-ring-separator sql-input-ring-separator) + (comint-input-ring-file-name sql-input-ring-file-name)) + (comint-write-input-ring)) + + (if (not buffer-read-only) + (insert (format "\nProcess %s %s\n" process event)) + (message "Process %s %s" process event))))) commit 2e54ffebb8555d23f72c7b450b481f0335562b0d Author: David Beswick Date: Tue Apr 17 23:53:55 2018 +0200 Don't display an initial-buffer-choice buffer twice * lisp/startup.el (command-line-1): Don't display an initial-buffer-choice buffer twice if the user is also explicitly specifying it on the mode line, but shift it to the initial place (bug#29999). Copyright-paperwork-exempt: yes diff --git a/lisp/startup.el b/lisp/startup.el index 1faeabf23b..f6907a821b 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -2504,7 +2504,12 @@ nil default-directory" name) (insert (substitute-command-keys initial-scratch-message)) (set-buffer-modified-p nil)))) - ;; Prepend `initial-buffer-choice' to `displayable-buffers'. + ;; Prepend `initial-buffer-choice' to `displayable-buffers'. If + ;; the buffer is already a member of that list then shift the + ;; buffer to the head of the list. The shift behavior is intended + ;; to prevent the same buffer being displayed in two windows when + ;; an `initial-buffer-choice' function happens to return the head + ;; of `displayable-buffers'. (when initial-buffer-choice (let ((buf (cond ((stringp initial-buffer-choice) @@ -2517,7 +2522,7 @@ nil default-directory" name) (error "initial-buffer-choice must be a string, a function, or t."))))) (unless (buffer-live-p buf) (error "initial-buffer-choice is not a live buffer.")) - (setq displayable-buffers (cons buf displayable-buffers)))) + (setq displayable-buffers (cons buf (delq buf displayable-buffers))))) ;; Display the first two buffers in `displayable-buffers'. If ;; `initial-buffer-choice' is non-nil, its buffer will be the commit d2d1f39536e32dc6789ee2d26aeda05a405d47d3 Author: Lars Ingebrigtsen Date: Tue Apr 17 23:26:11 2018 +0200 Revert hunk mistakenly applied in last patch diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el index ebbef8d89e..f907a01d8c 100644 --- a/lisp/progmodes/sql.el +++ b/lisp/progmodes/sql.el @@ -4031,16 +4031,15 @@ Writes the input history to a history file using This function is a sentinel watching the SQL interpreter process. Sentinels will always get the two parameters PROCESS and EVENT." - (when (buffer-live-p (process-buffer process)) - (with-current-buffer (process-buffer process) - (let - ((comint-input-ring-separator sql-input-ring-separator) - (comint-input-ring-file-name sql-input-ring-file-name)) - (comint-write-input-ring)) - - (if (not buffer-read-only) - (insert (format "\nProcess %s %s\n" process event)) - (message "Process %s %s" process event))))) + (with-current-buffer (process-buffer process) + (let + ((comint-input-ring-separator sql-input-ring-separator) + (comint-input-ring-file-name sql-input-ring-file-name)) + (comint-write-input-ring)) + + (if (not buffer-read-only) + (insert (format "\nProcess %s %s\n" process event)) + (message "Process %s %s" process event)))) commit e3b0dd6bf118c60ba41a09e3ffdce056b2e7c494 Author: Lars Ingebrigtsen Date: Tue Apr 17 23:14:55 2018 +0200 Fix problem in `g' in Info with strings like "(foo)" * lisp/info.el (Info-find-file): Add a new parameter to avoid jumping to the directory if the user looks for a filename on the form "(foo)" that doesn't exist. (Info-read-node-name-1): Use it to allow completing over strings like "(foo)" without losing focus (bug#30091). diff --git a/lisp/info.el b/lisp/info.el index 8743b44997..0db84fb3da 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -868,10 +868,13 @@ In standalone mode, \\\\[Info-exit] exits Emacs itself." (forward-line 1) ; does the line after delimiter match REGEXP? (re-search-backward regexp beg t)))) -(defun Info-find-file (filename &optional noerror) +(defun Info-find-file (filename &optional noerror no-pop-to-dir) "Return expanded FILENAME, or t if FILENAME is \"dir\". Optional second argument NOERROR, if t, means if file is not found -just return nil (no error)." +just return nil (no error). + +If NO-POP-TO-DIR, don't try to pop to the info buffer if we can't +find a node." ;; Convert filename to lower case if not found as specified. ;; Expand it. (cond @@ -930,7 +933,8 @@ just return nil (no error)." (if noerror (setq filename nil) ;; If there is no previous Info file, go to the directory. - (unless Info-current-file + (when (and (not no-pop-to-dir) + (not Info-current-file)) (Info-directory)) (user-error "Info file %s does not exist" filename))) filename)))) @@ -1868,7 +1872,7 @@ See `completing-read' for a description of arguments and usage." (lambda (string pred action) (complete-with-action action - (Info-build-node-completions (Info-find-file file1)) + (Info-build-node-completions (Info-find-file file1 nil t)) string pred)) nodename predicate code)))) ;; Otherwise use Info-read-node-completion-table. diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el index f907a01d8c..ebbef8d89e 100644 --- a/lisp/progmodes/sql.el +++ b/lisp/progmodes/sql.el @@ -4031,15 +4031,16 @@ Writes the input history to a history file using This function is a sentinel watching the SQL interpreter process. Sentinels will always get the two parameters PROCESS and EVENT." - (with-current-buffer (process-buffer process) - (let - ((comint-input-ring-separator sql-input-ring-separator) - (comint-input-ring-file-name sql-input-ring-file-name)) - (comint-write-input-ring)) - - (if (not buffer-read-only) - (insert (format "\nProcess %s %s\n" process event)) - (message "Process %s %s" process event)))) + (when (buffer-live-p (process-buffer process)) + (with-current-buffer (process-buffer process) + (let + ((comint-input-ring-separator sql-input-ring-separator) + (comint-input-ring-file-name sql-input-ring-file-name)) + (comint-write-input-ring)) + + (if (not buffer-read-only) + (insert (format "\nProcess %s %s\n" process event)) + (message "Process %s %s" process event))))) commit f10fa789ca8f0feff0e85df3624270604ed54dd6 Author: Basil L. Contovounesios Date: Tue Apr 17 21:46:26 2018 +0200 Set :version of shr faces * lisp/net/shr.el (shr-strike-through, shr-link, shr-selected-link): Set :version tag (bug#31200). diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 5507fab4db..1103a93024 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -137,16 +137,19 @@ cid: URL as the argument.") (defface shr-strike-through '((t :strike-through t)) "Face for elements." + :version "24.1" :group 'shr) (defface shr-link '((t :inherit link)) "Face for link elements." + :version "24.1" :group 'shr) (defface shr-selected-link '((t :inherit shr-link :background "red")) "Face for link elements." + :version "27.1" :group 'shr) (defvar shr-inhibit-images nil commit d742d4ca2ec1e01fbc2dcc1332c5b6daa0ff03dd Author: Lars Ingebrigtsen Date: Tue Apr 17 21:43:34 2018 +0200 shr doc string fix * lisp/net/shr.el (shr-strike-through, shr-link) (shr-selected-link): Doc string fix. diff --git a/lisp/net/shr.el b/lisp/net/shr.el index ca70c5c656..5507fab4db 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -136,17 +136,17 @@ cid: URL as the argument.") "Function called to put image and alt string.") (defface shr-strike-through '((t :strike-through t)) - "Font for elements." + "Face for elements." :group 'shr) (defface shr-link '((t :inherit link)) - "Font for link elements." + "Face for link elements." :group 'shr) (defface shr-selected-link '((t :inherit shr-link :background "red")) - "Font for link elements." + "Face for link elements." :group 'shr) (defvar shr-inhibit-images nil commit 3dfec182d25ed438dc6d4a91f4201e2f7e0c99ec Author: Basil L. Contovounesios Date: Tue Apr 17 21:42:04 2018 +0200 Modernise face specs and set version tags in eww/shr * lisp/net/shr.el (shr-strike-through, shr-link, shr-selected-link): Set :version tag (bug#31200). * lisp/net/eww.el (eww-form-text, eww-form-textarea): * lisp/net/shr.el (shr-strike-through, shr-link, shr-selected-link): Use (DISPLAY . PLIST) face spec syntax as recommended in '(elisp) Defining Faces'. diff --git a/lisp/net/eww.el b/lisp/net/eww.el index f737189612..e74f661ac7 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -186,17 +186,17 @@ See also `eww-form-checkbox-selected-symbol'." :group 'eww) (defface eww-form-text - '((t (:background "#505050" - :foreground "white" - :box (:line-width 1)))) + '((t :background "#505050" + :foreground "white" + :box (:line-width 1))) "Face for eww text inputs." :version "24.4" :group 'eww) (defface eww-form-textarea - '((t (:background "#C0C0C0" - :foreground "black" - :box (:line-width 1)))) + '((t :background "#C0C0C0" + :foreground "black" + :box (:line-width 1))) "Face for eww textarea inputs." :version "24.4" :group 'eww) diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 0fc7ccf958..ca70c5c656 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -135,17 +135,17 @@ cid: URL as the argument.") (defvar shr-put-image-function 'shr-put-image "Function called to put image and alt string.") -(defface shr-strike-through '((t (:strike-through t))) +(defface shr-strike-through '((t :strike-through t)) "Font for elements." :group 'shr) (defface shr-link - '((t (:inherit link))) + '((t :inherit link)) "Font for link elements." :group 'shr) (defface shr-selected-link - '((t (:inherit shr-link :background "red"))) + '((t :inherit shr-link :background "red")) "Font for link elements." :group 'shr) commit c99ba231602a40792317976149500120c4959d1c Author: Lars Ingebrigtsen Date: Tue Apr 17 20:52:14 2018 +0200 When undoing a mark-as-read, display the group if it isn't * lisp/gnus/gnus-group.el (gnus-group-jump-to-group): Return whether we found the group. (gnus-info-clear-data): Make the group visible if it wasn't. * lisp/gnus/gnus-sum.el (gnus-group-make-articles-read): Ditto. (gnus-update-read-articles): Ditto. diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index 271c3c838b..6af27afbfa 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -2551,14 +2551,15 @@ If PROMPT (the prefix) is a number, use the prompt specified in (when (equal group "") (error "Empty group name")) - (unless (gnus-ephemeral-group-p group) - ;; Either go to the line in the group buffer... - (unless (gnus-group-goto-group group) - ;; ... or insert the line. - (gnus-group-update-group group) - (gnus-group-goto-group group))) - ;; Adjust cursor point. - (gnus-group-position-point)) + (prog1 + (unless (gnus-ephemeral-group-p group) + ;; Either go to the line in the group buffer... + (unless (gnus-group-goto-group group) + ;; ... or insert the line. + (gnus-group-update-group group) + (gnus-group-goto-group group))) + ;; Adjust cursor point. + (gnus-group-position-point))) (defun gnus-group-goto-group (group &optional far test-marked) "Goto to newsgroup GROUP. @@ -3560,7 +3561,7 @@ Obeys the process/prefix convention." (gnus-request-set-mark ,group ',action) (gnus-info-set-marks ',info ',(gnus-info-marks info) t) (gnus-info-set-read ',info ',(gnus-info-read info)) - (when (gnus-group-goto-group ,group) + (when (gnus-group-jump-to-group ,group) (gnus-get-unread-articles-in-group ',info ',(gnus-active group) t) (gnus-group-update-group-line)))) (setq action (mapcar (lambda (el) (list (nth 0 el) 'del (nth 2 el))) diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index 4c54ac59d6..e562b30170 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -6310,6 +6310,7 @@ The resulting hash table is returned, or nil if no Xrefs were found." (when ,set-marks (gnus-request-set-mark ,group (list (list ',range 'del '(read))))) + (gnus-group-jump-to-group ,group) (gnus-group-update-group ,group t)))) ;; Add the read articles to the range. (gnus-info-set-read info range) @@ -12726,6 +12727,7 @@ UNREAD is a sorted list." `(progn (gnus-info-set-marks ',info ',(gnus-info-marks info) t) (gnus-info-set-read ',info ',(gnus-info-read info)) + (gnus-group-jump-to-group ,group) (gnus-get-unread-articles-in-group ',info (gnus-active ,group)) (gnus-group-update-group ,group t) commit 0c9e3df3c2088b61feb4b4e00d24419459962273 Author: Juri Linkov Date: Tue Apr 17 22:27:48 2018 +0300 Use next-error-found to set next-error-last-buffer. https://lists.gnu.org/archive/html/emacs-devel/2018-04/msg00207.html * lisp/simple.el (next-error-buffer): New buffer-local variable instead of making buffer-local next-error-last-buffer. (Bug#20489) (next-error-found-function): New defcustom. (next-error-buffer-on-selected-frame): Use t for avoid-current arg of next-error-buffer-p. (next-error-find-buffer): Add second rule for using the current next-error-buffer if it's not visited by other navigation. (next-error, next-error-internal): Call next-error-found. (next-error-found): New function with body extracted mostly from next-error. * lisp/vc/add-log.el (change-log-goto-source-internal): New function with body from change-log-goto-source. (change-log-goto-source): Call change-log-goto-source-internal and next-error-found. (change-log-next-error): Call change-log-goto-source-internal instead of change-log-goto-source. (change-log-mode): Don't set next-error-last-buffer. (Bug#28864) * lisp/vc/diff-mode.el (diff-goto-source): Call next-error-found. * lisp/progmodes/xref.el (xref-goto-xref): Call next-error-found. * lisp/replace.el (occur-mode-goto-occurrence) (occur-mode-goto-occurrence-other-window) (occur-mode-display-occurrence): Call next-error-found. (occur-next-error): Remove unnecessary with-current-buffer. (Bug#27362, bug#30646) diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el index ee8886a4e1..b7c44d6083 100644 --- a/lisp/progmodes/grep.el +++ b/lisp/progmodes/grep.el @@ -354,17 +354,6 @@ See `compilation-error-screen-columns'" (defalias 'kill-grep 'kill-compilation) -;;;; TODO --- refine this!! - -;; (defcustom grep-use-compilation-buffer t -;; "When non-nil, grep specific commands update `compilation-last-buffer'. -;; This means that standard compile commands like \\[next-error] and \\[compile-goto-error] -;; can be used to navigate between grep matches (the default). -;; Otherwise, the grep specific commands like \\[grep-next-match] must -;; be used to navigate between grep matches." -;; :type 'boolean -;; :group 'grep) - ;; override compilation-last-buffer (defvar grep-last-buffer nil "The most recent grep buffer. @@ -1083,6 +1072,7 @@ This command shares argument histories with \\[rgrep] and \\[grep]." (concat command " " null-device) command) 'grep-mode)) + ;; Set default-directory if we started lgrep in the *grep* buffer. (if (eq next-error-last-buffer (current-buffer)) (setq default-directory dir)))))) diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index 5a9a7a925a..9a437b6f69 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -540,9 +540,11 @@ SELECT is `quit', also quit the *xref* window." Non-interactively, non-nil QUIT means to first quit the *xref* buffer." (interactive) - (let ((xref (or (xref--item-at-point) + (let ((buffer (current-buffer)) + (xref (or (xref--item-at-point) (user-error "No reference at point")))) - (xref--show-location (xref-item-location xref) (if quit 'quit t)))) + (xref--show-location (xref-item-location xref) (if quit 'quit t)) + (next-error-found buffer (current-buffer)))) (defun xref-quit-and-goto-xref () "Quit *xref* buffer, then jump to xref on current line." diff --git a/lisp/replace.el b/lisp/replace.el index 4916cb138e..058e14452d 100644 --- a/lisp/replace.el +++ b/lisp/replace.el @@ -1192,7 +1192,8 @@ To return to ordinary Occur mode, use \\[occur-cease-edit]." (defun occur-mode-goto-occurrence (&optional event) "Go to the occurrence on the current line." (interactive (list last-nonmenu-event)) - (let ((pos + (let ((buffer (when event (current-buffer))) + (pos (if (null event) ;; Actually `event-end' works correctly with a nil argument as ;; well, so we could dispense with this test, but let's not @@ -1204,26 +1205,31 @@ To return to ordinary Occur mode, use \\[occur-cease-edit]." (occur-mode-find-occurrence)))))) (pop-to-buffer (marker-buffer pos)) (goto-char pos) + (when buffer (next-error-found buffer (current-buffer))) (run-hooks 'occur-mode-find-occurrence-hook))) (defun occur-mode-goto-occurrence-other-window () "Go to the occurrence the current line describes, in another window." (interactive) - (let ((pos (occur-mode-find-occurrence))) + (let ((buffer (current-buffer)) + (pos (occur-mode-find-occurrence))) (switch-to-buffer-other-window (marker-buffer pos)) (goto-char pos) + (next-error-found buffer (current-buffer)) (run-hooks 'occur-mode-find-occurrence-hook))) (defun occur-mode-display-occurrence () "Display in another window the occurrence the current line describes." (interactive) - (let ((pos (occur-mode-find-occurrence)) + (let ((buffer (current-buffer)) + (pos (occur-mode-find-occurrence)) window) (setq window (display-buffer (marker-buffer pos) t)) ;; This is the way to set point in the proper window. (save-selected-window (select-window window) (goto-char pos) + (next-error-found buffer (current-buffer)) (run-hooks 'occur-mode-find-occurrence-hook)))) (defun occur-find-match (n search message) @@ -1253,29 +1259,20 @@ To return to ordinary Occur mode, use \\[occur-cease-edit]." "Move to the Nth (default 1) next match in an Occur mode buffer. Compatibility function for \\[next-error] invocations." (interactive "p") - ;; we need to run occur-find-match from within the Occur buffer - (with-current-buffer - ;; Choose the buffer and make it current. - (if (next-error-buffer-p (current-buffer)) - (current-buffer) - (next-error-find-buffer nil nil - (lambda () - (eq major-mode 'occur-mode)))) - - (goto-char (cond (reset (point-min)) - ((< argp 0) (line-beginning-position)) - ((> argp 0) (line-end-position)) - ((point)))) - (occur-find-match - (abs argp) - (if (> 0 argp) - #'previous-single-property-change - #'next-single-property-change) - "No more matches") - ;; In case the *Occur* buffer is visible in a nonselected window. - (let ((win (get-buffer-window (current-buffer) t))) - (if win (set-window-point win (point)))) - (occur-mode-goto-occurrence))) + (goto-char (cond (reset (point-min)) + ((< argp 0) (line-beginning-position)) + ((> argp 0) (line-end-position)) + ((point)))) + (occur-find-match + (abs argp) + (if (> 0 argp) + #'previous-single-property-change + #'next-single-property-change) + "No more matches") + ;; In case the *Occur* buffer is visible in a nonselected window. + (let ((win (get-buffer-window (current-buffer) t))) + (if win (set-window-point win (point)))) + (occur-mode-goto-occurrence)) (defface match '((((class color) (min-colors 88) (background light)) diff --git a/lisp/simple.el b/lisp/simple.el index 7d94b64913..b51be3a8f8 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -122,11 +122,13 @@ A buffer becomes most recent when its compilation, grep, or similar mode is started, or when it is used with \\[next-error] or \\[compile-goto-error].") -;; next-error-last-buffer is made buffer-local to keep the reference +(defvar next-error-buffer nil + "The buffer-local value of the most recent `next-error' buffer.") +;; next-error-buffer is made buffer-local to keep the reference ;; to the parent buffer used to navigate to the current buffer, so the ;; next call of next-buffer will use the same parent buffer to ;; continue navigation from it. -(make-variable-buffer-local 'next-error-last-buffer) +(make-variable-buffer-local 'next-error-buffer) (defvar next-error-function nil "Function to use to find the next error in the current buffer. @@ -177,14 +179,23 @@ rejected, and the function returns nil." (defcustom next-error-find-buffer-function #'ignore "Function called to find a `next-error' capable buffer." - :type '(choice (const :tag "Single next-error capable buffer on selected frame" + :type '(choice (const :tag "No default" ignore) + (const :tag "Single next-error capable buffer on selected frame" next-error-buffer-on-selected-frame) - (const :tag "No default" ignore) (function :tag "Other function")) :group 'next-error :version "27.1") -(defun next-error-buffer-on-selected-frame (&optional avoid-current +(defcustom next-error-found-function #'ignore + "Function called when a next locus is found and displayed. +Function is called with two arguments: a FROM-BUFFER buffer +from which next-error navigated, and a target buffer TO-BUFFER." + :type '(choice (const :tag "No default" ignore) + (function :tag "Other function")) + :group 'next-error + :version "27.1") + +(defun next-error-buffer-on-selected-frame (&optional _avoid-current extra-test-inclusive extra-test-exclusive) "Return a single visible next-error buffer on the selected frame." @@ -193,7 +204,7 @@ rejected, and the function returns nil." (delq nil (mapcar (lambda (w) (if (next-error-buffer-p (window-buffer w) - avoid-current + t extra-test-inclusive extra-test-exclusive) (window-buffer w))) (window-list)))))) @@ -220,16 +231,24 @@ that buffer is rejected." (funcall next-error-find-buffer-function avoid-current extra-test-inclusive extra-test-exclusive) - ;; 2. If next-error-last-buffer is an acceptable buffer, use that. + ;; 2. If next-error-buffer has no buffer-local value + ;; (i.e. never navigated to the current buffer from another), + ;; and the current buffer is a `next-error' capable buffer, + ;; use it unconditionally, so next-error will always use it. + (if (and (not (local-variable-p 'next-error-buffer)) + (next-error-buffer-p (current-buffer) avoid-current + extra-test-inclusive extra-test-exclusive)) + (current-buffer)) + ;; 3. If next-error-last-buffer is an acceptable buffer, use that. (if (and next-error-last-buffer (next-error-buffer-p next-error-last-buffer avoid-current extra-test-inclusive extra-test-exclusive)) next-error-last-buffer) - ;; 3. If the current buffer is acceptable, choose it. + ;; 4. If the current buffer is acceptable, choose it. (if (next-error-buffer-p (current-buffer) avoid-current extra-test-inclusive extra-test-exclusive) (current-buffer)) - ;; 4. Look for any acceptable buffer. + ;; 5. Look for any acceptable buffer. (let ((buffers (buffer-list))) (while (and buffers (not (next-error-buffer-p @@ -237,7 +256,7 @@ that buffer is rejected." extra-test-inclusive extra-test-exclusive))) (setq buffers (cdr buffers))) (car buffers)) - ;; 5. Use the current buffer as a last resort if it qualifies, + ;; 6. Use the current buffer as a last resort if it qualifies, ;; even despite AVOID-CURRENT. (and avoid-current (next-error-buffer-p (current-buffer) nil @@ -245,7 +264,7 @@ that buffer is rejected." (progn (message "This is the only buffer with error message locations") (current-buffer))) - ;; 6. Give up. + ;; 7. Give up. (error "No buffers contain error message locations"))) (defun next-error (&optional arg reset) @@ -284,37 +303,35 @@ To control which errors are matched, customize the variable (when buffer ;; We know here that next-error-function is a valid symbol we can funcall (with-current-buffer buffer - ;; Allow next-error to be used from the next-error capable buffer. - (setq next-error-last-buffer buffer) (funcall next-error-function (prefix-numeric-value arg) reset) - ;; Override possible change of next-error-last-buffer in next-error-function - (setq next-error-last-buffer buffer) - (setq-default next-error-last-buffer buffer) - (when next-error-recenter - (recenter next-error-recenter)) - (message "%s error from %s" + (next-error-found buffer (current-buffer)) + (message "%s locus from %s" (cond (reset "First") ((eq (prefix-numeric-value arg) 0) "Current") ((< (prefix-numeric-value arg) 0) "Previous") (t "Next")) - next-error-last-buffer) - (run-hooks 'next-error-hook))))) + next-error-last-buffer))))) (defun next-error-internal () "Visit the source code corresponding to the `next-error' message at point." (let ((buffer (current-buffer))) ;; We know here that next-error-function is a valid symbol we can funcall - (with-current-buffer buffer - ;; Allow next-error to be used from the next-error capable buffer. - (setq next-error-last-buffer buffer) - (funcall next-error-function 0 nil) - ;; Override possible change of next-error-last-buffer in next-error-function - (setq next-error-last-buffer buffer) - (setq-default next-error-last-buffer buffer) - (when next-error-recenter - (recenter next-error-recenter)) - (message "Current error from %s" next-error-last-buffer) - (run-hooks 'next-error-hook)))) + (funcall next-error-function 0 nil) + (next-error-found buffer (current-buffer)) + (message "Current locus from %s" next-error-last-buffer))) + +(defun next-error-found (&optional from-buffer to-buffer) + "Function to call when the next locus is found and displayed. +FROM-BUFFER is a buffer from which next-error navigated, +and TO-BUFFER is a target buffer." + (setq next-error-last-buffer (or from-buffer (current-buffer))) + (when to-buffer + (with-current-buffer to-buffer + (setq next-error-buffer from-buffer))) + (when next-error-recenter + (recenter next-error-recenter)) + (funcall next-error-found-function from-buffer to-buffer) + (run-hooks 'next-error-hook)) (defun next-error-select-buffer (buffer) "Select a `next-error' capable buffer and set it as the last used." @@ -322,8 +339,7 @@ To control which errors are matched, customize the variable (list (get-buffer (read-buffer "Select next-error buffer: " nil nil (lambda (b) (next-error-buffer-p (cdr b))))))) - (setq next-error-last-buffer buffer) - (setq-default next-error-last-buffer buffer)) + (setq next-error-last-buffer buffer)) (defalias 'goto-next-locus 'next-error) (defalias 'next-match 'next-error) diff --git a/lisp/vc/add-log.el b/lisp/vc/add-log.el index 175c82f8c0..41a9991699 100644 --- a/lisp/vc/add-log.el +++ b/lisp/vc/add-log.el @@ -471,6 +471,11 @@ A change log tag is a symbol within a parenthesized, comma-separated list. If no suitable tag can be found nearby, try to visit the file for the change under `point' instead." (interactive) + (let ((buffer (current-buffer))) + (change-log-goto-source-internal) + (next-error-found buffer (current-buffer)))) + +(defun change-log-goto-source-internal () (if (and (eq last-command 'change-log-goto-source) change-log-find-tail) (setq change-log-find-tail @@ -539,7 +544,7 @@ Compatibility function for \\[next-error] invocations." ;; if we found a place to visit... (when (looking-at change-log-file-names-re) (let (change-log-find-window) - (change-log-goto-source) + (change-log-goto-source-internal) (when change-log-find-window ;; Select window displaying source file. (select-window change-log-find-window))))) @@ -1067,8 +1072,7 @@ Runs `change-log-mode-hook'. (set (make-local-variable 'end-of-defun-function) 'change-log-end-of-defun) ;; next-error function glue - (setq next-error-function 'change-log-next-error) - (setq next-error-last-buffer (current-buffer))) + (setq next-error-function 'change-log-next-error)) (defun change-log-next-buffer (&optional buffer wrap) "Return the next buffer in the series of ChangeLog file buffers. diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index ef13f55b93..1e2fbb97fc 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -1874,11 +1874,13 @@ then `diff-jump-to-old-file' is also set, for the next invocations." ;; the old location, and else to the new (i.e. as if reverting). ;; This is a convenient detail when using smerge-diff. (if event (posn-set-point (event-end event))) - (let ((rev (not (save-excursion (beginning-of-line) (looking-at "[-<]"))))) + (let ((buffer (when event (current-buffer))) + (rev (not (save-excursion (beginning-of-line) (looking-at "[-<]"))))) (pcase-let ((`(,buf ,line-offset ,pos ,src ,_dst ,switched) (diff-find-source-location other-file rev))) (pop-to-buffer buf) (goto-char (+ (car pos) (cdr src))) + (when buffer (next-error-found buffer (current-buffer))) (diff-hunk-status-msg line-offset (diff-xor rev switched) t)))) commit d12800303fc1f3f6c45806ee0b1e638d20478938 Author: Lars Ingebrigtsen Date: Tue Apr 17 20:34:12 2018 +0200 Tweak shr window width computation * lisp/net/shr.el (shr-insert-document): The computation of the window width is apparently one pixel too wide for the shr line folding algorithm (bug#31196). diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 2d913a5a92..0fc7ccf958 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -274,7 +274,8 @@ DOM should be a parse tree as generated by (if (and (null shr-width) (not (shr--have-one-fringe-p))) (* (frame-char-width) 2) - 0))))) + 0) + 1)))) (max-specpdl-size max-specpdl-size) bidi-display-reordering) ;; If the window was hscrolled for some reason, shr-fill-lines commit 01a32a0f97134aca41df6895d23bcfcc51916b21 Author: Lars Ingebrigtsen Date: Tue Apr 17 20:09:28 2018 +0200 (gnus-summary-select-article-buffer): Further point placing tweak * lisp/gnus/gnus-sum.el (gnus-summary-select-article-buffer): Further tweak for the previous point-placing tweak. diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index 596afd1552..4c54ac59d6 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -7073,7 +7073,7 @@ buffer." (select-window (get-buffer-window gnus-article-buffer)) ;; If we've just selected the message, place point at the start of ;; the body because that's probably where we want to be. - (if (not (bobp)) + (if (not (= point (point-min))) (goto-char point) (article-goto-body) (forward-char -1))))) commit c90984250b31fa0d33064e85c3a243e6018f9592 Author: Lars Ingebrigtsen Date: Tue Apr 17 20:02:26 2018 +0200 Tweak point placement in gnus-summary-select-article-buffer * lisp/gnus/gnus-sum.el (gnus-summary-select-article-buffer): Ensure that point is where it's supposed to be after switching to the article buffer. diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index 234d527cd1..596afd1552 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -7063,17 +7063,20 @@ buffer." (or (get-buffer-window gnus-article-buffer) (eq gnus-current-article (gnus-summary-article-number)) (gnus-summary-show-article)) - (gnus-configure-windows - (if gnus-widen-article-window - 'only-article - 'article) - t) - (select-window (get-buffer-window gnus-article-buffer)) - ;; If we've just selected the message, place point at the start of - ;; the body because that's probably where we want to be. - (when (bobp) - (article-goto-body) - (forward-char -1)))) + (let ((point (with-current-buffer gnus-article-buffer + (point)))) + (gnus-configure-windows + (if gnus-widen-article-window + 'only-article + 'article) + t) + (select-window (get-buffer-window gnus-article-buffer)) + ;; If we've just selected the message, place point at the start of + ;; the body because that's probably where we want to be. + (if (not (bobp)) + (goto-char point) + (article-goto-body) + (forward-char -1))))) (defun gnus-summary-universal-argument (arg) "Perform any operation on all articles that are process/prefixed." commit 62a075b01678c6a6f5d2a69c9ea6904a3927f1b4 Author: Lars Ingebrigtsen Date: Tue Apr 17 19:34:40 2018 +0200 Make the `c' command work in a single-article Gnus view * lisp/gnus/gnus-art.el (gnus-article-read-summary-keys): Make `c' work from the article buffer (bug#31195) when no summary buffer is shown. diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 0b349ea2d2..869ff4e661 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -6673,7 +6673,7 @@ not have a face in `gnus-article-boring-faces'." (interactive "P") (gnus-article-check-buffer) (let ((nosaves - '("q" "Q" "c" "r" "\C-c\C-f" "m" "a" "f" "WDD" "WDW" + '("q" "Q" "r" "\C-c\C-f" "m" "a" "f" "WDD" "WDW" "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP" "=" "^" "\M-^" "|")) (nosave-but-article @@ -6739,7 +6739,8 @@ not have a face in `gnus-article-boring-faces'." ;; We disable the pick minor mode commands. (setq func (let (gnus-pick-mode) (key-binding keys t))) - (when (get func 'disabled) + (when (and (symbolp func) + (get func 'disabled)) (error "Function %s disabled" func)) (if (and func (functionp func) commit 1d5d23a9f69db81927ac802deb2ef7c5573bc6e9 Author: Lars Ingebrigtsen Date: Tue Apr 17 19:21:42 2018 +0200 Place point consistently in the Gnus group buffer on exit * lisp/gnus/gnus-sum.el (gnus-summary-exit): Place point correctly when exiting with `q' (and the like) from the article buffer when only the article buffer is displayed (bug#31195). This is apparently yet another fall-out from the "preserve-visible-point- in-windows" patches of yesteryear... diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index b68dfdf6b7..234d527cd1 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -7286,12 +7286,13 @@ If FORCE (the prefix), also save the .newsrc file(s)." (if quit-config (gnus-handle-ephemeral-exit quit-config) (goto-char group-point) + (unless leave-hidden + (gnus-configure-windows 'group 'force)) ;; If gnus-group-buffer is already displayed, make sure we also move ;; the cursor in the window that displays it. (let ((win (get-buffer-window (current-buffer) 0))) - (if win (set-window-point win (point)))) - (unless leave-hidden - (gnus-configure-windows 'group 'force))) + (goto-char group-point) + (if win (set-window-point win (point))))) ;; If we have several article buffers, we kill them at exit. (unless single-article-buffer commit 950d6cc74426f8d88c1c3985efb336a3a02b3b0e Author: Lars Ingebrigtsen Date: Tue Apr 17 18:53:09 2018 +0200 Reimplement `shr-next-link' and `shr-previous-link' * lisp/net/shr.el (shr-next-link): Use `text-property-search-forward'. (shr-previous-link): Use `text-property-search-backward'. diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 275b36f900..2d913a5a92 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -39,6 +39,7 @@ (require 'svg) (require 'image) (require 'puny) +(require 'text-property-search) (defgroup shr nil "Simple HTML Renderer" @@ -378,49 +379,18 @@ If the URL is already at the front of the kill ring act like (defun shr-next-link () "Skip to the next link." (interactive) - (let ((current (get-text-property (point) 'shr-url)) - (start (point)) - skip) - (while (and (not (eobp)) - (equal (get-text-property (point) 'shr-url) current)) - (forward-char 1)) - (cond - ((and (not (eobp)) - (get-text-property (point) 'shr-url)) - ;; The next link is adjacent. - (message "%s" (get-text-property (point) 'help-echo))) - ((or (eobp) - (not (setq skip (text-property-not-all (point) (point-max) - 'shr-url nil)))) - (goto-char start) - (message "No next link")) - (t - (goto-char skip) - (message "%s" (get-text-property (point) 'help-echo)))))) + (let ((match (text-property-search-forward 'shr-url nil nil t))) + (if (not match) + (message "No next link") + (goto-char (prop-match-beginning match)) + (message "%s" (get-text-property (point) 'help-echo))))) (defun shr-previous-link () "Skip to the previous link." (interactive) - (let ((start (point)) - (found nil)) - ;; Skip past the current link. - (while (and (not (bobp)) - (get-text-property (point) 'help-echo)) - (forward-char -1)) - ;; Find the previous link. - (while (and (not (bobp)) - (not (setq found (get-text-property (point) 'help-echo)))) - (forward-char -1)) - (if (not found) - (progn - (message "No previous link") - (goto-char start)) - ;; Put point at the start of the link. - (while (and (not (bobp)) - (get-text-property (point) 'help-echo)) - (forward-char -1)) - (forward-char 1) - (message "%s" (get-text-property (point) 'help-echo))))) + (if (not (text-property-search-backward 'shr-url nil nil t)) + (message "No previous link") + (message "%s" (get-text-property (point) 'help-echo)))) (defun shr-show-alt-text () "Show the ALT text of the image under point." commit 6f572972d19397d8295727a99b687fc521bd469e Author: Lars Ingebrigtsen Date: Tue Apr 17 18:51:41 2018 +0200 Add `text-property-search-forward' and `-backward' * doc/lispref/text.texi (Property Search): Document `text-property-search-forward' and `text-property-search-backward'. * lisp/emacs-lisp/text-property-search.el: New file. diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi index e89bd0b7ef..8cb6cf6242 100644 --- a/doc/lispref/text.texi +++ b/doc/lispref/text.texi @@ -3180,6 +3180,95 @@ buffer to scan. Positions are relative to @var{object}. The default for @var{object} is the current buffer. @end defun +@defun text-property-search-forward prop &optional value predicate not-current +Search for the next region that has text property @var{prop} set to +@var{value} according to @var{predicate}. + +This function is modelled after @code{search-forward} and friends in +that it moves point, but it returns a structure that describes the +match instead of returning it in @code{match-beginning} and friends. + +If the text property can't be found, the function returns @code{nil}. +If it's found, point is placed at the end of the region that has this +text property match, and a @code{prop-match} structure is returned. + +@var{predicate} can either be @code{t} (which is a synonym for +@code{equal}), @code{nil} (which means ``not equal''), or a predicate +that will be called with two parameters: The first is @var{value}, and +the second is the value of the text property we're inspecting. + +If @var{not-current}, if point is in a region where we have a match, +then skip past that and find the next instance instead. + +The @code{prop-match} structure has the following accessors: +@code{prop-match-beginning} (the start of the match), +@code{prop-match-end} (the end of the match), and +@code{prop-match-value} (the value of @var{property} at the start of +the match). + +In the examples below, imagine that you're in a buffer that looks like +this: + +@example +This is a bold and here's bolditalic and this is the end. +@end example + +That is, the ``bold'' words are the @code{bold} face, and the +``italic'' word is in the @code{italic} face. + +With point at the start: + +@lisp +(while (setq match (text-property-search-forward 'face 'bold t)) + (push (buffer-substring (prop-match-beginning match) + (prop-match-end match)) + words)) +@end lisp + +This will pick out all the words that use the @code{bold} face. + +@lisp +(while (setq match (text-property-search-forward 'face nil t)) + (push (buffer-substring (prop-match-beginning match) + (prop-match-end match)) + words)) +@end lisp + +This will pick out all the bits that have no face properties, which +will result in the list @samp{("This is a " "and here's " "and this is +the end")} (only reversed, since we used @code{push}). + +@lisp +(while (setq match (text-property-search-forward 'face nil nil)) + (push (buffer-substring (prop-match-beginning match) + (prop-match-end match)) + words)) +@end lisp + +This will pick out all the regions where @code{face} is set to +something, but this is split up into where the properties change, so +the result here will be @samp{("bold" "bold" "italic")}. + +For a more realistic example where you might use this, consider that +you have a buffer where certain sections represent URLs, and these are +tagged with @code{shr-url}. + +@lisp +(while (setq match (text-property-search-forward 'shr-url nil nil)) + (push (prop-match-value match) urls)) +@end lisp + +This will give you a list of all those URLs. + +@end defun + +@defun text-property-search-backward prop &optional value predicate not-current +This is just like @code{text-property-search-backward}, but searches +backward instead. Point is placed at the beginning of the matched +region instead of the end, though. +@end defun + + @node Special Properties @subsection Properties with Special Meanings diff --git a/etc/NEWS b/etc/NEWS index 5aa92e2991..d402401619 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -164,6 +164,11 @@ non-text modes. 'write-abbrev-file' now writes special properties like ':case-fixed' for abbrevs that have them. ++++ +** The new functions and commands `text-property-search-forward' and +`text-property-search-backward' have been added. These provide an +interface that's more like functions like @code{search-forward}. + * Changes in Specialized Modes and Packages in Emacs 27.1 diff --git a/lisp/emacs-lisp/text-property-search.el b/lisp/emacs-lisp/text-property-search.el new file mode 100644 index 0000000000..cd4471a045 --- /dev/null +++ b/lisp/emacs-lisp/text-property-search.el @@ -0,0 +1,201 @@ +;;; text-property-search.el --- search for text properties -*- lexical-binding:t -*- + +;; Copyright (C) 2018 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: convenience + +;; 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: + +;;; Code: + +(eval-when-compile (require 'cl-lib)) + +(cl-defstruct (prop-match) + beginning end value) + +(defun text-property-search-forward (property &optional value predicate + not-immediate) + "Search for the next region that has text property PROPERTY set to VALUE. +If not found, the return value is nil. If found, point will be +placed at the end of the region and an object describing the +match is returned. + +PREDICATE is called with two values. The first is the VALUE +parameter. The second is the value of PROPERTY. This predicate +should return non-nil if there is a match. + +Some convenience values for PREDICATE can also be used. `t' +means the same as `equal'. `nil' means almost the same as \"not +equal\", but will also end the match if the value of PROPERTY +changes. See the manual for extensive examples. + +If `not-immediate', if the match is under point, it will not be +returned, but instead the next instance is returned, if any. + +The return value (if a match is made) is a `prop-match' +structure. The accessor avaliable are +`prop-match-beginning'/`prop-match-end' (which are the region in +the buffer that's matching, and `prop-match-value', which is the +value of PROPERTY at the start of the region." + (interactive + (list + (let ((string (completing-read "Search for property: " obarray))) + (when (> (length string) 0) + (intern string obarray))))) + ;; We're standing in the property we're looking for, so find the + ;; end. + (if (and (text-property--match-p value (get-text-property (point) property) + predicate) + (not not-immediate)) + (text-property--find-end-forward (point) property value predicate) + (let ((origin (point)) + (ended nil) + pos) + ;; Fix the next candidate. + (while (not ended) + (setq pos (next-single-property-change (point) property)) + (if (not pos) + (progn + (goto-char origin) + (setq ended t)) + (goto-char pos) + (if (text-property--match-p value (get-text-property (point) property) + predicate) + (setq ended + (text-property--find-end-forward + (point) property value predicate)) + ;; Skip past this section of non-matches. + (setq pos (next-single-property-change (point) property)) + (unless pos + (goto-char origin) + (setq ended t))))) + (and (not (eq ended t)) + ended)))) + +(defun text-property--find-end-forward (start property value predicate) + (let (end) + (if (and value + (null predicate)) + ;; This is the normal case: We're looking for areas where the + ;; values aren't, so we aren't interested in sub-areas where the + ;; property has different values, all non-matching value. + (let ((ended nil)) + (while (not ended) + (setq end (next-single-property-change (point) property)) + (if (not end) + (progn + (goto-char (point-max)) + (setq end (point) + ended t)) + (goto-char end) + (unless (text-property--match-p + value (get-text-property (point) property) predicate) + (setq ended t))))) + ;; End this at the first place the property changes value. + (setq end (next-single-property-change (point) property nil (point-max))) + (goto-char end)) + (make-prop-match :beginning start + :end end + :value (get-text-property start property)))) + + +(defun text-property-search-backward (property &optional value predicate + not-immediate) + "Search for the previous region that has text property PROPERTY set to VALUE. +See `text-property-search-forward' for further documentation." + (interactive + (list + (let ((string (completing-read "Search for property: " obarray))) + (when (> (length string) 0) + (intern string obarray))))) + (cond + ;; We're at the start of the buffer; no previous matches. + ((bobp) + nil) + ;; We're standing in the property we're looking for, so find the + ;; end. + ((and (text-property--match-p + value (get-text-property (1- (point)) property) + predicate) + (not not-immediate)) + (text-property--find-end-backward (1- (point)) property value predicate)) + (t + (let ((origin (point)) + (ended nil) + pos) + (forward-char -1) + ;; Fix the next candidate. + (while (not ended) + (setq pos (previous-single-property-change (point) property)) + (if (not pos) + (progn + (goto-char origin) + (setq ended t)) + (goto-char (1- pos)) + (if (text-property--match-p value (get-text-property (point) property) + predicate) + (setq ended + (text-property--find-end-backward + (point) property value predicate)) + ;; Skip past this section of non-matches. + (setq pos (previous-single-property-change (point) property)) + (unless pos + (goto-char origin) + (setq ended t))))) + (and (not (eq ended t)) + ended))))) + +(defun text-property--find-end-backward (start property value predicate) + (let (end) + (if (and value + (null predicate)) + ;; This is the normal case: We're looking for areas where the + ;; values aren't, so we aren't interested in sub-areas where the + ;; property has different values, all non-matching value. + (let ((ended nil)) + (while (not ended) + (setq end (previous-single-property-change (point) property)) + (if (not end) + (progn + (goto-char (point-min)) + (setq end (point) + ended t)) + (goto-char (1- end)) + (unless (text-property--match-p + value (get-text-property (point) property) predicate) + (goto-char end) + (setq ended t))))) + ;; End this at the first place the property changes value. + (setq end (previous-single-property-change + (point) property nil (point-min))) + (goto-char end)) + (make-prop-match :beginning end + :end (1+ start) + :value (get-text-property end property)))) + +(defun text-property--match-p (value prop-value predicate) + (cond + ((eq predicate t) + (setq predicate #'equal)) + ((eq predicate nil) + (setq predicate (lambda (val p-val) + (not (equal val p-val)))))) + (funcall predicate value prop-value)) + +(provide 'text-property-search) commit c969fbd40bcad0de6322895a5ad4d53144309315 Author: Tino Calancha Date: Tue Apr 17 22:20:28 2018 +0900 * lisp/textmodes/artist.el (artist-mode): Ensure we have a font diff --git a/lisp/textmodes/artist.el b/lisp/textmodes/artist.el index 7c261f8d2d..e9ae6a4ce9 100644 --- a/lisp/textmodes/artist.el +++ b/lisp/textmodes/artist.el @@ -1402,8 +1402,9 @@ Keymap summary (t ;; Turn mode on (artist-mode-init) - (unless (font-get (face-attribute 'default :font) :spacing) - (message "The default font isn't monospaced, so the drawings in this buffer may look odd"))))) + (let ((font (face-attribute 'default :font))) + (when (and (fontp font) (not (font-get font :spacing))) + (message "The default font isn't monospaced, so the drawings in this buffer may look odd")))))) ;; Init and exit (defun artist-mode-init ()