mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2024-12-14 09:39:42 +00:00
c52e26df30
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.
621 lines
16 KiB
EmacsLisp
621 lines
16 KiB
EmacsLisp
;;; replace-tests.el --- tests for replace.el. -*- lexical-binding:t -*-
|
||
|
||
;; Copyright (C) 2010-2021 Free Software Foundation, Inc.
|
||
|
||
;; Author: Nicolas Richard <youngfrog@members.fsf.org>
|
||
;; Author: Juri Linkov <juri@jurta.org>
|
||
|
||
;; 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 <https://www.gnu.org/licenses/>.
|
||
|
||
;;; Code:
|
||
|
||
(require 'ert)
|
||
(eval-when-compile (require 'subr-x))
|
||
|
||
(ert-deftest query-replace--split-string-tests ()
|
||
(let ((sep (propertize "\0" 'separator t)))
|
||
(dolist (before '("" "b"))
|
||
(dolist (after '("" "a"))
|
||
(should (equal
|
||
(query-replace--split-string (concat before sep after))
|
||
(cons before after)))
|
||
(should (equal
|
||
(query-replace--split-string (concat before "\0" after))
|
||
(concat before "\0" after)))))))
|
||
|
||
(defconst replace-occur-tests
|
||
'(
|
||
;; * Test one-line matches (at bob, eob, bol, eol).
|
||
("x" 0 "\
|
||
xa
|
||
b
|
||
cx
|
||
xd
|
||
xex
|
||
fx
|
||
" "\
|
||
6 matches in 5 lines for \"x\" in buffer: *test-occur*
|
||
1:xa
|
||
3:cx
|
||
4:xd
|
||
5:xex
|
||
6:fx
|
||
")
|
||
;; * Test multi-line matches, this is the first test from
|
||
;; https://lists.gnu.org/r/emacs-devel/2005-06/msg01008.html
|
||
;; where numbers are replaced with letters.
|
||
("a\na" 0 "\
|
||
a
|
||
a
|
||
a
|
||
a
|
||
a
|
||
" "\
|
||
2 matches for \"a\na\" in buffer: *test-occur*
|
||
1:a
|
||
:a
|
||
3:a
|
||
:a
|
||
")
|
||
;; * Test multi-line matches, this is the second test from
|
||
;; https://lists.gnu.org/r/emacs-devel/2005-06/msg01008.html
|
||
;; where numbers are replaced with letters.
|
||
("a\nb" 0 "\
|
||
a
|
||
b
|
||
c
|
||
a
|
||
b
|
||
" "\
|
||
2 matches for \"a\nb\" in buffer: *test-occur*
|
||
1:a
|
||
:b
|
||
4:a
|
||
:b
|
||
")
|
||
;; * Test line numbers for multi-line matches with empty last match line.
|
||
("a\n" 0 "\
|
||
a
|
||
|
||
c
|
||
a
|
||
|
||
" "\
|
||
2 matches for \"a\n\" in buffer: *test-occur*
|
||
1:a
|
||
:
|
||
4:a
|
||
:
|
||
")
|
||
;; * Test multi-line matches with 3 match lines.
|
||
("x\n.x\n" 0 "\
|
||
ax
|
||
bx
|
||
c
|
||
d
|
||
ex
|
||
fx
|
||
" "\
|
||
2 matches for \"x\n.x\n\" in buffer: *test-occur*
|
||
1:ax
|
||
:bx
|
||
:c
|
||
5:ex
|
||
:fx
|
||
:
|
||
")
|
||
;; * Test non-overlapping context lines with matches at bob/eob.
|
||
("x" 1 "\
|
||
ax
|
||
b
|
||
c
|
||
d
|
||
ex
|
||
f
|
||
g
|
||
hx
|
||
" "\
|
||
3 matches for \"x\" in buffer: *test-occur*
|
||
1:ax
|
||
:b
|
||
-------
|
||
:d
|
||
5:ex
|
||
:f
|
||
-------
|
||
:g
|
||
8:hx
|
||
")
|
||
;; * Test non-overlapping context lines with matches not at bob/eob.
|
||
("x" 1 "\
|
||
a
|
||
bx
|
||
c
|
||
d
|
||
ex
|
||
f
|
||
" "\
|
||
2 matches for \"x\" in buffer: *test-occur*
|
||
:a
|
||
2:bx
|
||
:c
|
||
-------
|
||
:d
|
||
5:ex
|
||
:f
|
||
")
|
||
;; * Test overlapping context lines with matches at bob/eob.
|
||
("x" 2 "\
|
||
ax
|
||
bx
|
||
c
|
||
dx
|
||
e
|
||
f
|
||
gx
|
||
h
|
||
i
|
||
j
|
||
kx
|
||
" "\
|
||
5 matches for \"x\" in buffer: *test-occur*
|
||
1:ax
|
||
2:bx
|
||
:c
|
||
4:dx
|
||
:e
|
||
:f
|
||
7:gx
|
||
:h
|
||
:i
|
||
:j
|
||
11:kx
|
||
")
|
||
;; * Test overlapping context lines with matches not at bob/eob.
|
||
("x" 2 "\
|
||
a
|
||
b
|
||
cx
|
||
d
|
||
e
|
||
f
|
||
gx
|
||
h
|
||
i
|
||
" "\
|
||
2 matches for \"x\" in buffer: *test-occur*
|
||
:a
|
||
:b
|
||
3:cx
|
||
:d
|
||
:e
|
||
:f
|
||
7:gx
|
||
:h
|
||
:i
|
||
")
|
||
;; * Test overlapping context lines with empty first and last line..
|
||
("x" 2 "\
|
||
|
||
b
|
||
cx
|
||
d
|
||
e
|
||
f
|
||
gx
|
||
h
|
||
|
||
" "\
|
||
2 matches for \"x\" in buffer: *test-occur*
|
||
:
|
||
:b
|
||
3:cx
|
||
:d
|
||
:e
|
||
:f
|
||
7:gx
|
||
:h
|
||
:
|
||
")
|
||
;; * Test multi-line overlapping context lines.
|
||
("x\n.x" 2 "\
|
||
ax
|
||
bx
|
||
c
|
||
d
|
||
ex
|
||
fx
|
||
g
|
||
h
|
||
i
|
||
jx
|
||
kx
|
||
" "\
|
||
3 matches for \"x\n.x\" in buffer: *test-occur*
|
||
1:ax
|
||
:bx
|
||
:c
|
||
:d
|
||
5:ex
|
||
:fx
|
||
:g
|
||
:h
|
||
:i
|
||
10:jx
|
||
:kx
|
||
")
|
||
;; * Test multi-line non-overlapping context lines.
|
||
("x\n.x" 2 "\
|
||
ax
|
||
bx
|
||
c
|
||
d
|
||
e
|
||
f
|
||
gx
|
||
hx
|
||
" "\
|
||
2 matches for \"x\n.x\" in buffer: *test-occur*
|
||
1:ax
|
||
:bx
|
||
:c
|
||
:d
|
||
-------
|
||
:e
|
||
:f
|
||
7:gx
|
||
:hx
|
||
")
|
||
;; * Test non-overlapping negative (before-context) lines.
|
||
("x" -2 "\
|
||
a
|
||
bx
|
||
c
|
||
d
|
||
e
|
||
fx
|
||
g
|
||
h
|
||
ix
|
||
" "\
|
||
3 matches for \"x\" in buffer: *test-occur*
|
||
:a
|
||
2:bx
|
||
-------
|
||
:d
|
||
:e
|
||
6:fx
|
||
-------
|
||
:g
|
||
:h
|
||
9:ix
|
||
")
|
||
;; * Test overlapping negative (before-context) lines.
|
||
("x" -3 "\
|
||
a
|
||
bx
|
||
c
|
||
dx
|
||
e
|
||
f
|
||
gx
|
||
h
|
||
" "\
|
||
3 matches for \"x\" in buffer: *test-occur*
|
||
:a
|
||
2:bx
|
||
:c
|
||
4:dx
|
||
:e
|
||
:f
|
||
7:gx
|
||
")
|
||
|
||
)
|
||
"List of tests for `occur'.
|
||
Each element has the format:
|
||
\(REGEXP NLINES INPUT-BUFFER-STRING OUTPUT-BUFFER-STRING).")
|
||
|
||
(defun replace-occur-test-case (test)
|
||
(let ((regexp (nth 0 test))
|
||
(nlines (nth 1 test))
|
||
(input-buffer-string (nth 2 test))
|
||
(temp-buffer (get-buffer-create " *test-occur*")))
|
||
(unwind-protect
|
||
(save-window-excursion
|
||
(with-current-buffer temp-buffer
|
||
(erase-buffer)
|
||
(insert input-buffer-string)
|
||
(occur regexp nlines)
|
||
(with-current-buffer "*Occur*"
|
||
(buffer-substring-no-properties (point-min) (point-max)))))
|
||
(and (buffer-name temp-buffer)
|
||
(kill-buffer temp-buffer)))))
|
||
|
||
(defun replace-occur-test-create (n)
|
||
"Create a test for element N of the `replace-occur-tests' constant."
|
||
(let ((testname (intern (format "occur-test-%.2d" n)))
|
||
(testdoc (format "Test element %d of `replace-occur-tests'." n)))
|
||
(eval
|
||
`(ert-deftest ,testname ()
|
||
,testdoc
|
||
(let (replace-occur-hook)
|
||
(should (equal (replace-occur-test-case (nth ,n replace-occur-tests))
|
||
(nth 3 (nth ,n replace-occur-tests)))))))))
|
||
|
||
(dotimes (i (length replace-occur-tests))
|
||
(replace-occur-test-create i))
|
||
|
||
(ert-deftest replace-occur-revert-bug32543 ()
|
||
"Test `occur-revert' with non-nil `list-matching-lines-jump-to-current-line'."
|
||
(let ((temp-buffer (get-buffer-create " *test-occur*")))
|
||
(unwind-protect
|
||
(save-window-excursion
|
||
(with-current-buffer temp-buffer
|
||
(erase-buffer)
|
||
(setq list-matching-lines-jump-to-current-line t)
|
||
(insert
|
||
";; This buffer is for text that is not saved, and for Lisp evaluation.
|
||
;; To create a file, visit it with C-x C-f and enter text in its buffer.
|
||
|
||
")
|
||
(occur "and")
|
||
(with-current-buffer "*Occur*"
|
||
(revert-buffer)
|
||
(goto-char (point-min))
|
||
(should (string-match "\\`2 matches for \"and\" in buffer: "
|
||
(buffer-substring-no-properties
|
||
(point) (line-end-position)))))))
|
||
(and (buffer-name temp-buffer)
|
||
(kill-buffer temp-buffer)))))
|
||
|
||
(ert-deftest replace-occur-revert-bug32987 ()
|
||
"Test `occur-revert' with non-nil `list-matching-lines-jump-to-current-line'."
|
||
(let ((temp-buffer (get-buffer-create " *test-occur*")))
|
||
(unwind-protect
|
||
(save-window-excursion
|
||
(with-current-buffer temp-buffer
|
||
(erase-buffer)
|
||
(setq list-matching-lines-jump-to-current-line nil)
|
||
(insert
|
||
";; This buffer is for text that is not saved, and for Lisp evaluation.
|
||
;; To create a file, visit it with C-x C-f and enter text in its buffer.
|
||
|
||
")
|
||
(occur "and")
|
||
(with-current-buffer "*Occur*"
|
||
(revert-buffer)
|
||
(goto-char (point-min))
|
||
(should (string-match "\\`2 matches for \"and\" in buffer: "
|
||
(buffer-substring-no-properties
|
||
(point) (line-end-position)))))))
|
||
(and (buffer-name temp-buffer)
|
||
(kill-buffer temp-buffer)))))
|
||
|
||
|
||
;;; Tests for `query-replace' undo feature.
|
||
|
||
(defvar replace-tests-bind-read-string nil
|
||
"A string to bind `read-string' and avoid the prompt.")
|
||
|
||
(defvar replace-tests-perform-replace-regexp-flag t
|
||
"Value for regexp-flag argument passed to `perform-replace' in undo tests.")
|
||
|
||
(defmacro replace-tests-with-undo (input from to char-nums def-chr &rest body)
|
||
"Helper to test `query-replace' undo feature.
|
||
INPUT is a string to insert in a temporary buffer.
|
||
FROM is the string to match and replace.
|
||
TO is the replacement string.
|
||
CHAR-NUMS is a list of elements (CHAR . NUMS), where CHAR is
|
||
one of the characters `,', `?\\s', `u', `U', `E' or `q'
|
||
and NUMS a list of integers.
|
||
DEF-CHAR is the character `?\\s' or `q'.
|
||
BODY is a list of forms to evaluate.
|
||
|
||
Use CHAR-NUMS and DEF-CHAR to temporary bind the function value of
|
||
`read-event', thus avoiding the prompt.
|
||
For instance, if CHAR-NUMS is the lists ((?\\s . (1 2 3)) (?u . (4))),
|
||
then replace 3 matches of FROM with TO, and undo the last replacement.
|
||
|
||
Return the last evalled form in BODY."
|
||
(declare (indent 5) (debug (stringp stringp stringp form characterp body)))
|
||
(let ((text (gensym "text"))
|
||
(count (gensym "count")))
|
||
`(let* ((,text ,input)
|
||
(,count 0)
|
||
(inhibit-message t))
|
||
(with-temp-buffer
|
||
(insert ,text)
|
||
(goto-char 1)
|
||
;; Bind `read-event' to simulate user input.
|
||
;; If `replace-tests-bind-read-string' is non-nil, then
|
||
;; bind `read-string' as well.
|
||
(cl-letf (((symbol-function 'read-event)
|
||
(lambda (&rest _args)
|
||
(cl-incf ,count)
|
||
(pcase ,count ; Build the clauses from CHAR-NUMS
|
||
,@(append
|
||
(delq nil
|
||
(mapcar
|
||
(lambda (chr)
|
||
(when-let (it (alist-get chr char-nums))
|
||
(if (cdr it)
|
||
`(,(cons 'or it) ,chr)
|
||
`(,(car it) ,chr))))
|
||
'(?, ?\s ?u ?U ?E ?q)))
|
||
`((_ ,def-chr))))))
|
||
((symbol-function 'read-string)
|
||
(if replace-tests-bind-read-string
|
||
(lambda (&rest _args) replace-tests-bind-read-string)
|
||
(symbol-function 'read-string)))
|
||
;; Emulate replace-highlight clobbering match-data via
|
||
;; isearch-lazy-highlight-new-loop and sit-for (bug#36328)
|
||
((symbol-function 'replace-highlight)
|
||
(lambda (&rest _args)
|
||
(string-match "[A-Z ]" "ForestGreen")))
|
||
;; Override `sit-for' and `ding' so that we don't have
|
||
;; to wait and listen to bells when running the test.
|
||
((symbol-function 'sit-for)
|
||
(lambda (&rest _args) (redisplay)))
|
||
((symbol-function 'ding) 'ignore))
|
||
(perform-replace ,from ,to t replace-tests-perform-replace-regexp-flag nil))
|
||
,@body))))
|
||
|
||
(defun replace-tests--query-replace-undo (&optional comma)
|
||
(let ((input "111"))
|
||
(if comma
|
||
(should
|
||
(replace-tests-with-undo
|
||
input "1" "2" ((?, . (2)) (?u . (3)) (?q . (4))) ?\s (buffer-string)))
|
||
(should
|
||
(replace-tests-with-undo
|
||
input "1" "2" ((?\s . (2)) (?u . (3)) (?q . (4))) ?\s (buffer-string))))))
|
||
|
||
(ert-deftest query-replace--undo ()
|
||
(should (string= "211" (replace-tests--query-replace-undo)))
|
||
(should (string= "211" (replace-tests--query-replace-undo 'comma))))
|
||
|
||
(ert-deftest query-replace-undo-bug31073 ()
|
||
"Test for https://debbugs.gnu.org/31073 ."
|
||
(let ((input "aaa aaa"))
|
||
(should
|
||
(replace-tests-with-undo
|
||
input "a" "B" ((?\s . (1 2 3)) (?U . (4))) ?q
|
||
(string= input (buffer-string))))))
|
||
|
||
(ert-deftest query-replace-undo-bug31492 ()
|
||
"Test for https://debbugs.gnu.org/31492 ."
|
||
(let ((input "a\nb\nc\n"))
|
||
(should
|
||
(replace-tests-with-undo
|
||
input "^\\|\b\\|$" "foo" ((?\s . (1 2)) (?U . (3))) ?q
|
||
(string= input (buffer-string))))))
|
||
|
||
(ert-deftest query-replace-undo-bug31538 ()
|
||
"Test for https://debbugs.gnu.org/31538 ."
|
||
(let ((input "aaa aaa")
|
||
(replace-tests-bind-read-string "Bfoo"))
|
||
(should
|
||
(replace-tests-with-undo
|
||
input "a" "B" ((?\s . (1 2 3)) (?E . (4)) (?U . (5))) ?q
|
||
(string= input (buffer-string))))))
|
||
|
||
(ert-deftest query-replace-undo-bug37073 ()
|
||
"Test for https://debbugs.gnu.org/37073 ."
|
||
(let ((input "theorem 1\ntheorem 2\ntheorem 3"))
|
||
(should
|
||
(replace-tests-with-undo
|
||
input "theorem \\([0-9]+\\)"
|
||
'(replace-eval-replacement
|
||
replace-quote
|
||
(format "theorem \\\\ref{theo_%d}" (1+ (string-to-number (match-string 1)))))
|
||
((?\s . (1 2)) (?U . (3)))
|
||
?q
|
||
(string= input (buffer-string)))))
|
||
;; Now run a test with regexp-flag arg in `perform-replace' set to nil
|
||
(let ((input " ^theorem$ 1\n ^theorem$ 2\n ^theorem$ 3")
|
||
(replace-tests-perform-replace-regexp-flag nil)
|
||
(expected " theo 1\n ^theorem$ 2\n ^theorem$ 3"))
|
||
(should
|
||
(replace-tests-with-undo
|
||
input "^theorem$"
|
||
"theo"
|
||
((?\s . (1 2 4)) (?U . (3)))
|
||
?q
|
||
(string= expected (buffer-string))))))
|
||
|
||
(ert-deftest query-replace-undo-bug37287 ()
|
||
"Test for https://debbugs.gnu.org/37287 ."
|
||
(let ((input "foo-1\nfoo-2\nfoo-3")
|
||
(expected "foo-2\nfoo-2\nfoo-3"))
|
||
(should
|
||
(replace-tests-with-undo
|
||
input "\\([0-9]\\)"
|
||
'(replace-eval-replacement
|
||
replace-quote
|
||
(format "%d" (1+ (string-to-number (match-string 1)))))
|
||
((?\s . (1 2 4)) (?U . (3)))
|
||
?q
|
||
(string= expected (buffer-string))))))
|
||
|
||
(defmacro replace-tests-with-highlighted-occurrence (highlight-locus &rest body)
|
||
"Helper macro to test the highlight of matches when navigating occur buffer.
|
||
|
||
Eval BODY with `next-error-highlight' and `next-error-highlight-no-select'
|
||
bound to HIGHLIGHT-LOCUS."
|
||
(declare (indent 1) (debug (form body)))
|
||
`(let ((regexp "foo")
|
||
(next-error-highlight ,highlight-locus)
|
||
(next-error-highlight-no-select ,highlight-locus)
|
||
(buffer (generate-new-buffer "test"))
|
||
(inhibit-message t))
|
||
(unwind-protect
|
||
;; Local bind to disable the deletion of `occur-highlight-overlay'
|
||
(cl-letf (((symbol-function 'occur-goto-locus-delete-o) (lambda ())))
|
||
(with-current-buffer buffer (dotimes (_ 3) (insert regexp ?\n)))
|
||
(pop-to-buffer buffer)
|
||
(occur regexp)
|
||
(pop-to-buffer "*Occur*")
|
||
(occur-next)
|
||
,@body)
|
||
(kill-buffer buffer)
|
||
(kill-buffer "*Occur*"))))
|
||
|
||
(ert-deftest occur-highlight-occurrence ()
|
||
"Test for https://debbugs.gnu.org/39121 ."
|
||
(let ((alist '((nil . nil) (0.5 . t) (t . t) (fringe-arrow . nil)))
|
||
(check-overlays
|
||
(lambda (has-ov)
|
||
(eq has-ov (not (null (overlays-in (point-min) (point-max))))))))
|
||
(pcase-dolist (`(,highlight-locus . ,has-overlay) alist)
|
||
;; Visiting occurrences
|
||
(replace-tests-with-highlighted-occurrence highlight-locus
|
||
(occur-mode-goto-occurrence)
|
||
(should (funcall check-overlays has-overlay)))
|
||
;; Displaying occurrences
|
||
(replace-tests-with-highlighted-occurrence highlight-locus
|
||
(occur-mode-display-occurrence)
|
||
(with-current-buffer (marker-buffer
|
||
(caar (get-text-property (point) 'occur-target)))
|
||
(should (funcall check-overlays has-overlay)))))))
|
||
|
||
(ert-deftest replace-regexp-bug45973 ()
|
||
"Test for https://debbugs.gnu.org/45973 ."
|
||
(let ((before "1RB 1LC 1RC 1RB 1RD 0LE 1LA 1LD 1RH 0LA")
|
||
(after "1LB 1RC 1LC 1LB 1LD 0RE 1RA 1RD 1LH 0RA"))
|
||
(with-temp-buffer
|
||
(insert before)
|
||
(goto-char (point-min))
|
||
(replace-regexp
|
||
"\\(\\(L\\)\\|\\(R\\)\\)"
|
||
'(replace-eval-replacement
|
||
replace-quote
|
||
(if (match-string 2) "R" "L")))
|
||
(should (equal (buffer-string) after)))))
|
||
|
||
(ert-deftest test-count-matches ()
|
||
(with-temp-buffer
|
||
(insert "oooooooooo")
|
||
(goto-char (point-min))
|
||
(should (= (count-matches "oo") 5))
|
||
(should (= (count-matches "o+") 1)))
|
||
(with-temp-buffer
|
||
(insert "o\n\n\n\no\n\n")
|
||
(goto-char (point-min))
|
||
(should (= (count-matches "^$") 4))))
|
||
|
||
;;; replace-tests.el ends here
|