| 1 | ;;; hi-lock.el --- minor mode for interactive automatic highlighting |
| 2 | |
| 3 | ;; Copyright (C) 2000-2012 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: David M. Koppelman <koppel@ece.lsu.edu> |
| 6 | ;; Keywords: faces, minor-mode, matching, display |
| 7 | |
| 8 | ;; This file is part of GNU Emacs. |
| 9 | |
| 10 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
| 11 | ;; it under the terms of the GNU General Public License as published by |
| 12 | ;; the Free Software Foundation, either version 3 of the License, or |
| 13 | ;; (at your option) any later version. |
| 14 | |
| 15 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 18 | ;; GNU General Public License for more details. |
| 19 | |
| 20 | ;; You should have received a copy of the GNU General Public License |
| 21 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
| 22 | |
| 23 | ;;; Commentary: |
| 24 | ;; |
| 25 | ;; With the hi-lock commands text matching interactively entered |
| 26 | ;; regexp's can be highlighted. For example, `M-x highlight-regexp |
| 27 | ;; RET clearly RET RET' will highlight all occurrences of `clearly' |
| 28 | ;; using a yellow background face. New occurrences of `clearly' will |
| 29 | ;; be highlighted as they are typed. `M-x unhighlight-regexp RET' |
| 30 | ;; will remove the highlighting. Any existing face can be used for |
| 31 | ;; highlighting and a set of appropriate faces is provided. The |
| 32 | ;; regexps can be written into the current buffer in a form that will |
| 33 | ;; be recognized the next time the corresponding file is read (when |
| 34 | ;; file patterns is turned on). |
| 35 | ;; |
| 36 | ;; Applications: |
| 37 | ;; |
| 38 | ;; In program source code highlight a variable to quickly see all |
| 39 | ;; places it is modified or referenced: |
| 40 | ;; M-x highlight-regexp ground_contact_switches_closed RET RET |
| 41 | ;; |
| 42 | ;; In a shell or other buffer that is showing lots of program |
| 43 | ;; output, highlight the parts of the output you're interested in: |
| 44 | ;; M-x highlight-regexp Total execution time [0-9]+ RET hi-blue-b RET |
| 45 | ;; |
| 46 | ;; In buffers displaying tables, highlight the lines you're interested in: |
| 47 | ;; M-x highlight-lines-matching-regexp January 2000 RET hi-black-b RET |
| 48 | ;; |
| 49 | ;; When writing text, highlight personal cliches. This can be |
| 50 | ;; amusing. |
| 51 | ;; M-x highlight-phrase as can be seen RET RET |
| 52 | ;; |
| 53 | ;; Setup: |
| 54 | ;; |
| 55 | ;; Put the following code in your .emacs file. This turns on |
| 56 | ;; hi-lock mode and adds a "Regexp Highlighting" entry |
| 57 | ;; to the edit menu. |
| 58 | ;; |
| 59 | ;; (global-hi-lock-mode 1) |
| 60 | ;; |
| 61 | ;; To enable the use of patterns found in files (presumably placed |
| 62 | ;; there by hi-lock) include the following in your .emacs file: |
| 63 | ;; |
| 64 | ;; (setq hi-lock-file-patterns-policy 'ask) |
| 65 | ;; |
| 66 | ;; If you get tired of being asked each time a file is loaded replace |
| 67 | ;; `ask' with a function that returns t if patterns should be read. |
| 68 | ;; |
| 69 | ;; You might also want to bind the hi-lock commands to more |
| 70 | ;; finger-friendly sequences: |
| 71 | |
| 72 | ;; (define-key hi-lock-map "\C-z\C-h" 'highlight-lines-matching-regexp) |
| 73 | ;; (define-key hi-lock-map "\C-zi" 'hi-lock-find-patterns) |
| 74 | ;; (define-key hi-lock-map "\C-zh" 'highlight-regexp) |
| 75 | ;; (define-key hi-lock-map "\C-zp" 'highlight-phrase) |
| 76 | ;; (define-key hi-lock-map "\C-zr" 'unhighlight-regexp) |
| 77 | ;; (define-key hi-lock-map "\C-zb" 'hi-lock-write-interactive-patterns)) |
| 78 | |
| 79 | ;; See the documentation for hi-lock-mode `C-h f hi-lock-mode' for |
| 80 | ;; additional instructions. |
| 81 | |
| 82 | ;; Sample file patterns: |
| 83 | |
| 84 | ; Hi-lock: (("^;;; .*" (0 (quote hi-black-hb) t))) |
| 85 | ; Hi-lock: ( ("make-variable-buffer-\\(local\\)" (0 font-lock-keyword-face)(1 'italic append))))) |
| 86 | ; Hi-lock: end |
| 87 | |
| 88 | ;;; Code: |
| 89 | |
| 90 | (require 'font-lock) |
| 91 | |
| 92 | (defgroup hi-lock nil |
| 93 | "Interactively add and remove font-lock patterns for highlighting text." |
| 94 | :link '(custom-manual "(emacs)Highlight Interactively") |
| 95 | :group 'font-lock) |
| 96 | |
| 97 | (defcustom hi-lock-file-patterns-range 10000 |
| 98 | "Limit of search in a buffer for hi-lock patterns. |
| 99 | When a file is visited and hi-lock mode is on, patterns starting |
| 100 | up to this limit are added to font-lock's patterns. See documentation |
| 101 | of functions `hi-lock-mode' and `hi-lock-find-patterns'." |
| 102 | :type 'integer |
| 103 | :group 'hi-lock) |
| 104 | |
| 105 | (defcustom hi-lock-highlight-range 200000 |
| 106 | "Size of area highlighted by hi-lock when font-lock not active. |
| 107 | Font-lock is not active in buffers that do their own highlighting, |
| 108 | such as the buffer created by `list-colors-display'. In those buffers |
| 109 | hi-lock patterns will only be applied over a range of |
| 110 | `hi-lock-highlight-range' characters. If font-lock is active then |
| 111 | highlighting will be applied throughout the buffer." |
| 112 | :type 'integer |
| 113 | :group 'hi-lock) |
| 114 | |
| 115 | (defcustom hi-lock-exclude-modes |
| 116 | '(rmail-mode mime/viewer-mode gnus-article-mode) |
| 117 | "List of major modes in which hi-lock will not run. |
| 118 | For security reasons since font lock patterns can specify function |
| 119 | calls." |
| 120 | :type '(repeat symbol) |
| 121 | :group 'hi-lock) |
| 122 | |
| 123 | (defcustom hi-lock-file-patterns-policy 'ask |
| 124 | "Specify when hi-lock should use patterns found in file. |
| 125 | If `ask', prompt when patterns found in buffer; if bound to a function, |
| 126 | use patterns when function returns t (function is called with patterns |
| 127 | as first argument); if nil or `never' or anything else, don't use file |
| 128 | patterns." |
| 129 | :type '(choice (const :tag "Do not use file patterns" never) |
| 130 | (const :tag "Ask about file patterns" ask) |
| 131 | (function :tag "Function to check file patterns")) |
| 132 | :group 'hi-lock |
| 133 | :version "22.1") |
| 134 | |
| 135 | ;; It can have a function value. |
| 136 | (put 'hi-lock-file-patterns-policy 'risky-local-variable t) |
| 137 | |
| 138 | (defgroup hi-lock-faces nil |
| 139 | "Faces for hi-lock." |
| 140 | :group 'hi-lock |
| 141 | :group 'faces) |
| 142 | |
| 143 | (defface hi-yellow |
| 144 | '((((min-colors 88) (background dark)) |
| 145 | (:background "yellow1" :foreground "black")) |
| 146 | (((background dark)) (:background "yellow" :foreground "black")) |
| 147 | (((min-colors 88)) (:background "yellow1")) |
| 148 | (t (:background "yellow"))) |
| 149 | "Default face for hi-lock mode." |
| 150 | :group 'hi-lock-faces) |
| 151 | |
| 152 | (defface hi-pink |
| 153 | '((((background dark)) (:background "pink" :foreground "black")) |
| 154 | (t (:background "pink"))) |
| 155 | "Face for hi-lock mode." |
| 156 | :group 'hi-lock-faces) |
| 157 | |
| 158 | (defface hi-green |
| 159 | '((((min-colors 88) (background dark)) |
| 160 | (:background "green1" :foreground "black")) |
| 161 | (((background dark)) (:background "green" :foreground "black")) |
| 162 | (((min-colors 88)) (:background "green1")) |
| 163 | (t (:background "green"))) |
| 164 | "Face for hi-lock mode." |
| 165 | :group 'hi-lock-faces) |
| 166 | |
| 167 | (defface hi-blue |
| 168 | '((((background dark)) (:background "light blue" :foreground "black")) |
| 169 | (t (:background "light blue"))) |
| 170 | "Face for hi-lock mode." |
| 171 | :group 'hi-lock-faces) |
| 172 | |
| 173 | (defface hi-black-b |
| 174 | '((t (:weight bold))) |
| 175 | "Face for hi-lock mode." |
| 176 | :group 'hi-lock-faces) |
| 177 | |
| 178 | (defface hi-blue-b |
| 179 | '((((min-colors 88)) (:weight bold :foreground "blue1")) |
| 180 | (t (:weight bold :foreground "blue"))) |
| 181 | "Face for hi-lock mode." |
| 182 | :group 'hi-lock-faces) |
| 183 | |
| 184 | (defface hi-green-b |
| 185 | '((((min-colors 88)) (:weight bold :foreground "green1")) |
| 186 | (t (:weight bold :foreground "green"))) |
| 187 | "Face for hi-lock mode." |
| 188 | :group 'hi-lock-faces) |
| 189 | |
| 190 | (defface hi-red-b |
| 191 | '((((min-colors 88)) (:weight bold :foreground "red1")) |
| 192 | (t (:weight bold :foreground "red"))) |
| 193 | "Face for hi-lock mode." |
| 194 | :group 'hi-lock-faces) |
| 195 | |
| 196 | (defface hi-black-hb |
| 197 | '((t (:weight bold :height 1.67 :inherit variable-pitch))) |
| 198 | "Face for hi-lock mode." |
| 199 | :group 'hi-lock-faces) |
| 200 | |
| 201 | (defvar hi-lock-file-patterns nil |
| 202 | "Patterns found in file for hi-lock. Should not be changed.") |
| 203 | |
| 204 | (defvar hi-lock-interactive-patterns nil |
| 205 | "Patterns provided to hi-lock by user. Should not be changed.") |
| 206 | |
| 207 | (defvar hi-lock-face-defaults |
| 208 | '("hi-yellow" "hi-pink" "hi-green" "hi-blue" "hi-black-b" |
| 209 | "hi-blue-b" "hi-red-b" "hi-green-b" "hi-black-hb") |
| 210 | "Default faces for hi-lock interactive functions.") |
| 211 | |
| 212 | ;(dolist (f hi-lock-face-defaults) (unless (facep f) (error "%s not a face" f))) |
| 213 | |
| 214 | (define-obsolete-variable-alias 'hi-lock-face-history |
| 215 | 'hi-lock-face-defaults |
| 216 | "23.1") |
| 217 | |
| 218 | (define-obsolete-variable-alias 'hi-lock-regexp-history |
| 219 | 'regexp-history |
| 220 | "23.1") |
| 221 | |
| 222 | (defvar hi-lock-file-patterns-prefix "Hi-lock" |
| 223 | "Search target for finding hi-lock patterns at top of file.") |
| 224 | |
| 225 | (defvar hi-lock-archaic-interface-message-used nil |
| 226 | "True if user alerted that `global-hi-lock-mode' is now the global switch. |
| 227 | Earlier versions of hi-lock used `hi-lock-mode' as the global switch; |
| 228 | the message is issued if it appears that `hi-lock-mode' is used assuming |
| 229 | that older functionality. This variable avoids multiple reminders.") |
| 230 | |
| 231 | (defvar hi-lock-archaic-interface-deduce nil |
| 232 | "If non-nil, sometimes assume that `hi-lock-mode' means `global-hi-lock-mode'. |
| 233 | Assumption is made if `hi-lock-mode' used in the *scratch* buffer while |
| 234 | a library is being loaded.") |
| 235 | |
| 236 | (make-variable-buffer-local 'hi-lock-interactive-patterns) |
| 237 | (put 'hi-lock-interactive-patterns 'permanent-local t) |
| 238 | (make-variable-buffer-local 'hi-lock-file-patterns) |
| 239 | (put 'hi-lock-file-patterns 'permanent-local t) |
| 240 | |
| 241 | (defvar hi-lock-menu |
| 242 | (let ((map (make-sparse-keymap "Hi Lock"))) |
| 243 | (define-key-after map [highlight-regexp] |
| 244 | '(menu-item "Highlight Regexp..." highlight-regexp |
| 245 | :help "Highlight text matching PATTERN (a regexp).")) |
| 246 | |
| 247 | (define-key-after map [highlight-phrase] |
| 248 | '(menu-item "Highlight Phrase..." highlight-phrase |
| 249 | :help "Highlight text matching PATTERN (a regexp processed to match phrases).")) |
| 250 | |
| 251 | (define-key-after map [highlight-lines-matching-regexp] |
| 252 | '(menu-item "Highlight Lines..." highlight-lines-matching-regexp |
| 253 | :help "Highlight lines containing match of PATTERN (a regexp).")) |
| 254 | |
| 255 | (define-key-after map [unhighlight-regexp] |
| 256 | '(menu-item "Remove Highlighting..." unhighlight-regexp |
| 257 | :help "Remove previously entered highlighting pattern." |
| 258 | :enable hi-lock-interactive-patterns)) |
| 259 | |
| 260 | (define-key-after map [hi-lock-write-interactive-patterns] |
| 261 | '(menu-item "Patterns to Buffer" hi-lock-write-interactive-patterns |
| 262 | :help "Insert interactively added REGEXPs into buffer at point." |
| 263 | :enable hi-lock-interactive-patterns)) |
| 264 | |
| 265 | (define-key-after map [hi-lock-find-patterns] |
| 266 | '(menu-item "Patterns from Buffer" hi-lock-find-patterns |
| 267 | :help "Use patterns (if any) near top of buffer.")) |
| 268 | map) |
| 269 | "Menu for hi-lock mode.") |
| 270 | |
| 271 | (defvar hi-lock-map |
| 272 | (let ((map (make-sparse-keymap "Hi Lock"))) |
| 273 | (define-key map "\C-xwi" 'hi-lock-find-patterns) |
| 274 | (define-key map "\C-xwl" 'highlight-lines-matching-regexp) |
| 275 | (define-key map "\C-xwp" 'highlight-phrase) |
| 276 | (define-key map "\C-xwh" 'highlight-regexp) |
| 277 | (define-key map "\C-xwr" 'unhighlight-regexp) |
| 278 | (define-key map "\C-xwb" 'hi-lock-write-interactive-patterns) |
| 279 | map) |
| 280 | "Key map for hi-lock.") |
| 281 | |
| 282 | ;; Visible Functions |
| 283 | |
| 284 | ;;;###autoload |
| 285 | (define-minor-mode hi-lock-mode |
| 286 | "Toggle selective highlighting of patterns (Hi Lock mode). |
| 287 | With a prefix argument ARG, enable Hi Lock mode if ARG is |
| 288 | positive, and disable it otherwise. If called from Lisp, enable |
| 289 | the mode if ARG is omitted or nil. |
| 290 | |
| 291 | Issuing one the highlighting commands listed below will |
| 292 | automatically enable Hi Lock mode. To enable Hi Lock mode in all |
| 293 | buffers, use `global-hi-lock-mode' or add (global-hi-lock-mode 1) |
| 294 | to your init file. When Hi Lock mode is enabled, a \"Regexp |
| 295 | Highlighting\" submenu is added to the \"Edit\" menu. The |
| 296 | commands in the submenu, which can be called interactively, are: |
| 297 | |
| 298 | \\[highlight-regexp] REGEXP FACE |
| 299 | Highlight matches of pattern REGEXP in current buffer with FACE. |
| 300 | |
| 301 | \\[highlight-phrase] PHRASE FACE |
| 302 | Highlight matches of phrase PHRASE in current buffer with FACE. |
| 303 | (PHRASE can be any REGEXP, but spaces will be replaced by matches |
| 304 | to whitespace and initial lower-case letters will become case insensitive.) |
| 305 | |
| 306 | \\[highlight-lines-matching-regexp] REGEXP FACE |
| 307 | Highlight lines containing matches of REGEXP in current buffer with FACE. |
| 308 | |
| 309 | \\[unhighlight-regexp] REGEXP |
| 310 | Remove highlighting on matches of REGEXP in current buffer. |
| 311 | |
| 312 | \\[hi-lock-write-interactive-patterns] |
| 313 | Write active REGEXPs into buffer as comments (if possible). They may |
| 314 | be read the next time file is loaded or when the \\[hi-lock-find-patterns] command |
| 315 | is issued. The inserted regexps are in the form of font lock keywords. |
| 316 | (See `font-lock-keywords'.) They may be edited and re-loaded with \\[hi-lock-find-patterns], |
| 317 | any valid `font-lock-keywords' form is acceptable. When a file is |
| 318 | loaded the patterns are read if `hi-lock-file-patterns-policy' is |
| 319 | 'ask and the user responds y to the prompt, or if |
| 320 | `hi-lock-file-patterns-policy' is bound to a function and that |
| 321 | function returns t. |
| 322 | |
| 323 | \\[hi-lock-find-patterns] |
| 324 | Re-read patterns stored in buffer (in the format produced by \\[hi-lock-write-interactive-patterns]). |
| 325 | |
| 326 | When hi-lock is started and if the mode is not excluded or patterns |
| 327 | rejected, the beginning of the buffer is searched for lines of the |
| 328 | form: |
| 329 | Hi-lock: FOO |
| 330 | where FOO is a list of patterns. These are added to the font lock |
| 331 | keywords already present. The patterns must start before position |
| 332 | \(number of characters into buffer) `hi-lock-file-patterns-range'. |
| 333 | Patterns will be read until |
| 334 | Hi-lock: end |
| 335 | is found. A mode is excluded if it's in the list `hi-lock-exclude-modes'." |
| 336 | :group 'hi-lock |
| 337 | :lighter (:eval (if (or hi-lock-interactive-patterns |
| 338 | hi-lock-file-patterns) |
| 339 | " Hi" "")) |
| 340 | :global nil |
| 341 | :keymap hi-lock-map |
| 342 | (when (and (equal (buffer-name) "*scratch*") |
| 343 | load-in-progress |
| 344 | (not (called-interactively-p 'interactive)) |
| 345 | (not hi-lock-archaic-interface-message-used)) |
| 346 | (setq hi-lock-archaic-interface-message-used t) |
| 347 | (if hi-lock-archaic-interface-deduce |
| 348 | (global-hi-lock-mode hi-lock-mode) |
| 349 | (warn |
| 350 | "Possible archaic use of (hi-lock-mode). |
| 351 | Use (global-hi-lock-mode 1) in .emacs to enable hi-lock for all buffers, |
| 352 | use (hi-lock-mode 1) for individual buffers. For compatibility with Emacs |
| 353 | versions before 22 use the following in your .emacs file: |
| 354 | |
| 355 | (if (functionp 'global-hi-lock-mode) |
| 356 | (global-hi-lock-mode 1) |
| 357 | (hi-lock-mode 1)) |
| 358 | "))) |
| 359 | (if hi-lock-mode |
| 360 | ;; Turned on. |
| 361 | (progn |
| 362 | (unless font-lock-mode (font-lock-mode 1)) |
| 363 | (define-key-after menu-bar-edit-menu [hi-lock] |
| 364 | (cons "Regexp Highlighting" hi-lock-menu)) |
| 365 | (hi-lock-find-patterns) |
| 366 | (add-hook 'font-lock-mode-hook 'hi-lock-font-lock-hook nil t)) |
| 367 | ;; Turned off. |
| 368 | (when (or hi-lock-interactive-patterns |
| 369 | hi-lock-file-patterns) |
| 370 | (when hi-lock-interactive-patterns |
| 371 | (font-lock-remove-keywords nil hi-lock-interactive-patterns) |
| 372 | (setq hi-lock-interactive-patterns nil)) |
| 373 | (when hi-lock-file-patterns |
| 374 | (font-lock-remove-keywords nil hi-lock-file-patterns) |
| 375 | (setq hi-lock-file-patterns nil)) |
| 376 | (remove-overlays nil nil 'hi-lock-overlay t) |
| 377 | (when font-lock-fontified (font-lock-fontify-buffer))) |
| 378 | (define-key-after menu-bar-edit-menu [hi-lock] nil) |
| 379 | (remove-hook 'font-lock-mode-hook 'hi-lock-font-lock-hook t))) |
| 380 | |
| 381 | ;;;###autoload |
| 382 | (define-globalized-minor-mode global-hi-lock-mode |
| 383 | hi-lock-mode turn-on-hi-lock-if-enabled |
| 384 | :group 'hi-lock) |
| 385 | |
| 386 | (defun turn-on-hi-lock-if-enabled () |
| 387 | (setq hi-lock-archaic-interface-message-used t) |
| 388 | (unless (memq major-mode hi-lock-exclude-modes) |
| 389 | (hi-lock-mode 1))) |
| 390 | |
| 391 | ;;;###autoload |
| 392 | (defalias 'highlight-lines-matching-regexp 'hi-lock-line-face-buffer) |
| 393 | ;;;###autoload |
| 394 | (defun hi-lock-line-face-buffer (regexp &optional face) |
| 395 | "Set face of all lines containing a match of REGEXP to FACE. |
| 396 | |
| 397 | Interactively, prompt for REGEXP then FACE. Buffer-local history |
| 398 | list maintained for regexps, global history maintained for faces. |
| 399 | \\<minibuffer-local-map>Use \\[previous-history-element] to retrieve previous history items, |
| 400 | and \\[next-history-element] to retrieve default values. |
| 401 | \(See info node `Minibuffer History'.)" |
| 402 | (interactive |
| 403 | (list |
| 404 | (hi-lock-regexp-okay |
| 405 | (read-regexp "Regexp to highlight line" (car regexp-history))) |
| 406 | (hi-lock-read-face-name))) |
| 407 | (or (facep face) (setq face 'hi-yellow)) |
| 408 | (unless hi-lock-mode (hi-lock-mode 1)) |
| 409 | (hi-lock-set-pattern |
| 410 | ;; The \\(?:...\\) grouping construct ensures that a leading ^, +, * or ? |
| 411 | ;; or a trailing $ in REGEXP will be interpreted correctly. |
| 412 | (concat "^.*\\(?:" regexp "\\).*$") face)) |
| 413 | |
| 414 | |
| 415 | ;;;###autoload |
| 416 | (defalias 'highlight-regexp 'hi-lock-face-buffer) |
| 417 | ;;;###autoload |
| 418 | (defun hi-lock-face-buffer (regexp &optional face) |
| 419 | "Set face of each match of REGEXP to FACE. |
| 420 | |
| 421 | Interactively, prompt for REGEXP then FACE. Buffer-local history |
| 422 | list maintained for regexps, global history maintained for faces. |
| 423 | \\<minibuffer-local-map>Use \\[previous-history-element] to retrieve previous history items, |
| 424 | and \\[next-history-element] to retrieve default values. |
| 425 | \(See info node `Minibuffer History'.)" |
| 426 | (interactive |
| 427 | (list |
| 428 | (hi-lock-regexp-okay |
| 429 | (read-regexp "Regexp to highlight" (car regexp-history))) |
| 430 | (hi-lock-read-face-name))) |
| 431 | (or (facep face) (setq face 'hi-yellow)) |
| 432 | (unless hi-lock-mode (hi-lock-mode 1)) |
| 433 | (hi-lock-set-pattern regexp face)) |
| 434 | |
| 435 | ;;;###autoload |
| 436 | (defalias 'highlight-phrase 'hi-lock-face-phrase-buffer) |
| 437 | ;;;###autoload |
| 438 | (defun hi-lock-face-phrase-buffer (regexp &optional face) |
| 439 | "Set face of each match of phrase REGEXP to FACE. |
| 440 | |
| 441 | Whitespace in REGEXP converted to arbitrary whitespace and initial |
| 442 | lower-case letters made case insensitive." |
| 443 | (interactive |
| 444 | (list |
| 445 | (hi-lock-regexp-okay |
| 446 | (hi-lock-process-phrase |
| 447 | (read-regexp "Phrase to highlight" (car regexp-history)))) |
| 448 | (hi-lock-read-face-name))) |
| 449 | (or (facep face) (setq face 'hi-yellow)) |
| 450 | (unless hi-lock-mode (hi-lock-mode 1)) |
| 451 | (hi-lock-set-pattern regexp face)) |
| 452 | |
| 453 | (declare-function x-popup-menu "menu.c" (position menu)) |
| 454 | |
| 455 | ;;;###autoload |
| 456 | (defalias 'unhighlight-regexp 'hi-lock-unface-buffer) |
| 457 | ;;;###autoload |
| 458 | (defun hi-lock-unface-buffer (regexp) |
| 459 | "Remove highlighting of each match to REGEXP set by hi-lock. |
| 460 | |
| 461 | Interactively, prompt for REGEXP. Buffer-local history of inserted |
| 462 | regexp's maintained. Will accept only regexps inserted by hi-lock |
| 463 | interactive functions. \(See `hi-lock-interactive-patterns'.\) |
| 464 | \\<minibuffer-local-must-match-map>Use \\[minibuffer-complete] to complete a partially typed regexp. |
| 465 | \(See info node `Minibuffer History'.\)" |
| 466 | (interactive |
| 467 | (if (and (display-popup-menus-p) |
| 468 | (listp last-nonmenu-event) |
| 469 | use-dialog-box) |
| 470 | (catch 'snafu |
| 471 | (or |
| 472 | (x-popup-menu |
| 473 | t |
| 474 | (cons |
| 475 | `keymap |
| 476 | (cons "Select Pattern to Unhighlight" |
| 477 | (mapcar (lambda (pattern) |
| 478 | (list (car pattern) |
| 479 | (format |
| 480 | "%s (%s)" (car pattern) |
| 481 | (symbol-name |
| 482 | (car |
| 483 | (cdr (car (cdr (car (cdr pattern)))))))) |
| 484 | (cons nil nil) |
| 485 | (car pattern))) |
| 486 | hi-lock-interactive-patterns)))) |
| 487 | ;; If the user clicks outside the menu, meaning that they |
| 488 | ;; change their mind, x-popup-menu returns nil, and |
| 489 | ;; interactive signals a wrong number of arguments error. |
| 490 | ;; To prevent that, we return an empty string, which will |
| 491 | ;; effectively disable the rest of the function. |
| 492 | (throw 'snafu '("")))) |
| 493 | (let ((history-list (mapcar (lambda (p) (car p)) |
| 494 | hi-lock-interactive-patterns))) |
| 495 | (unless hi-lock-interactive-patterns |
| 496 | (error "No highlighting to remove")) |
| 497 | (list |
| 498 | (completing-read "Regexp to unhighlight: " |
| 499 | hi-lock-interactive-patterns nil t |
| 500 | (car (car hi-lock-interactive-patterns)) |
| 501 | (cons 'history-list 1)))))) |
| 502 | (let ((keyword (assoc regexp hi-lock-interactive-patterns))) |
| 503 | (when keyword |
| 504 | (font-lock-remove-keywords nil (list keyword)) |
| 505 | (setq hi-lock-interactive-patterns |
| 506 | (delq keyword hi-lock-interactive-patterns)) |
| 507 | (remove-overlays |
| 508 | nil nil 'hi-lock-overlay-regexp (hi-lock-string-serialize regexp)) |
| 509 | (when font-lock-fontified (font-lock-fontify-buffer))))) |
| 510 | |
| 511 | ;;;###autoload |
| 512 | (defun hi-lock-write-interactive-patterns () |
| 513 | "Write interactively added patterns, if any, into buffer at point. |
| 514 | |
| 515 | Interactively added patterns are those normally specified using |
| 516 | `highlight-regexp' and `highlight-lines-matching-regexp'; they can |
| 517 | be found in variable `hi-lock-interactive-patterns'." |
| 518 | (interactive) |
| 519 | (if (null hi-lock-interactive-patterns) |
| 520 | (error "There are no interactive patterns")) |
| 521 | (let ((beg (point))) |
| 522 | (mapc |
| 523 | (lambda (pattern) |
| 524 | (insert (format "%s: (%s)\n" |
| 525 | hi-lock-file-patterns-prefix |
| 526 | (prin1-to-string pattern)))) |
| 527 | hi-lock-interactive-patterns) |
| 528 | (comment-region beg (point))) |
| 529 | (when (> (point) hi-lock-file-patterns-range) |
| 530 | (warn "Inserted keywords not close enough to top of file"))) |
| 531 | |
| 532 | ;; Implementation Functions |
| 533 | |
| 534 | (defun hi-lock-process-phrase (phrase) |
| 535 | "Convert regexp PHRASE to a regexp that matches phrases. |
| 536 | |
| 537 | Blanks in PHRASE replaced by regexp that matches arbitrary whitespace |
| 538 | and initial lower-case letters made case insensitive." |
| 539 | (let ((mod-phrase nil)) |
| 540 | (setq mod-phrase |
| 541 | (replace-regexp-in-string |
| 542 | "\\<[a-z]" (lambda (m) (format "[%s%s]" (upcase m) m)) phrase)) |
| 543 | (setq mod-phrase |
| 544 | (replace-regexp-in-string |
| 545 | "\\s-+" "[ \t\n]+" mod-phrase nil t)))) |
| 546 | |
| 547 | (defun hi-lock-regexp-okay (regexp) |
| 548 | "Return REGEXP if it appears suitable for a font-lock pattern. |
| 549 | |
| 550 | Otherwise signal an error. A pattern that matches the null string is |
| 551 | not suitable." |
| 552 | (if (string-match regexp "") |
| 553 | (error "Regexp cannot match an empty string") |
| 554 | regexp)) |
| 555 | |
| 556 | (defun hi-lock-read-face-name () |
| 557 | "Read face name from minibuffer with completion and history." |
| 558 | (intern (completing-read |
| 559 | "Highlight using face: " |
| 560 | obarray 'facep t |
| 561 | (cons (car hi-lock-face-defaults) |
| 562 | (let ((prefix |
| 563 | (try-completion |
| 564 | (substring (car hi-lock-face-defaults) 0 1) |
| 565 | hi-lock-face-defaults))) |
| 566 | (if (and (stringp prefix) |
| 567 | (not (equal prefix (car hi-lock-face-defaults)))) |
| 568 | (length prefix) 0))) |
| 569 | 'face-name-history |
| 570 | (cdr hi-lock-face-defaults)))) |
| 571 | |
| 572 | (defun hi-lock-set-pattern (regexp face) |
| 573 | "Highlight REGEXP with face FACE." |
| 574 | (let ((pattern (list regexp (list 0 (list 'quote face) t)))) |
| 575 | (unless (member pattern hi-lock-interactive-patterns) |
| 576 | (push pattern hi-lock-interactive-patterns) |
| 577 | (if font-lock-fontified |
| 578 | (progn |
| 579 | (font-lock-add-keywords nil (list pattern) t) |
| 580 | (font-lock-fontify-buffer)) |
| 581 | (let* ((serial (hi-lock-string-serialize regexp)) |
| 582 | (range-min (- (point) (/ hi-lock-highlight-range 2))) |
| 583 | (range-max (+ (point) (/ hi-lock-highlight-range 2))) |
| 584 | (search-start |
| 585 | (max (point-min) |
| 586 | (- range-min (max 0 (- range-max (point-max)))))) |
| 587 | (search-end |
| 588 | (min (point-max) |
| 589 | (+ range-max (max 0 (- (point-min) range-min)))))) |
| 590 | (save-excursion |
| 591 | (goto-char search-start) |
| 592 | (while (re-search-forward regexp search-end t) |
| 593 | (let ((overlay (make-overlay (match-beginning 0) (match-end 0)))) |
| 594 | (overlay-put overlay 'hi-lock-overlay t) |
| 595 | (overlay-put overlay 'hi-lock-overlay-regexp serial) |
| 596 | (overlay-put overlay 'face face)) |
| 597 | (goto-char (match-end 0))))))))) |
| 598 | |
| 599 | (defun hi-lock-set-file-patterns (patterns) |
| 600 | "Replace file patterns list with PATTERNS and refontify." |
| 601 | (when (or hi-lock-file-patterns patterns) |
| 602 | (font-lock-remove-keywords nil hi-lock-file-patterns) |
| 603 | (setq hi-lock-file-patterns patterns) |
| 604 | (font-lock-add-keywords nil hi-lock-file-patterns t) |
| 605 | (font-lock-fontify-buffer))) |
| 606 | |
| 607 | (defun hi-lock-find-patterns () |
| 608 | "Find patterns in current buffer for hi-lock." |
| 609 | (interactive) |
| 610 | (unless (memq major-mode hi-lock-exclude-modes) |
| 611 | (let ((all-patterns nil) |
| 612 | (target-regexp (concat "\\<" hi-lock-file-patterns-prefix ":"))) |
| 613 | (save-excursion |
| 614 | (save-restriction |
| 615 | (widen) |
| 616 | (goto-char (point-min)) |
| 617 | (re-search-forward target-regexp |
| 618 | (+ (point) hi-lock-file-patterns-range) t) |
| 619 | (beginning-of-line) |
| 620 | (while (and (re-search-forward target-regexp (+ (point) 100) t) |
| 621 | (not (looking-at "\\s-*end"))) |
| 622 | (condition-case nil |
| 623 | (setq all-patterns (append (read (current-buffer)) all-patterns)) |
| 624 | (error (message "Invalid pattern list expression at %d" |
| 625 | (line-number-at-pos))))))) |
| 626 | (when (and all-patterns |
| 627 | hi-lock-mode |
| 628 | (cond |
| 629 | ((eq this-command 'hi-lock-find-patterns) t) |
| 630 | ((functionp hi-lock-file-patterns-policy) |
| 631 | (funcall hi-lock-file-patterns-policy all-patterns)) |
| 632 | ((eq hi-lock-file-patterns-policy 'ask) |
| 633 | (y-or-n-p "Add patterns from this buffer to hi-lock? ")) |
| 634 | (t nil))) |
| 635 | (hi-lock-set-file-patterns all-patterns) |
| 636 | (if (called-interactively-p 'interactive) |
| 637 | (message "Hi-lock added %d patterns." (length all-patterns))))))) |
| 638 | |
| 639 | (defun hi-lock-font-lock-hook () |
| 640 | "Add hi-lock patterns to font-lock's." |
| 641 | (when font-lock-fontified |
| 642 | (font-lock-add-keywords nil hi-lock-file-patterns t) |
| 643 | (font-lock-add-keywords nil hi-lock-interactive-patterns t))) |
| 644 | |
| 645 | (defvar hi-lock-string-serialize-hash |
| 646 | (make-hash-table :test 'equal) |
| 647 | "Hash table used to assign unique numbers to strings.") |
| 648 | |
| 649 | (defvar hi-lock-string-serialize-serial 1 |
| 650 | "Number assigned to last new string in call to `hi-lock-string-serialize'. |
| 651 | A string is considered new if it had not previously been used in a call to |
| 652 | `hi-lock-string-serialize'.") |
| 653 | |
| 654 | (defun hi-lock-string-serialize (string) |
| 655 | "Return unique serial number for STRING." |
| 656 | (interactive) |
| 657 | (let ((val (gethash string hi-lock-string-serialize-hash))) |
| 658 | (if val val |
| 659 | (puthash string |
| 660 | (setq hi-lock-string-serialize-serial |
| 661 | (1+ hi-lock-string-serialize-serial)) |
| 662 | hi-lock-string-serialize-hash) |
| 663 | hi-lock-string-serialize-serial))) |
| 664 | |
| 665 | (defun hi-lock-unload-function () |
| 666 | "Unload the Hi-Lock library." |
| 667 | (global-hi-lock-mode -1) |
| 668 | ;; continue standard unloading |
| 669 | nil) |
| 670 | |
| 671 | (provide 'hi-lock) |
| 672 | |
| 673 | ;;; hi-lock.el ends here |