[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
bug#22541: 25.0.50; highlight-regexp from isearch has is case-sensitive
|
From: |
Tino Calancha |
|
Subject: |
bug#22541: 25.0.50; highlight-regexp from isearch has is case-sensitive even if case-fold is active |
|
Date: |
Tue, 25 Apr 2017 14:22:10 +0900 |
|
User-agent: |
Gnus/5.13 (Gnus v5.13) Emacs/26.0.50 (gnu/linux) |
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)))
--
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