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