bug#22541: 25.0.50; highlight-regexp from isearch has is case-sensitive even if case-fold is active

[Tino Calancha <tino.calancha@gmail.com>]

Juri Linkov <juri@linkov.net> writes:

>> I think is a good moment to comeback to this issue once we have already
>> released Emacs 25.2.
>> I have updated your patch so that hi-lock-face-buffer checks search-upper-case
>> in interactive calls.  It works OK.
>> Since there isn't recent activity in the implementation of the pcre-style
>> embedded modifiers, we might use your patch in the meantime.
>
> Thank you for taking care of this issue.  If in your tests it works
> as expected, then I suppose this is the way to go.

I updated the patch to make work `hi-lock-unface-buffer'.  I added tests
as well.

Note that in interactive calls the case fold is determined with the
variables `search-upper-case' and `case-fold-search'.  This way it behaves
as `isearch-forward-regexp'.
Before this bug case fold was determined _just_ with `case-fold-search'.
Do you prefer avoid `search-upper-case' in this case?

--8<-----------------------------cut here---------------start------------->8---
From 7cad27c0fcc39add8679d0893010c4fdb3ed507a Mon Sep 17 00:00:00 2001
From: Juri Linkov <juri@jurta.org>
Date: Tue, 25 Apr 2017 14:17:23 +0900
Subject: [PATCH] highlight-regexp: Honor case-fold-search

Perform the matches of REGEXP as `isearch-forward' i.e., in interactive
calls determine the case fold with `search-upper-case' and
`case-fold-search' (Bug#22541).
* lisp/hi-lock.el (hi-lock-face-buffer, hi-lock-set-pattern):
Add optional arg CASE-FOLD.  All callers updated.
(hi-lock--regexps-at-point, hi-lock-unface-buffer):
Handle when pattern is a cons (REGEXP . FUNCTION).
* lisp/isearch.el (isearch-highlight-regexp): Call hi-lock-face-buffer
with 3 arguments.

Co-authored-by: Tino Calancha <tino.calancha@gmail.com>
---
 lisp/hi-lock.el | 99 ++++++++++++++++++++++++++++++++++++++-------------------
 lisp/isearch.el |  7 +++-
 2 files changed, 73 insertions(+), 33 deletions(-)

diff --git a/lisp/hi-lock.el b/lisp/hi-lock.el
index ebd18621ef..c9e0428f01 100644
--- a/lisp/hi-lock.el
+++ b/lisp/hi-lock.el
@@ -432,8 +432,9 @@ hi-lock-line-face-buffer
 ;;;###autoload
 (defalias 'highlight-regexp 'hi-lock-face-buffer)
 ;;;###autoload
-(defun hi-lock-face-buffer (regexp &optional face)
+(defun hi-lock-face-buffer (regexp &optional face case-fold)
   "Set face of each match of REGEXP to FACE.
+If optional arg CASE-FOLD is non-nil, then bind `case-fold-search' to it.
 Interactively, prompt for REGEXP using `read-regexp', then FACE.
 Use the global history list for FACE.
 
@@ -441,13 +442,18 @@ hi-lock-face-buffer
 use overlays for highlighting.  If overlays are used, the
 highlighting will not update as you type."
   (interactive
-   (list
-    (hi-lock-regexp-okay
-     (read-regexp "Regexp to highlight" 'regexp-history-last))
-    (hi-lock-read-face-name)))
+   (let* ((reg
+           (hi-lock-regexp-okay
+            (read-regexp "Regexp to highlight" 'regexp-history-last)))
+          (face (hi-lock-read-face-name))
+          (fold
+           (if search-upper-case
+               (isearch-no-upper-case-p reg t)
+             case-fold-search)))
+     (list reg face fold)))
   (or (facep face) (setq face 'hi-yellow))
   (unless hi-lock-mode (hi-lock-mode 1))
-  (hi-lock-set-pattern regexp face))
+  (hi-lock-set-pattern regexp face case-fold))
 
 ;;;###autoload
 (defalias 'highlight-phrase 'hi-lock-face-phrase-buffer)
@@ -530,10 +536,17 @@ hi-lock--regexps-at-point
           ;; 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)))
-              (if (string-match regexp hi-text)
-                  (push regexp regexps)))))))
-    regexps))
+            (let ((regexp-or-fn (car hi-lock-pattern)))
+              (cond ((stringp regexp-or-fn)
+                     (when (string-match regexp-or-fn hi-text)
+                       (push regexp-or-fn regexps)))
+                    (t
+                     (with-temp-buffer
+                       (insert hi-text)
+                       (goto-char 1)
+                       (when (funcall regexp-or-fn nil)
+                         (push regexp-or-fn regexps)))))))
+    ))) regexps))
 
 (defvar-local hi-lock--unused-faces nil
   "List of faces that is not used and is available for highlighting new text.
@@ -561,13 +574,16 @@ hi-lock-unface-buffer
          (cons
           `keymap
           (cons "Select Pattern to Unhighlight"
-                (mapcar (lambda (pattern)
-                          (list (car pattern)
-                                (format
-                                 "%s (%s)" (car pattern)
-                                 (hi-lock-keyword->face pattern))
-                                (cons nil nil)
-                                (car pattern)))
+                 (mapcar (lambda (pattern)
+                           (let ((regexp (if (consp (car pattern))
+                                             (caar pattern)
+                                           (car pattern))))
+                             (list regexp
+                                   (format
+                                    "%s (%s)" regexp
+                                    (hi-lock-keyword->face pattern))
+                                   (cons nil nil)
+                                   regexp)))
                         hi-lock-interactive-patterns))))
         ;; If the user clicks outside the menu, meaning that they
         ;; change their mind, x-popup-menu returns nil, and
@@ -581,16 +597,24 @@ hi-lock-unface-buffer
        (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))))
+                          (mapcar (lambda (x)
+                                    (if (consp (car x)) (caar x) (car x)))
+                                    hi-lock-interactive-patterns))))
        (list
         (completing-read (if (null defaults)
                              "Regexp to unhighlight: "
                            (format "Regexp to unhighlight (default %s): "
                                    (car defaults)))
                          hi-lock-interactive-patterns
-			 nil t nil nil defaults))))))
-  (dolist (keyword (if (eq regexp t) hi-lock-interactive-patterns
-                     (list (assoc regexp hi-lock-interactive-patterns))))
+			 nil nil nil nil defaults))))))
+  (let ((keys
+         (mapcar (lambda (x)
+                   (if (consp (car x))
+                       (cons (caar x) (cdr x))
+                     x))
+                 hi-lock-interactive-patterns)))
+    (dolist (keyword (if (eq regexp t) keys
+                       (list (assoc regexp keys))))
     (when keyword
       (let ((face (hi-lock-keyword->face keyword)))
         ;; Make `face' the next one to use by default.
@@ -606,7 +630,7 @@ hi-lock-unface-buffer
             (delq keyword hi-lock-interactive-patterns))
       (remove-overlays
        nil nil 'hi-lock-overlay-regexp (hi-lock--hashcons (car keyword)))
-      (font-lock-flush))))
+      (font-lock-flush)))))
 
 ;;;###autoload
 (defun hi-lock-write-interactive-patterns ()
@@ -689,15 +713,25 @@ hi-lock-read-face-name
       (add-to-list 'hi-lock-face-defaults face t))
     (intern face)))
 
