Fix hi-lock test and add new test for case-fold (bug#40337)
* lisp/hi-lock.el (hi-lock--regexps-at-point): Handle font-lock faces. (hi-lock-unface-buffer): Simplify default value handling. (hi-lock-set-pattern): Add either lighter or regexp to hi-lock-interactive-lighters. (hi-lock-set-pattern): Put overlay prop hi-lock-overlay-regexp to either lighter or regexp. * test/lisp/hi-lock-tests.el (hi-lock-bug26666): Use "b" instead of "a". (hi-lock-case-fold): New test.
This commit is contained in:
Juri Linkov
parent
68ffe4a3c9
commit
91e4acf7c7
3 changed files with 120 additions and 21 deletions
2
etc/NEWS
2
etc/NEWS
|
|
@ -267,7 +267,7 @@ to substitute spaces in regexp search.
|
|||
|
||||
---
|
||||
*** The default value of 'hi-lock-highlight-range' was enlarged.
|
||||
The new default value is 2000000 (2 million).
|
||||
The new default value is 2000000 (2 megabytes).
|
||||
|
||||
** Texinfo
|
||||
|
||||
|
|
|
|||
|
|
@ -564,13 +564,15 @@ in which case the highlighting will not update as you type."
|
|||
(let ((regexp (get-char-property (point) 'hi-lock-overlay-regexp)))
|
||||
(when regexp (push regexp regexps)))
|
||||
;; With font-locking on, check if the cursor is on a highlighted text.
|
||||
(let ((face-after (get-text-property (point) 'face))
|
||||
(face-before
|
||||
(unless (bobp) (get-text-property (1- (point)) 'face)))
|
||||
(faces (mapcar #'hi-lock-keyword->face
|
||||
hi-lock-interactive-patterns)))
|
||||
(unless (memq face-before faces) (setq face-before nil))
|
||||
(unless (memq face-after faces) (setq face-after nil))
|
||||
(let* ((faces-after (get-text-property (point) 'face))
|
||||
(faces-before
|
||||
(unless (bobp) (get-text-property (1- (point)) 'face)))
|
||||
(faces-after (if (consp faces-after) faces-after (list faces-after)))
|
||||
(faces-before (if (consp faces-before) faces-before (list faces-before)))
|
||||
(faces (mapcar #'hi-lock-keyword->face
|
||||
hi-lock-interactive-patterns))
|
||||
(face-after (seq-some (lambda (face) (car (memq face faces))) faces-after))
|
||||
(face-before (seq-some (lambda (face) (car (memq face faces))) faces-before)))
|
||||
(when (and face-before face-after (not (eq face-before face-after)))
|
||||
(setq face-before nil))
|
||||
(when (or face-after face-before)
|
||||
|
|
@ -588,7 +590,8 @@ in which case the highlighting will not update as you type."
|
|||
;; highlighted text at point. Use this later in
|
||||
;; during completing-read.
|
||||
(dolist (hi-lock-pattern hi-lock-interactive-patterns)
|
||||
(let ((regexp (car hi-lock-pattern)))
|
||||
(let ((regexp (or (car (rassq hi-lock-pattern hi-lock-interactive-lighters))
|
||||
(car hi-lock-pattern))))
|
||||
(if (string-match regexp hi-text)
|
||||
(push regexp regexps)))))))
|
||||
regexps))
|
||||
|
|
@ -642,15 +645,10 @@ then remove all hi-lock highlighting."
|
|||
(user-error "No highlighting to remove"))
|
||||
;; Infer the regexp to un-highlight based on cursor position.
|
||||
(let* ((defaults (or (hi-lock--regexps-at-point)
|
||||
(mapcar #'car hi-lock-interactive-patterns))))
|
||||
(setq defaults
|
||||
(mapcar (lambda (default)
|
||||
(or (car (rassq default
|
||||
(mapcar (lambda (a)
|
||||
(cons (car a) (cadr a)))
|
||||
hi-lock-interactive-lighters)))
|
||||
default))
|
||||
defaults))
|
||||
(mapcar (lambda (pattern)
|
||||
(or (car (rassq pattern hi-lock-interactive-lighters))
|
||||
(car pattern)))
|
||||
hi-lock-interactive-patterns))))
|
||||
(list
|
||||
(completing-read (if (null defaults)
|
||||
"Regexp to unhighlight: "
|
||||
|
|
@ -767,7 +765,8 @@ SPACES-REGEXP is a regexp to substitute spaces in font-lock search."
|
|||
(list subexp (list 'quote face) 'prepend)))
|
||||
(no-matches t))
|
||||
;; Refuse to highlight a text that is already highlighted.
|
||||
(if (assoc regexp hi-lock-interactive-patterns)
|
||||
(if (or (assoc regexp hi-lock-interactive-patterns)
|
||||
(assoc (or lighter regexp) hi-lock-interactive-lighters))
|
||||
(add-to-list 'hi-lock--unused-faces (face-name face))
|
||||
(push pattern hi-lock-interactive-patterns)
|
||||
(push (cons (or lighter regexp) pattern) hi-lock-interactive-lighters)
|
||||
|
|
@ -792,7 +791,7 @@ SPACES-REGEXP is a regexp to substitute spaces in font-lock search."
|
|||
(let ((overlay (make-overlay (match-beginning subexp)
|
||||
(match-end subexp))))
|
||||
(overlay-put overlay 'hi-lock-overlay t)
|
||||
(overlay-put overlay 'hi-lock-overlay-regexp regexp)
|
||||
(overlay-put overlay 'hi-lock-overlay-regexp (or lighter regexp))
|
||||
(overlay-put overlay 'face face))
|
||||
(goto-char (match-end 0)))
|
||||
(when no-matches
|
||||
|
|
|
|||
|
|
@ -33,7 +33,9 @@
|
|||
(car defaults))))
|
||||
(dotimes (_ 2)
|
||||
(let ((face (hi-lock-read-face-name)))
|
||||
(hi-lock-set-pattern "a" face))))
|
||||
;; This test should use regexp "b" different from "a"
|
||||
;; used in another test because hi-lock--hashcons is global.
|
||||
(hi-lock-set-pattern "b" face))))
|
||||
(should (equal hi-lock--unused-faces (cdr faces))))))
|
||||
|
||||
(ert-deftest hi-lock-test-set-pattern ()
|
||||
|
|
@ -48,5 +50,103 @@
|
|||
;; Only one match, then we have used just 1 face
|
||||
(should (equal hi-lock--unused-faces (cdr faces))))))
|
||||
|
||||
(ert-deftest hi-lock-case-fold ()
|
||||
"Test for case-sensitivity."
|
||||
(let ((hi-lock-auto-select-face t))
|
||||
(with-temp-buffer
|
||||
(insert "a A b B\n")
|
||||
|
||||
(dotimes (_ 2) (highlight-regexp "[a]"))
|
||||
(should (= (length (overlays-in (point-min) (point-max))) 2))
|
||||
(unhighlight-regexp "[a]")
|
||||
(should (= (length (overlays-in (point-min) (point-max))) 0))
|
||||
|
||||
(dotimes (_ 2) (highlight-regexp "[a]" nil nil "a"))
|
||||
(should (= (length (overlays-in (point-min) (point-max))) 2))
|
||||
(unhighlight-regexp "a")
|
||||
(should (= (length (overlays-in (point-min) (point-max))) 0))
|
||||
|
||||
(dotimes (_ 2) (highlight-regexp "[A]" ))
|
||||
(should (= (length (overlays-in (point-min) (point-max))) 1))
|
||||
(unhighlight-regexp "[A]")
|
||||
(should (= (length (overlays-in (point-min) (point-max))) 0))
|
||||
|
||||
(dotimes (_ 2) (highlight-regexp "[A]" nil nil "A"))
|
||||
(should (= (length (overlays-in (point-min) (point-max))) 1))
|
||||
(unhighlight-regexp "A")
|
||||
(should (= (length (overlays-in (point-min) (point-max))) 0))
|
||||
|
||||
(let ((case-fold-search nil)) (dotimes (_ 2) (highlight-regexp "[a]")))
|
||||
(should (= (length (overlays-in (point-min) (point-max))) 1))
|
||||
(unhighlight-regexp "[a]")
|
||||
(should (= (length (overlays-in (point-min) (point-max))) 0))
|
||||
|
||||
(dotimes (_ 2) (highlight-phrase "a a"))
|
||||
(should (= (length (overlays-in (point-min) (point-max))) 1))
|
||||
(unhighlight-regexp "a a")
|
||||
(should (= (length (overlays-in (point-min) (point-max))) 0))
|
||||
|
||||
(let ((search-spaces-regexp search-whitespace-regexp)) (highlight-regexp "a a"))
|
||||
(should (= (length (overlays-in (point-min) (point-max))) 1))
|
||||
(cl-letf (((symbol-function 'completing-read)
|
||||
(lambda (_prompt _coll _x _y _z _hist defaults)
|
||||
(car defaults))))
|
||||
(call-interactively 'unhighlight-regexp))
|
||||
(should (= (length (overlays-in (point-min) (point-max))) 0))
|
||||
|
||||
(emacs-lisp-mode)
|
||||
(setq font-lock-mode t)
|
||||
|
||||
(dotimes (_ 2) (highlight-regexp "[a]"))
|
||||
(font-lock-ensure)
|
||||
(should (memq 'hi-yellow (get-text-property 1 'face)))
|
||||
(should (memq 'hi-yellow (get-text-property 3 'face)))
|
||||
(let ((font-lock-fontified t)) (unhighlight-regexp "[a]"))
|
||||
(should (null (get-text-property 3 'face)))
|
||||
|
||||
(dotimes (_ 2) (highlight-regexp "[a]" nil nil "a"))
|
||||
(font-lock-ensure)
|
||||
(should (memq 'hi-yellow (get-text-property 1 'face)))
|
||||
(should (memq 'hi-yellow (get-text-property 3 'face)))
|
||||
(let ((font-lock-fontified t)) (unhighlight-regexp "a"))
|
||||
(should (null (get-text-property 3 'face)))
|
||||
|
||||
(dotimes (_ 2) (highlight-regexp "[A]" ))
|
||||
(font-lock-ensure)
|
||||
(should (null (get-text-property 1 'face)))
|
||||
(should (memq 'hi-yellow (get-text-property 3 'face)))
|
||||
(let ((font-lock-fontified t)) (unhighlight-regexp "[A]"))
|
||||
(should (null (get-text-property 3 'face)))
|
||||
|
||||
(dotimes (_ 2) (highlight-regexp "[A]" nil nil "A"))
|
||||
(font-lock-ensure)
|
||||
(should (null (get-text-property 1 'face)))
|
||||
(should (memq 'hi-yellow (get-text-property 3 'face)))
|
||||
(let ((font-lock-fontified t)) (unhighlight-regexp "A"))
|
||||
(should (null (get-text-property 3 'face)))
|
||||
|
||||
(let ((case-fold-search nil)) (dotimes (_ 2) (highlight-regexp "[a]")))
|
||||
(font-lock-ensure)
|
||||
(should (memq 'hi-yellow (get-text-property 1 'face)))
|
||||
(should (null (get-text-property 3 'face)))
|
||||
(let ((font-lock-fontified t)) (unhighlight-regexp "[a]"))
|
||||
(should (null (get-text-property 1 'face)))
|
||||
|
||||
(dotimes (_ 2) (highlight-phrase "a a"))
|
||||
(font-lock-ensure)
|
||||
(should (memq 'hi-yellow (get-text-property 1 'face)))
|
||||
(let ((font-lock-fontified t)) (unhighlight-regexp "a a"))
|
||||
(should (null (get-text-property 1 'face)))
|
||||
|
||||
(let ((search-spaces-regexp search-whitespace-regexp)) (highlight-regexp "a a"))
|
||||
(font-lock-ensure)
|
||||
(should (memq 'hi-yellow (get-text-property 1 'face)))
|
||||
(cl-letf (((symbol-function 'completing-read)
|
||||
(lambda (_prompt _coll _x _y _z _hist defaults)
|
||||
(car defaults)))
|
||||
(font-lock-fontified t))
|
||||
(call-interactively 'unhighlight-regexp))
|
||||
(should (null (get-text-property 1 'face))))))
|
||||
|
||||
(provide 'hi-lock-tests)
|
||||
;;; hi-lock-tests.el ends here
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue