From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!.POSTED!not-for-mail From: Tino Calancha Newsgroups: gmane.emacs.bugs Subject: bug#22541: 25.0.50; highlight-regexp from isearch has is case-sensitive even if case-fold is active Date: Thu, 25 May 2017 21:11:49 +0900 Message-ID: <87shjt16gq.fsf@calancha-pc> References: <87si1a2tod.fsf@secretsauce.net> <8760x7vyui.fsf@mail.linkov.net> <87vapwipy4.fsf@calancha-pc> <87shkyems1.fsf@localhost> <87pog112pp.fsf@calancha-pc> <87mvb4yzux.fsf@localhost> <87bmrilylu.fsf@calancha-pc> <87fugdfzoq.fsf@localhost> <8737bugyxe.fsf@calancha-pc> NNTP-Posting-Host: blaine.gmane.org Mime-Version: 1.0 Content-Type: text/plain X-Trace: blaine.gmane.org 1495714398 18147 195.159.176.226 (25 May 2017 12:13:18 GMT) X-Complaints-To: usenet@blaine.gmane.org NNTP-Posting-Date: Thu, 25 May 2017 12:13:18 +0000 (UTC) User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/26.0.50 (gnu/linux) Cc: 22541@debbugs.gnu.org, Dima Kogan , tino.calancha@gmail.com To: Juri Linkov Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Thu May 25 14:13:13 2017 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by blaine.gmane.org with esmtp (Exim 4.84_2) (envelope-from ) id 1dDrdf-0004Xh-TE for geb-bug-gnu-emacs@m.gmane.org; Thu, 25 May 2017 14:13:12 +0200 Original-Received: from localhost ([::1]:59796 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1dDrdl-00070R-4c for geb-bug-gnu-emacs@m.gmane.org; Thu, 25 May 2017 08:13:17 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:45853) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1dDrdc-00070C-7X for bug-gnu-emacs@gnu.org; Thu, 25 May 2017 08:13:11 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1dDrdX-0008Jm-3I for bug-gnu-emacs@gnu.org; Thu, 25 May 2017 08:13:08 -0400 Original-Received: from debbugs.gnu.org ([208.118.235.43]:34352) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1dDrdW-0008Io-TY for bug-gnu-emacs@gnu.org; Thu, 25 May 2017 08:13:03 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1dDrdW-0002Yi-Do for bug-gnu-emacs@gnu.org; Thu, 25 May 2017 08:13:02 -0400 X-Loop: help-debbugs@gnu.org Resent-From: Tino Calancha Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Thu, 25 May 2017 12:13:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 22541 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: Original-Received: via spool by 22541-submit@debbugs.gnu.org id=B22541.14957143269776 (code B ref 22541); Thu, 25 May 2017 12:13:02 +0000 Original-Received: (at 22541) by debbugs.gnu.org; 25 May 2017 12:12:06 +0000 Original-Received: from localhost ([127.0.0.1]:37029 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1dDrcb-0002Xb-I8 for submit@debbugs.gnu.org; Thu, 25 May 2017 08:12:06 -0400 Original-Received: from mail-pf0-f169.google.com ([209.85.192.169]:36075) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1dDrcY-0002X3-Lt for 22541@debbugs.gnu.org; Thu, 25 May 2017 08:12:03 -0400 Original-Received: by mail-pf0-f169.google.com with SMTP id m17so165699951pfg.3 for <22541@debbugs.gnu.org>; Thu, 25 May 2017 05:12:02 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20161025; h=from:to:cc:subject:references:date:in-reply-to:message-id :user-agent:mime-version; bh=8zQ78aITMkEXpNJDgQSbsLt3d5HiPyT4qockjKAUWmw=; b=T+4/tyaHIaylrfIBas7IEz6FECBNqsF4FNgsqx03i0ndNWuo+YvSsLvvKvmWt2NrpM rUph5E6YAQyZV0oJsqOgTuaDVmDHGb0h+WE7QbWBAkcrMawQmek5cxUm4LKbqcyycANJ pGfI3gbbErhaoRnn5EgQFH3Psy5Dnw6MhJYaShEKymlqn+H3ZPZq0G1APfh4Hl8+w/EC NBTwL3WCN23dv6JLx/djW4lmZACRTwkUwJUaN8qRLkz2yJ49LNsQ9eujnV/PHZS07AbV 1VJYPhhIkr6z7ZKJPCloPf5MuYsaa2iG83duAdWfLL3M8OxftC5iVokPf1YDY9ofJhCz zxjw== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20161025; h=x-gm-message-state:from:to:cc:subject:references:date:in-reply-to :message-id:user-agent:mime-version; bh=8zQ78aITMkEXpNJDgQSbsLt3d5HiPyT4qockjKAUWmw=; b=gp0xmQeiD6MFL8jE1kYPdqPa5IGQRqzX73r7KhT32wLcdgvS9pr4HMmg49Sd5YWq4o jdL3G6ZqTHpcDHzoJrMpYyRQSKyqGizKh0kVrnnk4LOXrz014IExHc2d7D7ns2FiYVGR EzZ+HVd74ERFO4GYEzo5yczrtYzG5nH12R2x40HXrRz8G23e13rKnSIL6NOcu8uZGWrs gF52kpzpJKugjOy+Hk1W1qWJiQCk3OgI2P6dNpyRqC5V7ZytC+AFXH5G9lJmFJXl75l3 d+azS0QqsT+mBiCOWr+K2Q1SiwFXs7shW1BHz+6uxZmOWeMYlIoU5Y7pYlYmVWGhq+qj vBcA== X-Gm-Message-State: AODbwcDQXpH7ZWH510IZL7r+MKjE0k9g2qRzUWshA8zBaAf26rWiMzOT fGhr7YNYcAQ/Ig== X-Received: by 10.99.167.75 with SMTP id w11mr45625552pgo.148.1495714316574; Thu, 25 May 2017 05:11:56 -0700 (PDT) Original-Received: from calancha-pc (222.139.137.133.dy.bbexcite.jp. [133.137.139.222]) by smtp.gmail.com with ESMTPSA id c7sm14153157pfk.103.2017.05.25.05.11.53 (version=TLS1_2 cipher=ECDHE-RSA-CHACHA20-POLY1305 bits=256/256); Thu, 25 May 2017 05:11:55 -0700 (PDT) In-Reply-To: <8737bugyxe.fsf@calancha-pc> (Tino Calancha's message of "Wed, 24 May 2017 22:35:41 +0900") X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 208.118.235.43 X-BeenThere: bug-gnu-emacs@gnu.org List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Original-Sender: "bug-gnu-emacs" Xref: news.gmane.org gmane.emacs.bugs:132825 Archived-At: Tino Calancha writes: > Juri Linkov writes: > >>> The new patch, in addition to fix this bug report, it also >>> helps with the 5. in bug#22520, that is: >>> emacs -Q >>> M-s hr t RET RET ; Highlight with regexp "[Tt]" >>> M-s hu t RET ; Unhighlight the buffer. >> >> Thanks, could you find more test cases that still don't work? > Yes i did. We need to fold according with `search-upper-case' and > `case-fold-search' for `hi-lock-face-phrase-buffer' and > `hi-lock-line-face-buffer' as well. > I am posting the updated patch in a few days after after test it. Hi Juri, I have updated the patch. It's harder than i expected. Maybe I am missing something. Could you take a look on it? The new patch seems to handle `case-fold-search' correctly for the 4 commands: `hi-lock-face-buffer' `hi-lock-line-face-buffer' `hi-lock-face-symbol-at-point' `hi-lock-face-phrase-buffer'. That's seems true regardless of the value of (font-lock-specified-p major-mode) --8<-----------------------------cut here---------------start------------->8--- >From 234c6189f9c6f978c7a4039cd2ff186805b1c3f3 Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Thu, 25 May 2017 11:00:09 +0900 Subject: [PATCH 1/3] highlight-regexp: Honor case-fold-search * lisp/hi-lock.el (hi-lock-face-buffer, hi-lock-set-pattern): Add optional arg CASE-FOLD. All callers updated. * lisp/isearch.el (isearch-highlight-regexp): Call hi-lock-face-buffer with 3 arguments. --- lisp/hi-lock.el | 30 +++++++++++++++++++----------- lisp/isearch.el | 7 ++++++- 2 files changed, 25 insertions(+), 12 deletions(-) diff --git a/lisp/hi-lock.el b/lisp/hi-lock.el index 5139e01fa8..55ad3ccb58 100644 --- a/lisp/hi-lock.el +++ b/lisp/hi-lock.el @@ -432,7 +432,7 @@ 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. Interactively, prompt for REGEXP using `read-regexp', then FACE. Use the global history list for FACE. @@ -444,10 +444,11 @@ hi-lock-face-buffer (list (hi-lock-regexp-okay (read-regexp "Regexp to highlight" 'regexp-history-last)) - (hi-lock-read-face-name))) + (hi-lock-read-face-name) + case-fold-search)) (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) @@ -689,11 +690,17 @@ hi-lock-read-face-name (add-to-list 'hi-lock-face-defaults face t)) (intern face))) -(defun hi-lock-set-pattern (regexp face) +(defun hi-lock-set-pattern (regexp face &optional case-fold) "Highlight REGEXP with face FACE." ;; 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 + (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. (if (assoc regexp hi-lock-interactive-patterns) (add-to-list 'hi-lock--unused-faces (face-name face)) @@ -712,12 +719,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 705f90014547c446cc7fd1df35f2d8d16e630771 Mon Sep 17 00:00:00 2001 From: Tino Calancha Date: Thu, 25 May 2017 11:22:06 +0900 Subject: [PATCH 2/3] Fix hi-lock-unface-buffer from last commit 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). A call to `hi-lock-unface-buffer' with the input used in `hi-lock-face-buffer' must unhighlight that pattern, regardless of the actual internal regexp used (Bug#22520). * lisp/hi-lock.el (hi-lock-face-buffer): Update docstring. Determine the case fold with `search-upper-case' and `case-fold-search'. (hi-lock--regexps-at-point, hi-lock-unface-buffer): Handle when pattern is a cons (REGEXP . FUNCTION). (hi-lock-read-face-name): Update docstring. (hi-lock--case-insensitive-regexp, hi-lock--case-insensitive-regexp-p): New defuns. (hi-lock-set-pattern, hi-lock-unface-buffer): Use them. * lisp/isearch.el (isearch-highlight-regexp): Delete hack for case-insensitive search; this is now handled in hi-lock-face-buffer. --- lisp/hi-lock.el | 153 +++++++++++++++++++++++++++++++++++++++++--------------- lisp/isearch.el | 10 +--- 2 files changed, 115 insertions(+), 48 deletions(-) diff --git a/lisp/hi-lock.el b/lisp/hi-lock.el index 55ad3ccb58..5862974844 100644 --- a/lisp/hi-lock.el +++ b/lisp/hi-lock.el @@ -434,6 +434,7 @@ 'highlight-regexp ;;;###autoload (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,11 +442,15 @@ 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) - case-fold-search)) + (let* ((regexp + (hi-lock-regexp-okay + (read-regexp "Regexp to highlight" 'regexp-history-last))) + (face (hi-lock-read-face-name)) + (case-fold + (if search-upper-case + (isearch-no-upper-case-p regexp t) + case-fold-search))) + (list regexp face case-fold))) (or (facep face) (setq face 'hi-yellow)) (unless hi-lock-mode (hi-lock-mode 1)) (hi-lock-set-pattern regexp face case-fold)) @@ -531,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. @@ -562,13 +574,15 @@ 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 (or (car-safe (car 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 @@ -582,16 +596,30 @@ 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)))) - (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)))) + (mapcar (lambda (x) + (or (car-safe (car x)) + (car x))) + hi-lock-interactive-patterns))) + (regexp (completing-read (if (null defaults) + "Regexp to unhighlight: " + (format "Regexp to unhighlight (default %s): " + (car defaults))) + hi-lock-interactive-patterns + nil nil nil nil defaults))) + (when (and (or (not search-upper-case) + (isearch-no-upper-case-p regexp t)) + case-fold-search + (not (hi-lock--case-insensitive-regexp-p regexp))) + (setq regexp (hi-lock--case-insensitive-regexp regexp))) + (list regexp))))) + (let* ((patterns hi-lock-interactive-patterns) + (keys (or (assoc regexp patterns) + (assoc + (assoc regexp (mapcar #'car patterns)) + patterns)))) + (dolist (keyword (if (eq regexp t) + patterns + (list keys))) (when keyword (let ((face (hi-lock-keyword->face keyword))) ;; Make `face' the next one to use by default. @@ -606,8 +634,10 @@ hi-lock-unface-buffer (setq hi-lock-interactive-patterns (delq keyword hi-lock-interactive-patterns)) (remove-overlays - nil nil 'hi-lock-overlay-regexp (hi-lock--hashcons (car keyword))) - (font-lock-flush)))) + nil nil 'hi-lock-overlay-regexp (hi-lock--hashcons + (or (car-safe (car keyword)) + (car keyword)))) + (font-lock-flush))))) ;;;###autoload (defun hi-lock-write-interactive-patterns () @@ -690,23 +720,67 @@ hi-lock-read-face-name (add-to-list 'hi-lock-face-defaults face t)) (intern face))) +(defun hi-lock--case-insensitive-regexp-p (regexp) + (let (case-fold-search) + (and (string-match-p regexp (downcase regexp)) + (string-match-p regexp (upcase regexp))))) + +(defun hi-lock--case-insensitive-regexp (regexp) + "Turn regexp into a case-insensitive regexp." + (let ((count 0) + (upper-re "[[:upper:]]") + (slash-upper-re "\\(\\\\\\)\\([[:upper:]]\\)") + case-fold-search) + (cond ((or (hi-lock--case-insensitive-regexp-p regexp) + (and (string-match upper-re regexp) + (not (string-match slash-upper-re regexp)))) + regexp) + (t + (let ((string regexp)) + (while (string-match slash-upper-re string) + (setq string (replace-match "" t t string 1))) + (setq regexp string) + (mapconcat + (lambda (c) + (let ((s (string c))) + (cond ((or (eq c ?\\) + (and (= count 1) (string= s (upcase s)))) + (setq count (1+ count)) s) + (t + (setq count 0) + (if (string-match "[[:alpha:]]" s) + (format "[%s%s]" (upcase s) (downcase s)) + (regexp-quote s)))))) + regexp "")))))) + (defun hi-lock-set-pattern (regexp face &optional case-fold) - "Highlight REGEXP with face FACE." + "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 (if (eq case-fold 'undefined) + (let* ((pattern (list (if (eq case-fold 'undefined) regexp - (byte-compile - `(lambda (limit) - (let ((case-fold-search ,case-fold)) - (re-search-forward ,regexp limit t))))) - (list 0 (list 'quote face) 'prepend)))) + (cons regexp + (byte-compile + `(lambda (limit) + (let ((case-fold-search ,case-fold)) + (re-search-forward ,regexp limit t)))))) + (list 0 (list 'quote face) 'prepend))) + (regexp-fold + (cond ((not (consp (car pattern))) + (car pattern)) + (t + (if (not case-fold) + (caar pattern) + (hi-lock--case-insensitive-regexp (caar pattern))))))) ;; 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 regexp-fold hi-lock-interactive-patterns) + (assoc regexp-fold (mapcar #'car hi-lock-interactive-patterns))) (add-to-list 'hi-lock--unused-faces (face-name face)) - (push pattern hi-lock-interactive-patterns) (if (and font-lock-mode (font-lock-specified-p major-mode)) - (progn + (progn + (setq pattern (list regexp-fold (list 0 (list 'quote face) 'prepend))) (font-lock-add-keywords nil (list pattern) t) (font-lock-flush)) (let* ((range-min (- (point) (/ hi-lock-highlight-range 2))) @@ -725,7 +799,8 @@ hi-lock-set-pattern (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)))))))))) + (goto-char (match-end 0))))))) + (push pattern hi-lock-interactive-patterns)))) (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 250d37b45e..2496e092a6 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -1940,15 +1940,7 @@ isearch-highlight-regexp (isearch-no-upper-case-p isearch-string isearch-regexp) isearch-case-fold-search) - ;; Turn isearch-string into a case-insensitive - ;; regexp. - (mapconcat - (lambda (c) - (let ((s (string c))) - (if (string-match "[[:alpha:]]" s) - (format "[%s%s]" (upcase s) (downcase s)) - (regexp-quote s)))) - isearch-string "")) + isearch-string) (t (regexp-quote isearch-string))))) (hi-lock-face-buffer regexp (hi-lock-read-face-name) (if (and (eq isearch-case-fold-search t) -- 2.11.0 >From 6f6cdbfe8e825ed1906194fd32542c1c93d94e47 Mon Sep 17 00:00:00 2001 From: Tino Calancha Date: Thu, 25 May 2017 20:51:55 +0900 Subject: [PATCH 3/3] Honor case-fold-search in all kind of matches Perform the matches of REGEXP in `hi-lock-line-face-buffer', `hi-lock-face-phrase-buffer' and `hi-lock-face-symbol-at-point' as in `hi-lock-face-buffer'. * lisp/hi-lock.el (hi-lock--deduce-case-fold-from-regexp): New defun. (hi-lock-line-face-buffer, hi-lock-face-phrase-buffer) (hi-lock-face-symbol-at-point): Perform the matches of REGEXP as `hi-lock-face-buffer'. (hi-lock--regexps-in-pattern-p): New defun. (hi-lock-unface-buffer): Use it. --- lisp/hi-lock.el | 162 ++++++++++++++++++++++++++++++++------------------------ 1 file changed, 94 insertions(+), 68 deletions(-) diff --git a/lisp/hi-lock.el b/lisp/hi-lock.el index 5862974844..21a170f4db 100644 --- a/lisp/hi-lock.el +++ b/lisp/hi-lock.el @@ -88,6 +88,7 @@ ;;; Code: (require 'font-lock) +(eval-when-compile (require 'cl-lib)) (defgroup hi-lock nil "Interactively add and remove font-lock patterns for highlighting text." @@ -405,11 +406,17 @@ turn-on-hi-lock-if-enabled (unless (memq major-mode hi-lock-exclude-modes) (hi-lock-mode 1))) +(defun hi-lock--deduce-case-fold-from-regexp (regexp) + (if search-upper-case + (isearch-no-upper-case-p regexp t) + case-fold-search)) + ;;;###autoload (defalias 'highlight-lines-matching-regexp 'hi-lock-line-face-buffer) ;;;###autoload -(defun hi-lock-line-face-buffer (regexp &optional face) +(defun hi-lock-line-face-buffer (regexp &optional face case-fold) "Set face of all lines containing a 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. @@ -417,16 +424,19 @@ hi-lock-line-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 line" 'regexp-history-last)) - (hi-lock-read-face-name))) + (let* ((regexp + (hi-lock-regexp-okay + (read-regexp "Regexp to highlight line" 'regexp-history-last))) + (face (hi-lock-read-face-name)) + (case-fold + (hi-lock--deduce-case-fold-from-regexp regexp))) + (list regexp face case-fold))) (or (facep face) (setq face 'hi-yellow)) (unless hi-lock-mode (hi-lock-mode 1)) (hi-lock-set-pattern ;; The \\(?:...\\) grouping construct ensures that a leading ^, +, * or ? ;; or a trailing $ in REGEXP will be interpreted correctly. - (concat "^.*\\(?:" regexp "\\).*$") face)) + (concat "^.*\\(?:" regexp "\\).*$") face case-fold)) ;;;###autoload @@ -447,9 +457,7 @@ hi-lock-face-buffer (read-regexp "Regexp to highlight" 'regexp-history-last))) (face (hi-lock-read-face-name)) (case-fold - (if search-upper-case - (isearch-no-upper-case-p regexp t) - case-fold-search))) + (hi-lock--deduce-case-fold-from-regexp regexp))) (list regexp face case-fold))) (or (facep face) (setq face 'hi-yellow)) (unless hi-lock-mode (hi-lock-mode 1)) @@ -458,8 +466,9 @@ hi-lock-face-buffer ;;;###autoload (defalias 'highlight-phrase 'hi-lock-face-phrase-buffer) ;;;###autoload -(defun hi-lock-face-phrase-buffer (regexp &optional face) +(defun hi-lock-face-phrase-buffer (regexp &optional face case-fold) "Set face of each match of phrase 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. @@ -471,14 +480,19 @@ hi-lock-face-phrase-buffer use overlays for highlighting. If overlays are used, the highlighting will not update as you type." (interactive - (list - (hi-lock-regexp-okay - (hi-lock-process-phrase - (read-regexp "Phrase to highlight" 'regexp-history-last))) - (hi-lock-read-face-name))) + (let* ((regexp + (hi-lock-regexp-okay + (read-regexp "Phrase to highlight" 'regexp-history-last))) + (face (hi-lock-read-face-name)) + (case-fold + (hi-lock--deduce-case-fold-from-regexp regexp))) + (setq regexp + (hi-lock-regexp-okay + (hi-lock-process-phrase regexp case-fold))) + (list regexp face case-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-symbol-at-point 'hi-lock-face-symbol-at-point) @@ -495,10 +509,12 @@ hi-lock-face-symbol-at-point (let* ((regexp (hi-lock-regexp-okay (find-tag-default-as-symbol-regexp))) (hi-lock-auto-select-face t) - (face (hi-lock-read-face-name))) + (face (hi-lock-read-face-name)) + (case-fold + (hi-lock--deduce-case-fold-from-regexp regexp))) (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))) (defun hi-lock-keyword->face (keyword) (cadr (cadr (cadr keyword)))) ; Keyword looks like (REGEXP (0 'FACE) ...). @@ -552,6 +568,12 @@ hi-lock--unused-faces "List of faces that is not used and is available for highlighting new text. Face names from this list come from `hi-lock-face-defaults'.") +(defun hi-lock--regexps-in-pattern-p (pattern &rest regexps) + (cl-some (lambda (reg) + (or (assoc reg pattern) + (assoc (assoc reg (mapcar #'car pattern)) pattern))) + regexps)) + ;;;###autoload (defalias 'unhighlight-regexp 'hi-lock-unface-buffer) ;;;###autoload @@ -574,15 +596,15 @@ hi-lock-unface-buffer (cons `keymap (cons "Select Pattern to Unhighlight" - (mapcar (lambda (pattern) - (let ((regexp (or (car-safe (car pattern)) - (car pattern)))) - (list regexp - (format - "%s (%s)" regexp - (hi-lock-keyword->face pattern)) - (cons nil nil) - regexp))) + (mapcar (lambda (pattern) + (let ((regexp (or (car-safe (car 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 @@ -599,45 +621,53 @@ hi-lock-unface-buffer (mapcar (lambda (x) (or (car-safe (car x)) (car x))) - hi-lock-interactive-patterns))) + hi-lock-interactive-patterns))) (regexp (completing-read (if (null defaults) "Regexp to unhighlight: " (format "Regexp to unhighlight (default %s): " (car defaults))) hi-lock-interactive-patterns nil nil nil nil defaults))) - (when (and (or (not search-upper-case) - (isearch-no-upper-case-p regexp t)) - case-fold-search - (not (hi-lock--case-insensitive-regexp-p regexp))) - (setq regexp (hi-lock--case-insensitive-regexp regexp))) (list regexp))))) (let* ((patterns hi-lock-interactive-patterns) - (keys (or (assoc regexp patterns) - (assoc - (assoc regexp (mapcar #'car patterns)) - patterns)))) + (keys (or (eq regexp t) + (let* ((case-fold (hi-lock--deduce-case-fold-from-regexp regexp)) + (case-in-regexp + (and (or (not search-upper-case) + (isearch-no-upper-case-p regexp t)) + case-fold-search + (not (hi-lock--case-insensitive-regexp-p regexp)) + (hi-lock--case-insensitive-regexp regexp))) + (xregexp (or case-in-regexp regexp))) + ;; Match a regexp. + (or (hi-lock--regexps-in-pattern-p patterns regexp xregexp) + ;; Match a line. + (let ((line-re (format "^.*\\(?:%s\\).*$" xregexp))) + (hi-lock--regexps-in-pattern-p patterns line-re)) + ;; Match a phrase. + (let ((phrase-re (hi-lock-process-phrase regexp case-fold))) + (hi-lock--regexps-in-pattern-p patterns phrase-re))))))) (dolist (keyword (if (eq regexp t) patterns (list keys))) - (when keyword - (let ((face (hi-lock-keyword->face keyword))) - ;; Make `face' the next one to use by default. - (when (symbolp face) ;Don't add it if it's a list (bug#13297). - (add-to-list 'hi-lock--unused-faces (face-name face)))) - ;; FIXME: Calling `font-lock-remove-keywords' causes - ;; `font-lock-specified-p' to go from nil to non-nil (because it - ;; calls font-lock-set-defaults). This is yet-another bug in - ;; font-lock-add/remove-keywords, which we circumvent here by - ;; testing `font-lock-fontified' (bug#19796). - (if font-lock-fontified (font-lock-remove-keywords nil (list keyword))) - (setq hi-lock-interactive-patterns - (delq keyword hi-lock-interactive-patterns)) - (remove-overlays - nil nil 'hi-lock-overlay-regexp (hi-lock--hashcons - (or (car-safe (car keyword)) - (car keyword)))) - (font-lock-flush))))) + (when keyword + (let ((face (hi-lock-keyword->face keyword))) + ;; Make `face' the next one to use by default. + (when (symbolp face) ;Don't add it if it's a list (bug#13297). + (add-to-list 'hi-lock--unused-faces (face-name face)))) + ;; FIXME: Calling `font-lock-remove-keywords' causes + ;; `font-lock-specified-p' to go from nil to non-nil (because it + ;; calls font-lock-set-defaults). This is yet-another bug in + ;; font-lock-add/remove-keywords, which we circumvent here by + ;; testing `font-lock-fontified' (bug#19796). + (if font-lock-fontified (font-lock-remove-keywords nil (list keyword))) + (setq hi-lock-interactive-patterns + (delq keyword hi-lock-interactive-patterns)) + (remove-overlays + nil nil 'hi-lock-overlay-regexp (hi-lock--hashcons + (or (car-safe (car keyword)) + (car keyword)))) + (font-lock-flush))))) ;;;###autoload (defun hi-lock-write-interactive-patterns () @@ -662,20 +692,16 @@ hi-lock-write-interactive-patterns ;; Implementation Functions -(defun hi-lock-process-phrase (phrase) +(defun hi-lock-process-phrase (phrase &optional case-fold) "Convert regexp PHRASE to a regexp that matches phrases. -Blanks in PHRASE replaced by regexp that matches arbitrary whitespace -and initial lower-case letters made case insensitive." - (let ((mod-phrase nil)) - ;; FIXME fragile; better to just bind case-fold-search? (Bug#7161) - (setq mod-phrase - (replace-regexp-in-string - "\\(^\\|\\s-\\)\\([a-z]\\)" - (lambda (m) (format "%s[%s%s]" - (match-string 1 m) - (upcase (match-string 2 m)) - (match-string 2 m))) phrase)) +If optional arg CASE-FOLD is non-nil, then transform PHRASE into a case +insensitive pattern. +Blanks in PHRASE replaced by regexp that matches arbitrary whitespace." + ;; FIXME fragile; better to just bind case-fold-search? (Bug#7161) + (let ((mod-phrase (if case-fold + (hi-lock--case-insensitive-regexp phrase) + phrase))) ;; FIXME fragile; better to use search-spaces-regexp? (setq mod-phrase (replace-regexp-in-string @@ -750,7 +776,7 @@ hi-lock--case-insensitive-regexp (setq count 0) (if (string-match "[[:alpha:]]" s) (format "[%s%s]" (upcase s) (downcase s)) - (regexp-quote s)))))) + s))))) regexp "")))))) (defun hi-lock-set-pattern (regexp face &optional case-fold) -- 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-05-25 Repository revision: b2ec91db89739153b39d10c15701b57aae7e251c