-(defun hi-lock-set-pattern (regexp face)
-  "Highlight REGEXP with face FACE."
+(defun hi-lock-set-pattern (regexp face &optional case-fold)
+  "Highlight REGEXP with face FACE.
+If optional arg CASE-FOLD is non-nil, then bind `case-fold-search' to it."
   ;; Hashcons the regexp, so it can be passed to remove-overlays later.
   (setq regexp (hi-lock--hashcons regexp))
-  (let ((pattern (list regexp (list 0 (list 'quote face) 'prepend))))
+  (let ((pattern (list (if (eq case-fold 'undefined)
+                           regexp
+                         (cons regexp
+                               (byte-compile
+                          `(lambda (limit)
+                             (let ((case-fold-search ,case-fold))
+                               (re-search-forward ,regexp limit t))))))
+                       (list 0 (list 'quote face) 'prepend))))
     ;; Refuse to highlight a text that is already highlighted.
     (unless (assoc regexp hi-lock-interactive-patterns)
       (push pattern hi-lock-interactive-patterns)
-      (if (and font-lock-mode (font-lock-specified-p major-mode))
+      (if (and font-lock-mode
+               (font-lock-specified-p major-mode)
+               (not (consp pattern)))
 	  (progn
 	    (font-lock-add-keywords nil (list pattern) t)
 	    (font-lock-flush))
@@ -711,12 +745,13 @@ hi-lock-set-pattern
                      (+ range-max (max 0 (- (point-min) range-min))))))
           (save-excursion
             (goto-char search-start)
-            (while (re-search-forward regexp search-end t)
-              (let ((overlay (make-overlay (match-beginning 0) (match-end 0))))
-                (overlay-put overlay 'hi-lock-overlay t)
-                (overlay-put overlay 'hi-lock-overlay-regexp regexp)
-                (overlay-put overlay 'face face))
-              (goto-char (match-end 0)))))))))
+            (let ((case-fold-search case-fold))
+              (while (re-search-forward regexp search-end t)
+                (let ((overlay (make-overlay (match-beginning 0) (match-end 0))))
+                  (overlay-put overlay 'hi-lock-overlay t)
+                  (overlay-put overlay 'hi-lock-overlay-regexp regexp)
+                  (overlay-put overlay 'face face))
+                (goto-char (match-end 0))))))))))
 
 (defun hi-lock-set-file-patterns (patterns)
   "Replace file patterns list with PATTERNS and refontify."
diff --git a/lisp/isearch.el b/lisp/isearch.el
index c34739d638..250d37b45e 100644
--- a/lisp/isearch.el
+++ b/lisp/isearch.el
@@ -1950,7 +1950,12 @@ isearch-highlight-regexp
 			      (regexp-quote s))))
 			isearch-string ""))
 		      (t (regexp-quote isearch-string)))))
