X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/f5bd8092f26cfc61afd4f6c9701f86ef30baaba5..6e0f362cb0a10f1a71fcc10ca8c979de4673217c:/lisp/hi-lock.el diff --git a/lisp/hi-lock.el b/lisp/hi-lock.el index e856e7e95d..14920cf93c 100644 --- a/lisp/hi-lock.el +++ b/lisp/hi-lock.el @@ -1,6 +1,7 @@ -;;; hi-lock.el --- Minor mode for interactive automatic highlighting. +;;; hi-lock.el --- minor mode for interactive automatic highlighting -;; Copyright (C) 2000 Free Software Foundation, Inc. +;; Copyright (C) 2000, 2001, 2002, 2003, 2004, +;; 2005 Free Software Foundation, Inc. ;; Author: David M. Koppelman, koppel@ee.lsu.edu ;; Keywords: faces, minor-mode, matching, display @@ -19,11 +20,11 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. -;;; Commentary -;; +;;; Commentary: +;; ;; With the hi-lock commands text matching interactively entered ;; regexp's can be highlighted. For example, `M-x highlight-regexp ;; RET clearly RET RET' will highlight all occurrences of `clearly' @@ -49,22 +50,23 @@ ;; ;; When writing text, highlight personal cliches. This can be ;; amusing. -;; M-x highlight-regexp as can be seen RET RET +;; M-x highlight-phrase as can be seen RET RET ;; -;; Setup +;; Setup: ;; ;; Put the following code in your .emacs file. This turns on -;; hi-lock mode and adds an "Automatic Highlighting" entry +;; hi-lock mode and adds a "Regexp Highlighting" entry ;; to the edit menu. ;; ;; (hi-lock-mode 1) -;; +;; ;; You might also want to bind the hi-lock commands to more ;; finger-friendly sequences: ;; (define-key hi-lock-map "\C-z\C-h" 'highlight-lines-matching-regexp) ;; (define-key hi-lock-map "\C-zi" 'hi-lock-find-patterns) ;; (define-key hi-lock-map "\C-zh" 'highlight-regexp) +;; (define-key hi-lock-map "\C-zp" 'highlight-phrase) ;; (define-key hi-lock-map "\C-zr" 'unhighlight-regexp) ;; (define-key hi-lock-map "\C-zb" 'hi-lock-write-interactive-patterns)) @@ -82,7 +84,6 @@ (eval-and-compile (require 'font-lock)) -;;;###autoload (defgroup hi-lock-interactive-text-highlighting nil "Interactively add and remove font-lock patterns for highlighting text." :group 'faces) @@ -119,7 +120,10 @@ calls." :group 'hi-lock-interactive-text-highlighting) (defface hi-yellow - '((((background dark)) (:background "yellow" :foreground "black")) + '((((min-colors 88) (background dark)) + (:background "yellow1" :foreground "black")) + (((background dark)) (:background "yellow" :foreground "black")) + (((min-colors 88)) (:background "yellow1")) (t (:background "yellow"))) "Default face for hi-lock mode." :group 'hi-lock-faces) @@ -131,7 +135,10 @@ calls." :group 'hi-lock-faces) (defface hi-green - '((((background dark)) (:background "green" :foreground "black")) + '((((min-colors 88) (background dark)) + (:background "green1" :foreground "black")) + (((background dark)) (:background "green" :foreground "black")) + (((min-colors 88)) (:background "green1")) (t (:background "green"))) "Face for hi-lock mode." :group 'hi-lock-faces) @@ -148,17 +155,20 @@ calls." :group 'hi-lock-faces) (defface hi-blue-b - '((t (:weight bold :foreground "blue"))) + '((((min-colors 88)) (:weight bold :foreground "blue1")) + (t (:weight bold :foreground "blue"))) "Face for hi-lock mode." :group 'hi-lock-faces) (defface hi-green-b - '((t (:weight bold :foreground "green"))) + '((((min-colors 88)) (:weight bold :foreground "green1")) + (t (:weight bold :foreground "green"))) "Face for hi-lock mode." :group 'hi-lock-faces) (defface hi-red-b - '((t (:weight bold :foreground "red"))) + '((((min-colors 88)) (:weight bold :foreground "red1")) + (t (:weight bold :foreground "red"))) "Face for hi-lock mode." :group 'hi-lock-faces) @@ -200,6 +210,10 @@ calls." '(menu-item "Highlight Regexp..." highlight-regexp :help "Highlight text matching PATTERN (a regexp).")) +(define-key-after hi-lock-menu [highlight-phrase] + '(menu-item "Highlight Phrase..." highlight-phrase + :help "Highlight text matching PATTERN (a regexp processed to match phrases).")) + (define-key-after hi-lock-menu [highlight-lines-matching-regexp] '(menu-item "Highlight Lines..." highlight-lines-matching-regexp :help "Highlight lines containing match of PATTERN (a regexp)..")) @@ -223,6 +237,7 @@ calls." (define-key hi-lock-map "\C-xwi" 'hi-lock-find-patterns) (define-key hi-lock-map "\C-xwl" 'highlight-lines-matching-regexp) +(define-key hi-lock-map "\C-xwp" 'highlight-phrase) (define-key hi-lock-map "\C-xwh" 'highlight-regexp) (define-key hi-lock-map "\C-xwr" 'unhighlight-regexp) (define-key hi-lock-map "\C-xwb" 'hi-lock-write-interactive-patterns) @@ -243,13 +258,18 @@ calls." "Toggle minor mode for interactively adding font-lock highlighting patterns. If ARG positive turn hi-lock on. Issuing a hi-lock command will also -turn hi-lock on. When hi-lock turned on an \"Automatic Highlighting\" +turn hi-lock on. When hi-lock is turned on, a \"Regexp Highlighting\" submenu is added to the \"Edit\" menu. The commands in the submenu, which can be called interactively, are: \\[highlight-regexp] REGEXP FACE Highlight matches of pattern REGEXP in current buffer with FACE. +\\[highlight-phrase] PHRASE FACE + Highlight matches of phrase PHRASE in current buffer with FACE. + (PHRASE can be any REGEXP, but spaces will be replaced by matches + to whitespace and initial lower-case letters will become case insensitive.) + \\[highlight-lines-matching-regexp] REGEXP FACE Highlight lines containing matches of REGEXP in current buffer with FACE. @@ -278,24 +298,32 @@ is found. A mode is excluded if it's in the list `hi-lock-exclude-modes'." (interactive) (let ((hi-lock-mode-prev hi-lock-mode)) (setq hi-lock-mode - (if (null arg) (not hi-lock-mode) - (> (prefix-numeric-value arg) 0))) + (if (null arg) (not hi-lock-mode) + (> (prefix-numeric-value arg) 0))) ;; Turned on. (when (and (not hi-lock-mode-prev) hi-lock-mode) - (if (not font-lock-mode) (turn-on-font-lock)) - (add-hook 'find-file-hooks 'hi-lock-find-file-hook) + (add-hook 'find-file-hook 'hi-lock-find-file-hook) (add-hook 'font-lock-mode-hook 'hi-lock-font-lock-hook) + (when (eq nil font-lock-defaults) + (setq font-lock-defaults '(nil))) + (unless font-lock-mode + (font-lock-mode 1)) (define-key-after menu-bar-edit-menu [hi-lock] - (cons "Automatic Highlighting" hi-lock-menu)) - (hi-lock-find-patterns)) + (cons "Regexp Highlighting" hi-lock-menu)) + (dolist (buffer (buffer-list)) + (with-current-buffer buffer (hi-lock-find-patterns)))) ;; Turned off. (when (and hi-lock-mode-prev (not hi-lock-mode)) - (font-lock-remove-keywords nil hi-lock-interactive-patterns) - (font-lock-remove-keywords nil hi-lock-file-patterns) - (setq hi-lock-interactive-patterns nil) - (hi-lock-refontify) + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (when (or hi-lock-interactive-patterns hi-lock-file-patterns) + (font-lock-remove-keywords nil hi-lock-interactive-patterns) + (font-lock-remove-keywords nil hi-lock-file-patterns) + (setq hi-lock-interactive-patterns nil + hi-lock-file-patterns nil) + (when font-lock-mode (hi-lock-refontify))))) (define-key-after menu-bar-edit-menu [hi-lock] nil) - (remove-hook 'find-file-hooks 'hi-lock-find-file-hook) + (remove-hook 'find-file-hook 'hi-lock-find-file-hook) (remove-hook 'font-lock-mode-hook 'hi-lock-font-lock-hook)))) @@ -303,12 +331,12 @@ is found. A mode is excluded if it's in the list `hi-lock-exclude-modes'." (defalias 'highlight-lines-matching-regexp 'hi-lock-line-face-buffer) ;;;###autoload (defun hi-lock-line-face-buffer (regexp &optional face) - "Set face of all lines containing matches of REGEXP to FACE. + "Set face of all lines containing a match of REGEXP to FACE. Interactively, prompt for REGEXP then FACE. Buffer-local history list maintained for regexps, global history maintained for faces. \\Use \\[next-history-element] and \\[previous-history-element] to retrieve next or previous history item. -(See info node `Minibuffer History')" +\(See info node `Minibuffer History')" (interactive (list (hi-lock-regexp-okay @@ -319,18 +347,21 @@ list maintained for regexps, global history maintained for faces. (unless hi-lock-mode (hi-lock-mode)) (or (facep face) (setq face 'rwl-yellow)) (hi-lock-set-pattern - (list (concat "^.*" regexp ".*$") (list 0 (list 'quote face) t)))) + ;; The \\(?:...\\) grouping construct ensures that a leading ^, +, * or ? + ;; or a trailing $ in REGEXP will be interpreted correctly. + (list (concat "^.*\\(?:" regexp "\\).*$") (list 0 (list 'quote face) t)))) + ;;;###autoload (defalias 'highlight-regexp 'hi-lock-face-buffer) ;;;###autoload (defun hi-lock-face-buffer (regexp &optional face) - "Set face of all matches of REGEXP to FACE. + "Set face of each match of REGEXP to FACE. Interactively, prompt for REGEXP then FACE. Buffer-local history list maintained for regexps, global history maintained for faces. \\Use \\[next-history-element] and \\[previous-history-element] to retrieve next or previous history item. -(See info node `Minibuffer History')" +\(See info node `Minibuffer History')" (interactive (list (hi-lock-regexp-okay @@ -342,19 +373,39 @@ list maintained for regexps, global history maintained for faces. (unless hi-lock-mode (hi-lock-mode)) (hi-lock-set-pattern (list regexp (list 0 (list 'quote face) t)))) +;;;###autoload +(defalias 'highlight-phrase 'hi-lock-face-phrase-buffer) +;;;###autoload +(defun hi-lock-face-phrase-buffer (regexp &optional face) + "Set face of each match of phrase REGEXP to FACE. + +Whitespace in REGEXP converted to arbitrary whitespace and initial +lower-case letters made case insensitive." + (interactive + (list + (hi-lock-regexp-okay + (hi-lock-process-phrase + (read-from-minibuffer "Phrase to highlight: " + (cons (or (car hi-lock-regexp-history) "") 1 ) + nil nil 'hi-lock-regexp-history))) + (hi-lock-read-face-name))) + (or (facep face) (setq face 'rwl-yellow)) + (unless hi-lock-mode (hi-lock-mode)) + (hi-lock-set-pattern (list regexp (list 0 (list 'quote face) t)))) + ;;;###autoload (defalias 'unhighlight-regexp 'hi-lock-unface-buffer) ;;;###autoload (defun hi-lock-unface-buffer (regexp) - "Remove highlighting of matches to REGEXP set by hi-lock. + "Remove highlighting of each match to REGEXP set by hi-lock. Interactively, prompt for REGEXP. Buffer-local history of inserted regexp's maintained. Will accept only regexps inserted by hi-lock -interactive functions. \(See `hi-lock-interactive-patterns'.\) +interactive functions. \(See `hi-lock-interactive-patterns'.\) \\Use \\[minibuffer-complete] to complete a partially typed regexp. \(See info node `Minibuffer History'.\)" (interactive - (if (vectorp (this-command-keys)) + (if (and (display-popup-menus-p) (vectorp (this-command-keys))) (catch 'snafu (or (x-popup-menu @@ -384,7 +435,7 @@ interactive functions. \(See `hi-lock-interactive-patterns'.\) (error "No highlighting to remove")) (list (completing-read "Regexp to unhighlight: " - hi-lock-interactive-patterns t t + hi-lock-interactive-patterns nil t (car (car hi-lock-interactive-patterns)) (cons 'history-list 1)))))) (let ((keyword (assoc regexp hi-lock-interactive-patterns))) @@ -416,6 +467,19 @@ be found in variable `hi-lock-interactive-patterns'." ;; Implementation Functions +(defun hi-lock-process-phrase (phrase) + "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)) + (setq mod-phrase + (replace-regexp-in-string + "\\<[a-z]" (lambda (m) (format "[%s%s]" (upcase m) m)) phrase)) + (setq mod-phrase + (replace-regexp-in-string + "\\s-+" "[ \t\n]+" mod-phrase nil t)))) + (defun hi-lock-regexp-okay (regexp) "Return REGEXP if it appears suitable for a font-lock pattern. @@ -467,25 +531,17 @@ Optional argument END is maximum excursion." (defun hi-lock-set-file-patterns (patterns) "Replace file patterns list with PATTERNS and refontify." - (font-lock-remove-keywords nil hi-lock-file-patterns) - (setq hi-lock-file-patterns patterns) - (font-lock-add-keywords nil hi-lock-file-patterns) - (hi-lock-refontify)) + (when (or hi-lock-file-patterns patterns) + (font-lock-remove-keywords nil hi-lock-file-patterns) + (setq hi-lock-file-patterns patterns) + (font-lock-add-keywords nil hi-lock-file-patterns) + (hi-lock-refontify))) (defun hi-lock-refontify () "Unfontify then refontify buffer. Used when hi-lock patterns change." (interactive) - (font-lock-unfontify-buffer) - (cond - (jit-lock-mode (jit-lock-refontify)) - ;; Need a better way, since this assumes too much about lazy lock. - (lazy-lock-mode - (let ((windows (get-buffer-window-list (current-buffer) 'nomini t))) - (while windows - (lazy-lock-fontify-window (car windows)) - (setq windows (cdr windows))))) - (t (font-lock-fontify-buffer)))) - + (unless font-lock-mode (font-lock-mode 1)) + (font-lock-fontify-buffer)) (defun hi-lock-find-patterns () "Find patterns in current buffer for hi-lock." @@ -494,27 +550,19 @@ Optional argument END is maximum excursion." (let ((all-patterns nil) (target-regexp (concat "\\<" hi-lock-file-patterns-prefix ":"))) (save-excursion - (widen) - (goto-char (point-min)) - (re-search-forward target-regexp - (+ (point) hi-lock-file-patterns-range) t) - (beginning-of-line) - (while - (and - (re-search-forward target-regexp (+ (point) 100) t) - (not (looking-at "\\s-*end"))) - (let - ((patterns - (condition-case nil - (read (current-buffer)) - (error (message - (format "Could not read expression at %d" - (hi-lock-current-line))) nil)))) - (if patterns - (setq all-patterns (append patterns all-patterns)))))) - (if (and (not hi-lock-mode) all-patterns) - (hi-lock-mode 1)) - (if hi-lock-mode (hi-lock-set-file-patterns all-patterns)) + (save-restriction + (widen) + (goto-char (point-min)) + (re-search-forward target-regexp + (+ (point) hi-lock-file-patterns-range) t) + (beginning-of-line) + (while (and (re-search-forward target-regexp (+ (point) 100) t) + (not (looking-at "\\s-*end"))) + (condition-case nil + (setq all-patterns (append (read (current-buffer)) all-patterns)) + (error (message "Invalid pattern list expression at %d" + (hi-lock-current-line))))))) + (when hi-lock-mode (hi-lock-set-file-patterns all-patterns)) (if (interactive-p) (message (format "Hi-lock added %d patterns." (length all-patterns))))))) @@ -526,4 +574,5 @@ Optional argument END is maximum excursion." (provide 'hi-lock) +;; arch-tag: d2e8fd07-4cc9-4c6f-a200-1e729bc54066 ;;; hi-lock.el ends here