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.

diff --git a/etc/NEWS b/etc/NEWS
index 28c01d71f18a753dcee9001322a0a0bce3bdad6e..7a7f11f5071146bdb61ed088eff2a41b14d46aff 100644 (file)
--- a/etc/NEWS
+++ b/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
 

diff --git a/lisp/hi-lock.el b/lisp/hi-lock.el
index d5e46651a50e674441baeff99b092f4fb244b5cb..1d8dc0624ba380dd906e26d85b7e7415baf44571 100644 (file)
--- a/lisp/hi-lock.el
+++ b/lisp/hi-lock.el
@@ -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

diff --git a/test/lisp/hi-lock-tests.el b/test/lisp/hi-lock-tests.el
index dd2c28053a09e9c86f265f0941f2a630919787d2..252caaa26501fea4b2e3edb3bfb84685d5f2997d 100644 (file)
--- a/test/lisp/hi-lock-tests.el
+++ b/test/lisp/hi-lock-tests.el
@@ -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