Commit c52e26df authored by Mattias Engdegård's avatar Mattias Engdegård
Browse files

Keep track of match extents in occur-mode (bug#39121)

Use the `occur-target` text property to keep track of the extents of
all matches on each line instead of just the start of the first match.
Doing so allows us to highlight all matches when jumping to a matching
line instead of just the first one, and it works in a more principled
way.  It also removes compatibility problems that were introduced with
occur-highlight-regexp.

For compatibility with code that populate their own occur-mode
buffers, we still accept `occur-target` properties with a single
marker as value.

* lisp/replace.el (occur-highlight-regexp, occur-highlight-overlay):
Remove.
(occur-highlight-overlays): New.
(occur--targets-start): New.
* lisp/replace.el (occur-after-change-function):
(occur-mode-find-occurrence): Replace with...
(occur-mode--find-occurrences): ...this function that returns the
whole `occur-target` property value.
(occur-mode-goto-occurrence, occur-mode-goto-occurrence-other-window)
(occur-goto-locus-delete-o, occur-mode-display-occurrence)
(occur-engine): Adjust to new property format.
(occur--highlight-occurrence): Replace with...
(occur--highlight-occurrences): ...this function that takes
the `occur-target` property value as argument.
(occur-1): Don't use `occur-highlight-regexp`.
* test/lisp/replace-tests.el (occur-highlight-occurrence):
Adapt to new property format.
parent d3415724
Pipeline #11587 failed with stages
in 29 seconds
...@@ -792,12 +792,8 @@ which will run faster and will not set the mark or print anything." ...@@ -792,12 +792,8 @@ which will run faster and will not set the mark or print anything."
Maximum length of the history list is determined by the value Maximum length of the history list is determined by the value
of `history-length', which see.") of `history-length', which see.")
(defvar occur-highlight-regexp t (defvar occur-highlight-overlays nil
"Regexp matching part of visited source lines to highlight temporarily. "Overlays used to temporarily highlight occur matches.")
Highlight entire line if t; don't highlight source lines if nil.")
(defvar occur-highlight-overlay nil
"Overlay used to temporarily highlight occur matches.")
(defvar occur-collect-regexp-history '("\\1") (defvar occur-collect-regexp-history '("\\1")
"History of regexp for occur's collect operation") "History of regexp for occur's collect operation")
...@@ -1357,18 +1353,27 @@ To return to ordinary Occur mode, use \\[occur-cease-edit]." ...@@ -1357,18 +1353,27 @@ To return to ordinary Occur mode, use \\[occur-cease-edit]."
(occur-mode) (occur-mode)
(message "Switching to Occur mode."))) (message "Switching to Occur mode.")))
(defun occur--targets-start (targets)
"First marker of the `occur-target' property value TARGETS."
(if (consp targets)
(caar targets)
;; Tolerate an `occur-target' value that is a single marker for
;; compatibility.
targets))
(defun occur-after-change-function (beg end length) (defun occur-after-change-function (beg end length)
(save-excursion (save-excursion
(goto-char beg) (goto-char beg)
(let* ((line-beg (line-beginning-position)) (let* ((line-beg (line-beginning-position))
(m (get-text-property line-beg 'occur-target)) (targets (get-text-property line-beg 'occur-target))
(m (occur--targets-start targets))
(buf (marker-buffer m)) (buf (marker-buffer m))
col) col)
(when (and (get-text-property line-beg 'occur-prefix) (when (and (get-text-property line-beg 'occur-prefix)
(not (get-text-property end 'occur-prefix))) (not (get-text-property end 'occur-prefix)))
(when (= length 0) (when (= length 0)
;; Apply occur-target property to inserted (e.g. yanked) text. ;; Apply occur-target property to inserted (e.g. yanked) text.
(put-text-property beg end 'occur-target m) (put-text-property beg end 'occur-target targets)
;; Did we insert a newline? Occur Edit mode can't create new ;; Did we insert a newline? Occur Edit mode can't create new
;; Occur entries; just discard everything after the newline. ;; Occur entries; just discard everything after the newline.
(save-excursion (save-excursion
...@@ -1402,35 +1407,38 @@ To return to ordinary Occur mode, use \\[occur-cease-edit]." ...@@ -1402,35 +1407,38 @@ To return to ordinary Occur mode, use \\[occur-cease-edit]."
"Handle `revert-buffer' for Occur mode buffers." "Handle `revert-buffer' for Occur mode buffers."
(apply #'occur-1 (append occur-revert-arguments (list (buffer-name))))) (apply #'occur-1 (append occur-revert-arguments (list (buffer-name)))))
(defun occur-mode-find-occurrence () (defun occur-mode--find-occurrences ()
(let ((pos (get-text-property (point) 'occur-target))) ;; The `occur-target' property value is a list of (BEG . END) for each
(unless pos ;; match on the line, or (for compatibility) a single marker to the start
;; of the first match.
(let* ((targets (get-text-property (point) 'occur-target))
(start (occur--targets-start targets)))
(unless targets
(error "No occurrence on this line")) (error "No occurrence on this line"))
(unless (buffer-live-p (marker-buffer pos)) (unless (buffer-live-p (marker-buffer start))
(error "Buffer for this occurrence was killed")) (error "Buffer for this occurrence was killed"))
pos)) targets))
(defalias 'occur-mode-mouse-goto 'occur-mode-goto-occurrence) (defalias 'occur-mode-mouse-goto 'occur-mode-goto-occurrence)
(defun occur-mode-goto-occurrence (&optional event) (defun occur-mode-goto-occurrence (&optional event)
"Go to the occurrence specified by EVENT, a mouse click. "Go to the occurrence specified by EVENT, a mouse click.
If not invoked by a mouse click, go to occurrence on the current line." If not invoked by a mouse click, go to occurrence on the current line."
(interactive (list last-nonmenu-event)) (interactive (list last-nonmenu-event))
(let ((buffer (when event (current-buffer))) (let* ((buffer (when event (current-buffer)))
(pos (targets
(if (null event) (if (null event)
;; Actually `event-end' works correctly with a nil argument as ;; Actually `event-end' works correctly with a nil argument as
;; well, so we could dispense with this test, but let's not ;; well, so we could dispense with this test, but let's not
;; rely on this undocumented behavior. ;; rely on this undocumented behavior.
(occur-mode-find-occurrence) (occur-mode--find-occurrences)
(with-current-buffer (window-buffer (posn-window (event-end event))) (with-current-buffer (window-buffer (posn-window (event-end event)))
(save-excursion (save-excursion
(goto-char (posn-point (event-end event))) (goto-char (posn-point (event-end event)))
(occur-mode-find-occurrence))))) (occur-mode--find-occurrences)))))
(regexp occur-highlight-regexp)) (pos (occur--targets-start targets)))
(pop-to-buffer (marker-buffer pos)) (pop-to-buffer (marker-buffer pos))
(goto-char pos) (goto-char pos)
(let ((end-mk (save-excursion (re-search-forward regexp nil t)))) (occur--highlight-occurrences targets)
(occur--highlight-occurrence pos end-mk))
(when buffer (next-error-found buffer (current-buffer))) (when buffer (next-error-found buffer (current-buffer)))
(run-hooks 'occur-mode-find-occurrence-hook))) (run-hooks 'occur-mode-find-occurrence-hook)))
...@@ -1438,15 +1446,15 @@ If not invoked by a mouse click, go to occurrence on the current line." ...@@ -1438,15 +1446,15 @@ If not invoked by a mouse click, go to occurrence on the current line."
"Go to the occurrence the current line describes, in another window." "Go to the occurrence the current line describes, in another window."
(interactive) (interactive)
(let ((buffer (current-buffer)) (let ((buffer (current-buffer))
(pos (occur-mode-find-occurrence))) (pos (occur--targets-start (occur-mode--find-occurrences))))
(switch-to-buffer-other-window (marker-buffer pos)) (switch-to-buffer-other-window (marker-buffer pos))
(goto-char pos) (goto-char pos)
(next-error-found buffer (current-buffer)) (next-error-found buffer (current-buffer))
(run-hooks 'occur-mode-find-occurrence-hook))) (run-hooks 'occur-mode-find-occurrence-hook)))
;; Stolen from compile.el
(defun occur-goto-locus-delete-o () (defun occur-goto-locus-delete-o ()
(delete-overlay occur-highlight-overlay) (mapc #'delete-overlay occur-highlight-overlays)
(setq occur-highlight-overlays nil)
;; Get rid of timer and hook that would try to do this again. ;; Get rid of timer and hook that would try to do this again.
(if (timerp next-error-highlight-timer) (if (timerp next-error-highlight-timer)
(cancel-timer next-error-highlight-timer)) (cancel-timer next-error-highlight-timer))
...@@ -1454,64 +1462,55 @@ If not invoked by a mouse click, go to occurrence on the current line." ...@@ -1454,64 +1462,55 @@ If not invoked by a mouse click, go to occurrence on the current line."
#'occur-goto-locus-delete-o)) #'occur-goto-locus-delete-o))
;; Highlight the current visited occurrence. ;; Highlight the current visited occurrence.
;; Adapted from `compilation-goto-locus'. (defun occur--highlight-occurrences (targets)
(defun occur--highlight-occurrence (mk end-mk) (let ((start-marker (occur--targets-start targets)))
(let ((highlight-regexp occur-highlight-regexp)) (occur-goto-locus-delete-o)
(if (timerp next-error-highlight-timer) (with-current-buffer (marker-buffer start-marker)
(cancel-timer next-error-highlight-timer)) (when (or (eq next-error-highlight t)
(unless occur-highlight-overlay (numberp next-error-highlight))
(setq occur-highlight-overlay (setq occur-highlight-overlays
(make-overlay (point-min) (point-min))) (mapcar (lambda (target)
(overlay-put occur-highlight-overlay 'face 'next-error)) (let ((o (make-overlay (car target) (cdr target))))
(with-current-buffer (marker-buffer mk) (overlay-put o 'face 'next-error)
(save-excursion o))
(if end-mk (goto-char end-mk) (end-of-line)) (if (listp targets)
(let ((end (point))) targets
(if mk (goto-char mk) (beginning-of-line)) ;; `occur-target' compatibility: when we only
(if (and (stringp highlight-regexp) ;; have a single starting point, highlight the
(re-search-forward highlight-regexp end t)) ;; rest of the line.
(progn (let ((end-pos (save-excursion
(goto-char (match-beginning 0)) (goto-char start-marker)
(move-overlay occur-highlight-overlay (line-end-position))))
(match-beginning 0) (match-end 0) (list (cons start-marker end-pos))))))
(current-buffer))) (add-hook 'pre-command-hook #'occur-goto-locus-delete-o)
(move-overlay occur-highlight-overlay (when (numberp next-error-highlight)
(point) end (current-buffer))) ;; We want highlighting for a limited time:
(if (or (eq next-error-highlight t) ;; set up a timer to delete it.
(numberp next-error-highlight)) (setq next-error-highlight-timer
;; We want highlighting: delete overlay on next input. (run-at-time next-error-highlight nil
(add-hook 'pre-command-hook 'occur-goto-locus-delete-o))))
#'occur-goto-locus-delete-o)
;; We don't want highlighting: delete overlay now. (when (eq next-error-highlight 'fringe-arrow)
(delete-overlay occur-highlight-overlay)) ;; We want a fringe arrow (instead of highlighting).
;; We want highlighting for a limited time: (setq next-error-overlay-arrow-position
;; set up a timer to delete it. (copy-marker (line-beginning-position)))))))
(when (numberp next-error-highlight)
(setq next-error-highlight-timer
(run-at-time next-error-highlight nil
'occur-goto-locus-delete-o))))))
(when (eq next-error-highlight 'fringe-arrow)
;; We want a fringe arrow (instead of highlighting).
(setq next-error-overlay-arrow-position
(copy-marker (line-beginning-position))))))
(defun occur-mode-display-occurrence () (defun occur-mode-display-occurrence ()
"Display in another window the occurrence the current line describes." "Display in another window the occurrence the current line describes."
(interactive) (interactive)
(let ((buffer (current-buffer)) (let* ((buffer (current-buffer))
(pos (occur-mode-find-occurrence)) (targets (occur-mode--find-occurrences))
(regexp occur-highlight-regexp) (pos (occur--targets-start targets))
(next-error-highlight next-error-highlight-no-select) (next-error-highlight next-error-highlight-no-select)
(display-buffer-overriding-action (display-buffer-overriding-action
'(nil (inhibit-same-window . t))) '(nil (inhibit-same-window . t)))
window) window)
(setq window (display-buffer (marker-buffer pos) t)) (setq window (display-buffer (marker-buffer pos) t))
;; This is the way to set point in the proper window. ;; This is the way to set point in the proper window.
(save-selected-window (save-selected-window
(select-window window) (select-window window)
(goto-char pos) (goto-char pos)
(let ((end-mk (save-excursion (re-search-forward regexp nil t)))) (occur--highlight-occurrences targets)
(occur--highlight-occurrence pos end-mk))
(next-error-found buffer (current-buffer)) (next-error-found buffer (current-buffer))
(run-hooks 'occur-mode-find-occurrence-hook)))) (run-hooks 'occur-mode-find-occurrence-hook))))
...@@ -1868,7 +1867,6 @@ See also `multi-occur'." ...@@ -1868,7 +1867,6 @@ See also `multi-occur'."
(buffer-undo-list t) (buffer-undo-list t)
(occur--final-pos nil)) (occur--final-pos nil))
(erase-buffer) (erase-buffer)
(setq-local occur-highlight-regexp regexp)
(let ((count (let ((count
(if (stringp nlines) (if (stringp nlines)
;; Treat nlines as a regexp to collect. ;; Treat nlines as a regexp to collect.
...@@ -1968,7 +1966,7 @@ See also `multi-occur'." ...@@ -1968,7 +1966,7 @@ See also `multi-occur'."
(origpt nil) (origpt nil)
(begpt nil) (begpt nil)
(endpt nil) (endpt nil)
(marker nil) markers ; list of (BEG-MARKER . END-MARKER)
(curstring "") (curstring "")
(ret nil) (ret nil)
;; The following binding is for when case-fold-search ;; The following binding is for when case-fold-search
...@@ -1994,8 +1992,7 @@ See also `multi-occur'." ...@@ -1994,8 +1992,7 @@ See also `multi-occur'."
(setq endpt (line-end-position))) (setq endpt (line-end-position)))
;; Sum line numbers up to the first match line. ;; Sum line numbers up to the first match line.
(setq curr-line (+ curr-line (count-lines origpt begpt))) (setq curr-line (+ curr-line (count-lines origpt begpt)))
(setq marker (make-marker)) (setq markers nil)
(set-marker marker matchbeg)
(setq curstring (occur-engine-line begpt endpt keep-props)) (setq curstring (occur-engine-line begpt endpt keep-props))
;; Highlight the matches ;; Highlight the matches
(let ((len (length curstring)) (let ((len (length curstring))
...@@ -2017,6 +2014,11 @@ See also `multi-occur'." ...@@ -2017,6 +2014,11 @@ See also `multi-occur'."
(setq orig-line-shown-p t))) (setq orig-line-shown-p t)))
(while (and (< start len) (while (and (< start len)
(string-match regexp curstring start)) (string-match regexp curstring start))
(push (cons (set-marker (make-marker)
(+ begpt (match-beginning 0)))
(set-marker (make-marker)
(+ begpt (match-end 0))))
markers)
(setq matches (1+ matches)) (setq matches (1+ matches))
(add-text-properties (add-text-properties
(match-beginning 0) (match-end 0) (match-beginning 0) (match-end 0)
...@@ -2029,6 +2031,7 @@ See also `multi-occur'." ...@@ -2029,6 +2031,7 @@ See also `multi-occur'."
;; Avoid infloop (Bug#7593). ;; Avoid infloop (Bug#7593).
(let ((end (match-end 0))) (let ((end (match-end 0)))
(setq start (if (= start end) (1+ start) end))))) (setq start (if (= start end) (1+ start) end)))))
(setq markers (nreverse markers))
;; Generate the string to insert for this match ;; Generate the string to insert for this match
(let* ((match-prefix (let* ((match-prefix
;; Using 7 digits aligns tabs properly. ;; Using 7 digits aligns tabs properly.
...@@ -2042,7 +2045,7 @@ See also `multi-occur'." ...@@ -2042,7 +2045,7 @@ See also `multi-occur'."
;; (for Occur Edit mode). ;; (for Occur Edit mode).
front-sticky t front-sticky t
rear-nonsticky t rear-nonsticky t
occur-target ,marker occur-target ,markers
follow-link t follow-link t
help-echo "mouse-2: go to this occurrence")))) help-echo "mouse-2: go to this occurrence"))))
(match-str (match-str
...@@ -2050,7 +2053,7 @@ See also `multi-occur'." ...@@ -2050,7 +2053,7 @@ See also `multi-occur'."
;; because that loses. And don't put it ;; because that loses. And don't put it
;; on context lines to reduce flicker. ;; on context lines to reduce flicker.
(propertize curstring (propertize curstring
'occur-target marker 'occur-target markers
'follow-link t 'follow-link t
'help-echo 'help-echo
"mouse-2: go to this occurrence")) "mouse-2: go to this occurrence"))
...@@ -2069,8 +2072,8 @@ See also `multi-occur'." ...@@ -2069,8 +2072,8 @@ See also `multi-occur'."
;; get a contiguous highlight. ;; get a contiguous highlight.
(propertize (concat match-prefix match-str) (propertize (concat match-prefix match-str)
'mouse-face 'highlight)) 'mouse-face 'highlight))
;; Add marker at eol, but no mouse props. ;; Add markers at eol, but no mouse props.
(propertize "\n" 'occur-target marker))) (propertize "\n" 'occur-target markers)))
(data (data
(if (= nlines 0) (if (= nlines 0)
;; The simple display style ;; The simple display style
......
...@@ -589,7 +589,7 @@ bound to HIGHLIGHT-LOCUS." ...@@ -589,7 +589,7 @@ bound to HIGHLIGHT-LOCUS."
(replace-tests-with-highlighted-occurrence highlight-locus (replace-tests-with-highlighted-occurrence highlight-locus
(occur-mode-display-occurrence) (occur-mode-display-occurrence)
(with-current-buffer (marker-buffer (with-current-buffer (marker-buffer
(get-text-property (point) 'occur-target)) (caar (get-text-property (point) 'occur-target)))
(should (funcall check-overlays has-overlay))))))) (should (funcall check-overlays has-overlay)))))))
(ert-deftest replace-regexp-bug45973 () (ert-deftest replace-regexp-bug45973 ()
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment