Merge from emacs-24; up to 2012-04-22T13:58:00Z!cyd@gnu.org

[bpt/emacs.git] / lisp / hi-lock.el

diff --git a/lisp/hi-lock.el b/lisp/hi-lock.el
index 62f9240..32a041e 100644 (file)
--- a/lisp/hi-lock.el
+++ b/lisp/hi-lock.el
@@ -1,17 +1,16 @@
 ;;; hi-lock.el --- minor mode for interactive automatic highlighting
 
 ;;; hi-lock.el --- minor mode for interactive automatic highlighting
 

-;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
-;;   2005, 2006, 2007 Free Software Foundation, Inc.
+;; Copyright (C) 2000-2012 Free Software Foundation, Inc.

 
 

-;; Author: David M. Koppelman, koppel@ece.lsu.edu
+;; Author: David M. Koppelman <koppel@ece.lsu.edu>

 ;; Keywords: faces, minor-mode, matching, display
 
 ;; This file is part of GNU Emacs.
 
 ;; Keywords: faces, minor-mode, matching, display
 
 ;; This file is part of GNU Emacs.
 

-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify

 ;; it under the terms of the GNU General Public License as published by
 ;; it under the terms of the GNU General Public License as published by

-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.

 
 ;; GNU Emacs is distributed in the hope that it will be useful,
 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 
 ;; GNU Emacs is distributed in the hope that it will be useful,
 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of


@@ -19,9 +18,7 @@
 ;; GNU General Public License for more details.
 
 ;; You should have received a copy of the GNU General Public License
 ;; GNU General Public License for more details.
 
 ;; 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., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

 
 ;;; Commentary:
 ;;
 
 ;;; Commentary:
 ;;


@@ -90,8 +87,7 @@
 
 ;;; Code:
 
 
 ;;; Code:
 