-    (hi-lock-face-buffer regexp (hi-lock-read-face-name)))
+    (hi-lock-face-buffer regexp (hi-lock-read-face-name)
+                         (if (and (eq isearch-case-fold-search t)
+                                  search-upper-case)
+                             (isearch-no-upper-case-p
+                              isearch-string isearch-regexp)
+                           isearch-case-fold-search)))
   (and isearch-recursive-edit (exit-recursive-edit)))
 
 \f
-- 
2.11.0

From f0f68d2a2049b549a6690f411dd746cb4333f99b Mon Sep 17 00:00:00 2001
From: Tino Calancha <tino.calancha@gmail.com>
Date: Tue, 25 Apr 2017 14:18:00 +0900
Subject: [PATCH] * test/lisp/hi-lock-tests.el: Add test.

---
 test/lisp/hi-lock-tests.el | 90 ++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 90 insertions(+)
 create mode 100644 test/lisp/hi-lock-tests.el

diff --git a/test/lisp/hi-lock-tests.el b/test/lisp/hi-lock-tests.el
new file mode 100644
index 0000000000..836fbe9a89
--- /dev/null
+++ b/test/lisp/hi-lock-tests.el
@@ -0,0 +1,90 @@
+;;; hi-lock-tests.el --- Tests for hi-lock.el  -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2017 Free Software Foundation, Inc.
+
+;; Author: Tino Calancha <tino.calancha@gmail.com>
+;; Keywords:
+
+;; This program 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.
+
+;; This program 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 this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert)
+(require 'hi-lock)
+(eval-when-compile (require 'cl-lib))
+
+(defun hi-lock--count (face)
+  (let ((count 0))
+    (save-excursion
+      (goto-char (point-min))
+      (dolist (ov (car (overlay-lists)))
+        (let ((props (memq 'face (overlay-properties ov))))
+          (when (eq (cadr props) face)
+            (cl-incf count)))))
+    count))
+
+(defun hi-lock--highlight-and-count (regexp face case-fold)
+  "Highlight REGEXP with FACE with case fold CASE-FOLD.
+Return number of matches."
+       (hi-lock-unface-buffer t)
+       (should (eq 0 (hi-lock--count face)))
+       (hi-lock-face-buffer regexp face case-fold)
+       (hi-lock--count face))
+
+(defun hi-lock--interactive-test-1 (regexp face res ucase cfold)
+  (hi-lock-unface-buffer t)
+  (should (eq 0 (hi-lock--count face)))
+  (cl-letf (((symbol-function 'read-regexp)
+             (lambda (x y) (ignore x y) regexp))
+            ((symbol-function 'hi-lock-read-face-name)
+             (lambda () face)))
+    (setq search-upper-case ucase
+          case-fold-search cfold)
+    (call-interactively 'hi-lock-face-buffer)
+    (should (= res (hi-lock--count face)))))
+
+;; Interactive test should not depend on the major mode.
+(defun hi-lock--interactive-test (regexp face res ucase cfold)
+  (lisp-interaction-mode)
+  (hi-lock--interactive-test-1 regexp face res ucase cfold)
+  (fundamental-mode)
+  (hi-lock--interactive-test-1 regexp face res ucase cfold))
+
+;; In batch calls to `hi-lock-face-buffer', case is given by
+;; its third argument.  In interactive calls, case depends
+;; on `search-upper-case' and `case-fold-search'.
+(ert-deftest hi-lock-face-buffer-test ()
+  "Test for http://debbugs.gnu.org/22541 ."
+  (let ((face 'hi-yellow)
+        (regexp "a")
+        case-fold-search search-upper-case)
+    (with-temp-buffer
+      (insert "a A\n")
+      (should (= 1 (hi-lock--highlight-and-count regexp face nil)))
+      (should (= 2 (hi-lock--highlight-and-count regexp face t)))
+      ;; Case depends on the regexp.
+      (hi-lock--interactive-test regexp face 2 t nil)
+      (hi-lock--interactive-test "A" face 1 t nil)
+      (hi-lock--interactive-test "\\A" face 2 t nil)
+      ;; Case depends on `case-fold-search'.
+      (hi-lock--interactive-test "a" face 1 nil nil)
+      (hi-lock--interactive-test "A" face 1 nil nil)
+      (hi-lock--interactive-test "\\A" face 1 nil nil)
+      ;;
+      (hi-lock--interactive-test "a" face 2 nil t)
+      (hi-lock--interactive-test "A" face 2 nil t)
+      (hi-lock--interactive-test "\\A" face 2 nil t))))
+
+(provide 'hi-lock-tests)
+;;; hi-lock-tests.el ends here
-- 
2.11.0

--8<-----------------------------cut here---------------end--------------->8---
In GNU Emacs 26.0.50 (build 1, x86_64-pc-linux-gnu, GTK+ Version 3.22.11)
 of 2017-04-25
Repository revision: 622c24a2b75a564b9861fc3ca7a7878741e8568d