-(eval-and-compile
-  (require 'font-lock))
+(require 'font-lock)

 
 (defgroup hi-lock nil
   "Interactively add and remove font-lock patterns for highlighting text."
 
 (defgroup hi-lock nil
   "Interactively add and remove font-lock patterns for highlighting text."


@@ -208,15 +204,20 @@ patterns."
 (defvar hi-lock-interactive-patterns nil
   "Patterns provided to hi-lock by user.  Should not be changed.")
 
 (defvar hi-lock-interactive-patterns nil
   "Patterns provided to hi-lock by user.  Should not be changed.")
 

-(defvar hi-lock-face-history
-  (list "hi-yellow" "hi-pink" "hi-green" "hi-blue" "hi-black-b"
-        "hi-blue-b" "hi-red-b" "hi-green-b" "hi-black-hb")
-      "History list of faces for hi-lock interactive functions.")
+(defvar hi-lock-face-defaults
+  '("hi-yellow" "hi-pink" "hi-green" "hi-blue" "hi-black-b"
+    "hi-blue-b" "hi-red-b" "hi-green-b" "hi-black-hb")
+  "Default faces for hi-lock interactive functions.")

 
 

-;(dolist (f hi-lock-face-history) (unless (facep f) (error "%s not a face" f)))
+;(dolist (f hi-lock-face-defaults) (unless (facep f) (error "%s not a face" f)))

 
 

-(defvar hi-lock-regexp-history nil
-  "History of regexps used for interactive fontification.")
+(define-obsolete-variable-alias 'hi-lock-face-history
+                                'hi-lock-face-defaults
+                                "23.1")
+
+(define-obsolete-variable-alias 'hi-lock-regexp-history
+                                'regexp-history
+                                "23.1")

 
 (defvar hi-lock-file-patterns-prefix "Hi-lock"
   "Search target for finding hi-lock patterns at top of file.")
 
 (defvar hi-lock-file-patterns-prefix "Hi-lock"
   "Search target for finding hi-lock patterns at top of file.")


@@ -234,62 +235,65 @@ a library is being loaded.")
 
 (make-variable-buffer-local 'hi-lock-interactive-patterns)
 (put 'hi-lock-interactive-patterns 'permanent-local t)
 
 (make-variable-buffer-local 'hi-lock-interactive-patterns)
 (put 'hi-lock-interactive-patterns 'permanent-local t)

-(make-variable-buffer-local 'hi-lock-regexp-history)
-(put 'hi-lock-regexp-history 'permanent-local t)

 (make-variable-buffer-local 'hi-lock-file-patterns)
 (put 'hi-lock-file-patterns 'permanent-local t)
 
 (make-variable-buffer-local 'hi-lock-file-patterns)
 (put 'hi-lock-file-patterns 'permanent-local t)
 

-(defvar hi-lock-menu (make-sparse-keymap "Hi Lock")
+(defvar hi-lock-menu
+  (let ((map (make-sparse-keymap "Hi Lock")))
+    (define-key-after map [highlight-regexp]
+      '(menu-item "Highlight Regexp..." highlight-regexp
+        :help "Highlight text matching PATTERN (a regexp)."))
+
+    (define-key-after map [highlight-phrase]
+      '(menu-item "Highlight Phrase..." highlight-phrase
+        :help "Highlight text matching PATTERN (a regexp processed to match phrases)."))
+
+    (define-key-after map [highlight-lines-matching-regexp]
+      '(menu-item "Highlight Lines..." highlight-lines-matching-regexp
+        :help "Highlight lines containing match of PATTERN (a regexp)."))
+
+    (define-key-after map [unhighlight-regexp]
+      '(menu-item "Remove Highlighting..." unhighlight-regexp
+        :help "Remove previously entered highlighting pattern."
+        :enable hi-lock-interactive-patterns))
+
+    (define-key-after map [hi-lock-write-interactive-patterns]
+      '(menu-item "Patterns to Buffer" hi-lock-write-interactive-patterns
+        :help "Insert interactively added REGEXPs into buffer at point."
+        :enable hi-lock-interactive-patterns))
+
+    (define-key-after map [hi-lock-find-patterns]
+      '(menu-item "Patterns from Buffer" hi-lock-find-patterns
+        :help "Use patterns (if any) near top of buffer."))
+    map)

   "Menu for hi-lock mode.")
 
   "Menu for hi-lock mode.")
 

-(define-key-after hi-lock-menu [highlight-regexp]
-  '(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).."))
-
-(define-key-after hi-lock-menu [unhighlight-regexp]
-  '(menu-item "Remove Highlighting..." unhighlight-regexp
-              :help "Remove previously entered highlighting pattern."
-              :enable hi-lock-interactive-patterns))
-
-(define-key-after hi-lock-menu [hi-lock-write-interactive-patterns]
-  '(menu-item "Patterns to Buffer" hi-lock-write-interactive-patterns
-              :help "Insert interactively added REGEXPs into buffer at point."
-              :enable hi-lock-interactive-patterns))
-
-(define-key-after hi-lock-menu [hi-lock-find-patterns]
-  '(menu-item "Patterns from Buffer" hi-lock-find-patterns
-              :help "Use patterns (if any) near top of buffer."))
-
-(defvar hi-lock-map (make-sparse-keymap "Hi Lock")
+(defvar hi-lock-map
+  (let ((map (make-sparse-keymap "Hi Lock")))
+    (define-key map "\C-xwi" 'hi-lock-find-patterns)
+    (define-key map "\C-xwl" 'highlight-lines-matching-regexp)
+    (define-key map "\C-xwp" 'highlight-phrase)
+    (define-key map "\C-xwh" 'highlight-regexp)
+    (define-key map "\C-xwr" 'unhighlight-regexp)
+    (define-key map "\C-xwb" 'hi-lock-write-interactive-patterns)
+    map)

   "Key map for hi-lock.")
 
   "Key map for hi-lock.")
 

-(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)
-

 ;; Visible Functions
 
 ;;;###autoload
 (define-minor-mode hi-lock-mode
 ;; Visible Functions
 
 ;;;###autoload
 (define-minor-mode hi-lock-mode

-  "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.  To turn hi-lock on in all buffers use
-`global-hi-lock-mode' or in your .emacs file (global-hi-lock-mode 1).
-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:
+  "Toggle selective highlighting of patterns (Hi Lock mode).
+With a prefix argument ARG, enable Hi Lock mode if ARG is
+positive, and disable it otherwise.  If called from Lisp, enable
+the mode if ARG is omitted or nil.
+
+Issuing one the highlighting commands listed below will
+automatically enable Hi Lock mode.  To enable Hi Lock mode in all
+buffers, use `global-hi-lock-mode' or add (global-hi-lock-mode 1)
+to your init file.  When Hi Lock mode is enabled, 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-regexp] REGEXP FACE
   Highlight matches of pattern REGEXP in current buffer with FACE.


@@ -309,9 +313,9 @@ called interactively, are:
   Write active REGEXPs into buffer as comments (if possible).  They may
   be read the next time file is loaded or when the \\[hi-lock-find-patterns] command
   is issued.  The inserted regexps are in the form of font lock keywords.
   Write active REGEXPs into buffer as comments (if possible).  They may
   be read the next time file is loaded or when the \\[hi-lock-find-patterns] command
   is issued.  The inserted regexps are in the form of font lock keywords.

-  (See `font-lock-keywords'.)  They may be edited and re-loaded with \\[hi-lock-find-patterns], 
-  any valid `font-lock-keywords' form is acceptable. When a file is
-  loaded the patterns are read if `hi-lock-file-patterns-policy is
+  (See `font-lock-keywords'.)  They may be edited and re-loaded with \\[hi-lock-find-patterns],
+  any valid `font-lock-keywords' form is acceptable.  When a file is
+  loaded the patterns are read if `hi-lock-file-patterns-policy' is

   'ask and the user responds y to the prompt, or if
   `hi-lock-file-patterns-policy' is bound to a function and that
   function returns t.
   'ask and the user responds y to the prompt, or if
   `hi-lock-file-patterns-policy' is bound to a function and that
   function returns t.


@@ -337,7 +341,7 @@ is found.  A mode is excluded if it's in the list `hi-lock-exclude-modes'."
   :keymap hi-lock-map
   (when (and (equal (buffer-name) "*scratch*")
              load-in-progress
   :keymap hi-lock-map
   (when (and (equal (buffer-name) "*scratch*")
              load-in-progress

-             (not (interactive-p))
+             (not (called-interactively-p 'interactive))

              (not hi-lock-archaic-interface-message-used))
     (setq hi-lock-archaic-interface-message-used t)
     (if hi-lock-archaic-interface-deduce
              (not hi-lock-archaic-interface-message-used))
     (setq hi-lock-archaic-interface-message-used t)
     (if hi-lock-archaic-interface-deduce


@@ -392,14 +396,13 @@ versions before 22 use the following in your .emacs file:
 
 Interactively, prompt for REGEXP then FACE.  Buffer-local history
 list maintained for regexps, global history maintained for faces.
 
 Interactively, prompt for REGEXP then FACE.  Buffer-local history
 list maintained for regexps, global history maintained for faces.

-\\<minibuffer-local-map>Use \\[next-history-element] and \\[previous-history-element] to retrieve next or previous history item.
+\\<minibuffer-local-map>Use \\[previous-history-element] to retrieve previous history items,
+and \\[next-history-element] to retrieve default values.

 \(See info node `Minibuffer History'.)"
   (interactive
    (list
     (hi-lock-regexp-okay
 \(See info node `Minibuffer History'.)"
   (interactive
    (list
     (hi-lock-regexp-okay

-     (read-from-minibuffer "Regexp to highlight line: "
-                           (cons (or (car hi-lock-regexp-history) "") 1 )
-                           nil nil 'hi-lock-regexp-history))
+     (read-regexp "Regexp to highlight line" (car regexp-history)))

     (hi-lock-read-face-name)))
   (or (facep face) (setq face 'hi-yellow))
   (unless hi-lock-mode (hi-lock-mode 1))
     (hi-lock-read-face-name)))
   (or (facep face) (setq face 'hi-yellow))
   (unless hi-lock-mode (hi-lock-mode 1))


@@ -417,14 +420,13 @@ list maintained for regexps, global history maintained for faces.
 
 Interactively, prompt for REGEXP then FACE.  Buffer-local history
 list maintained for regexps, global history maintained for faces.
 
 Interactively, prompt for REGEXP then FACE.  Buffer-local history
 list maintained for regexps, global history maintained for faces.

-\\<minibuffer-local-map>Use \\[next-history-element] and \\[previous-history-element] to retrieve next or previous history item.
+\\<minibuffer-local-map>Use \\[previous-history-element] to retrieve previous history items,
+and \\[next-history-element] to retrieve default values.

 \(See info node `Minibuffer History'.)"
   (interactive
    (list
     (hi-lock-regexp-okay
 \(See info node `Minibuffer History'.)"
   (interactive
    (list
     (hi-lock-regexp-okay

-     (read-from-minibuffer "Regexp to highlight: "
-                           (cons (or (car hi-lock-regexp-history) "") 1 )
-                           nil nil 'hi-lock-regexp-history))
+     (read-regexp "Regexp to highlight" (car regexp-history)))

     (hi-lock-read-face-name)))
   (or (facep face) (setq face 'hi-yellow))
   (unless hi-lock-mode (hi-lock-mode 1))
     (hi-lock-read-face-name)))
   (or (facep face) (setq face 'hi-yellow))
   (unless hi-lock-mode (hi-lock-mode 1))


@@ -442,14 +444,14 @@ lower-case letters made case insensitive."
    (list
     (hi-lock-regexp-okay
      (hi-lock-process-phrase
    (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)))
+      (read-regexp "Phrase to highlight" (car regexp-history))))

     (hi-lock-read-face-name)))
   (or (facep face) (setq face 'hi-yellow))
   (unless hi-lock-mode (hi-lock-mode 1))
   (hi-lock-set-pattern regexp face))
 
     (hi-lock-read-face-name)))
   (or (facep face) (setq face 'hi-yellow))
   (unless hi-lock-mode (hi-lock-mode 1))
   (hi-lock-set-pattern regexp face))
 

+(declare-function x-popup-menu "menu.c" (position menu))
+

 ;;;###autoload
 (defalias 'unhighlight-regexp 'hi-lock-unface-buffer)
 ;;;###autoload
 ;;;###autoload
 (defalias 'unhighlight-regexp 'hi-lock-unface-buffer)
 ;;;###autoload


@@ -462,7 +464,9 @@ interactive functions.  \(See `hi-lock-interactive-patterns'.\)
 \\<minibuffer-local-must-match-map>Use \\[minibuffer-complete] to complete a partially typed regexp.
 \(See info node `Minibuffer History'.\)"
   (interactive
 \\<minibuffer-local-must-match-map>Use \\[minibuffer-complete] to complete a partially typed regexp.
 \(See info node `Minibuffer History'.\)"
   (interactive

-   (if (and (display-popup-menus-p) (vectorp (this-command-keys)))
+   (if (and (display-popup-menus-p)
+           (listp last-nonmenu-event)
+           use-dialog-box)

        (catch 'snafu
         (or
          (x-popup-menu
        (catch 'snafu
         (or
          (x-popup-menu


@@ -515,7 +519,7 @@ be found in variable `hi-lock-interactive-patterns'."
   (if (null hi-lock-interactive-patterns)
       (error "There are no interactive patterns"))
   (let ((beg (point)))
   (if (null hi-lock-interactive-patterns)
       (error "There are no interactive patterns"))
   (let ((beg (point)))

-    (mapcar
+    (mapc

      (lambda (pattern)
        (insert (format "%s: (%s)\n"
                       hi-lock-file-patterns-prefix
      (lambda (pattern)
        (insert (format "%s: (%s)\n"
                       hi-lock-file-patterns-prefix


@@ -554,25 +558,26 @@ not suitable."
   (intern (completing-read
            "Highlight using face: "
            obarray 'facep t
   (intern (completing-read
            "Highlight using face: "
            obarray 'facep t

-           (cons (car hi-lock-face-history)
+           (cons (car hi-lock-face-defaults)

                  (let ((prefix
                         (try-completion
                  (let ((prefix
                         (try-completion

-                         (substring (car hi-lock-face-history) 0 1)
-                         (mapcar (lambda (f) (cons f f))
-                                 hi-lock-face-history))))
+                         (substring (car hi-lock-face-defaults) 0 1)
+                         hi-lock-face-defaults)))

                    (if (and (stringp prefix)
                    (if (and (stringp prefix)

-                            (not (equal prefix (car hi-lock-face-history))))
+                            (not (equal prefix (car hi-lock-face-defaults))))

                        (length prefix) 0)))
                        (length prefix) 0)))

-           '(hi-lock-face-history . 0))))
+           'face-name-history
+          (cdr hi-lock-face-defaults))))

 
 (defun hi-lock-set-pattern (regexp face)
   "Highlight REGEXP with face FACE."
   (let ((pattern (list regexp (list 0 (list 'quote face) t))))
     (unless (member pattern hi-lock-interactive-patterns)
 
 (defun hi-lock-set-pattern (regexp face)
   "Highlight REGEXP with face FACE."
   (let ((pattern (list regexp (list 0 (list 'quote face) t))))
     (unless (member pattern hi-lock-interactive-patterns)

-      (font-lock-add-keywords nil (list pattern) t)

       (push pattern hi-lock-interactive-patterns)
       (if font-lock-fontified
       (push pattern hi-lock-interactive-patterns)
       (if font-lock-fontified

-          (font-lock-fontify-buffer)
+         (progn
+           (font-lock-add-keywords nil (list pattern) t)
+           (font-lock-fontify-buffer))

         (let* ((serial (hi-lock-string-serialize regexp))
                (range-min (- (point) (/ hi-lock-highlight-range 2)))
                (range-max (+ (point) (/ hi-lock-highlight-range 2)))
         (let* ((serial (hi-lock-string-serialize regexp))
                (range-min (- (point) (/ hi-lock-highlight-range 2)))
                (range-max (+ (point) (/ hi-lock-highlight-range 2)))


@@ -628,16 +633,14 @@ not suitable."
                    (y-or-n-p "Add patterns from this buffer to hi-lock? "))
                   (t nil)))
         (hi-lock-set-file-patterns all-patterns)
                    (y-or-n-p "Add patterns from this buffer to hi-lock? "))
                   (t nil)))
         (hi-lock-set-file-patterns all-patterns)

-        (if (interactive-p)
+        (if (called-interactively-p 'interactive)

             (message "Hi-lock added %d patterns." (length all-patterns)))))))
 
 (defun hi-lock-font-lock-hook ()
   "Add hi-lock patterns to font-lock's."
             (message "Hi-lock added %d patterns." (length all-patterns)))))))
 
 (defun hi-lock-font-lock-hook ()
   "Add hi-lock patterns to font-lock's."

-  (if font-lock-mode
-      (progn
-       (font-lock-add-keywords nil hi-lock-file-patterns t)
-       (font-lock-add-keywords nil hi-lock-interactive-patterns t))
-    (hi-lock-mode -1)))
+  (when font-lock-fontified
+    (font-lock-add-keywords nil hi-lock-file-patterns t)
+    (font-lock-add-keywords nil hi-lock-interactive-patterns t)))

 
 (defvar hi-lock-string-serialize-hash
   (make-hash-table :test 'equal)
 
 (defvar hi-lock-string-serialize-hash
   (make-hash-table :test 'equal)


@@ -659,7 +662,12 @@ A string is considered new if it had not previously been used in a call to
                hi-lock-string-serialize-hash)
       hi-lock-string-serialize-serial)))
 
                hi-lock-string-serialize-hash)
       hi-lock-string-serialize-serial)))
 

+(defun hi-lock-unload-function ()
+  "Unload the Hi-Lock library."
+  (global-hi-lock-mode -1)
+  ;; continue standard unloading
+  nil)
+

 (provide 'hi-lock)
 
 (provide 'hi-lock)
 

-;; arch-tag: d2e8fd07-4cc9-4c6f-a200-1e729bc54066

 ;;; hi-lock.el ends here
 ;;; hi-lock.el ends here