(show_help_echo): New function, extracted from read_char.

[gnu-emacs] / lisp / apropos.el

diff --git a/lisp/apropos.el b/lisp/apropos.el
index 04b0223e28d8efea359dc081d97fc1061a2ccaf6..c184a689bf644e99711226f097917f637a33491b 100644 (file)
--- a/lisp/apropos.el
+++ b/lisp/apropos.el
@@ -3,7 +3,7 @@
 ;; Copyright (C) 1989, 1994, 1995 Free Software Foundation, Inc.
 
 ;; Author: Joe Wells <jbw@bigbird.bu.edu>
 ;; Copyright (C) 1989, 1994, 1995 Free Software Foundation, Inc.
 
 ;; Author: Joe Wells <jbw@bigbird.bu.edu>

-;; Rewritten: Daniel.Pfeiffer@Informatik.START.dbp.de, fax (+49 69) 7588-2389
+;; Rewritten: Daniel Pfeiffer <occitan@esperanto.org>

 ;; Keywords: help
 
 ;; This file is part of GNU Emacs.
 ;; Keywords: help
 
 ;; This file is part of GNU Emacs.


@@ -19,8 +19,9 @@
 ;; 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+;; 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.

 
 ;;; Commentary:
 
 
 ;;; Commentary:
 


@@ -56,44 +57,63 @@
 
 ;;; Code:
 
 
 ;;; Code:
 

+(defgroup apropos nil
+  "Apropos commands for users and programmers"
+  :group 'help
+  :prefix "apropos")
+

 ;; I see a degradation of maybe 10-20% only.
 ;; I see a degradation of maybe 10-20% only.

-(defvar apropos-do-all nil
+(defcustom apropos-do-all nil

   "*Whether the apropos commands should do more.
   "*Whether the apropos commands should do more.

-Slows them down more or less.  Set this non-nil if you have a fast machine.")
+
+Slows them down more or less.  Set this non-nil if you have a fast machine."
+  :group 'apropos
+  :type 'boolean)

 
 
 
 

-(defvar apropos-symbol-face (if window-system 'bold)
-  "*Face for symbol name in apropos output or `nil'.  
-This looks good, but slows down the commands several times.")
+(defcustom apropos-symbol-face 'bold
+  "*Face for symbol name in Apropos output, or nil for none."
+  :group 'apropos
+  :type 'face)

 
 

-(defvar apropos-keybinding-face (if window-system 'underline)
-  "*Face for keybinding display in apropos output or `nil'.  
-This looks good, but slows down the commands several times.")
+(defcustom apropos-keybinding-face 'underline
+  "*Face for lists of keybinding in Apropos output, or nil for none."
+  :group 'apropos
+  :type 'face)

 
 

-(defvar apropos-label-face (if window-system 'italic)
-  "*Face for label (Command, Variable ...) in apropos output or `nil'.
-If this is `nil' no mouse highlighting occurs.
-This looks good, but slows down the commands several times.
-When this is a face name, as it is initially, it gets transformed to a
-text-property list for efficiency.")
+(defcustom apropos-label-face 'italic
+  "*Face for label (`Command', `Variable' ...) in Apropos output.
+A value of nil means don't use any special font for them, and also
+turns off mouse highlighting."
+  :group 'apropos
+  :type 'face)

 
 

-(defvar apropos-property-face (if window-system 'bold-italic)
-  "*Face for property name in apropos output or `nil'.  
-This looks good, but slows down the commands several times.")
+(defcustom apropos-property-face 'bold-italic
+  "*Face for property name in apropos output, or nil for none."
+  :group 'apropos
+  :type 'face)

 
 

-(defvar apropos-match-face (if window-system 'secondary-selection)
-  "*Face for matching part in apropos-documentation/value output or `nil'.  
-This looks good, but slows down the commands several times.")
+(defcustom apropos-match-face 'secondary-selection
+  "*Face for matching text in Apropos documentation/value, or nil for none.
+This applies when you look for matches in the documentation or variable value
+for the regexp; the part that matches gets displayed in this font."
+  :group 'apropos
+  :type 'face)

 
 
 (defvar apropos-mode-map
   (let ((map (make-sparse-keymap)))
     (define-key map "\C-m" 'apropos-follow)
 
 
 (defvar apropos-mode-map
   (let ((map (make-sparse-keymap)))
     (define-key map "\C-m" 'apropos-follow)

+    (define-key map " "    'scroll-up)
+    (define-key map "\177" 'scroll-down)
+    (define-key map "q"    'quit-window)

     (define-key map [mouse-2] 'apropos-mouse-follow)
     (define-key map [down-mouse-2] nil)
     map)
   "Keymap used in Apropos mode.")
 
     (define-key map [mouse-2] 'apropos-mouse-follow)
     (define-key map [down-mouse-2] nil)
     map)
   "Keymap used in Apropos mode.")
 

+(defvar apropos-mode-hook nil
+  "*Hook run when mode is turned on.")

 
 (defvar apropos-regexp nil
   "Regexp used in current apropos run.")
 
 (defvar apropos-regexp nil
   "Regexp used in current apropos run.")


@@ -105,8 +125,9 @@ This looks good, but slows down the commands several times.")
   "Alist of symbols already found in current apropos run.")
 
 (defvar apropos-item ()
   "Alist of symbols already found in current apropos run.")
 
 (defvar apropos-item ()

-  "Current item in or for apropos-accumulator.")
+  "Current item in or for `apropos-accumulator'.")

 \f
 \f

+;;;###autoload

 (defun apropos-mode ()
   "Major mode for following hyperlinks in output of apropos commands.
 
 (defun apropos-mode ()
   "Major mode for following hyperlinks in output of apropos commands.
 


@@ -115,22 +136,45 @@ This looks good, but slows down the commands several times.")
   (kill-all-local-variables)
   (use-local-map apropos-mode-map)
   (setq major-mode 'apropos-mode
   (kill-all-local-variables)
   (use-local-map apropos-mode-map)
   (setq major-mode 'apropos-mode

-       mode-name "Apropos"))
+       mode-name "Apropos")
+  (run-hooks 'apropos-mode-hook))

 
 

+;;;###autoload
+(defun apropos-variable (regexp &optional do-all)
+  "Show user variables that match REGEXP.
+With optional prefix DO-ALL or if `apropos-do-all' is non-nil, also show
+normal variables."
+  (interactive (list (read-string
+                      (concat "Apropos "
+                              (if (or current-prefix-arg apropos-do-all)
+                                 "variable"
+                               "user option")
+                              " (regexp): "))
+                     current-prefix-arg))
+  (apropos-command regexp nil
+                  (if (or do-all apropos-do-all)
+                      #'(lambda (symbol)
+                          (and (boundp symbol)
+                               (get symbol 'variable-documentation)))
+                    'user-variable-p)))

 
 ;; For auld lang syne:
 ;;;###autoload
 (fset 'command-apropos 'apropos-command)
 ;;;###autoload
 
 ;; For auld lang syne:
 ;;;###autoload
 (fset 'command-apropos 'apropos-command)
 ;;;###autoload

-(defun apropos-command (apropos-regexp &optional do-all)
-  "Shows commands (interactively callable functions) that match REGEXP.
-With optional prefix ARG or if `apropos-do-all' is non-nil, also show
-variables."
-  (interactive (list (read-string (concat "Apropos command "
-                                         (if (or current-prefix-arg
-                                                 apropos-do-all)
-                                             "or variable ")
-                                         "(regexp): "))
+(defun apropos-command (apropos-regexp &optional do-all var-predicate)
+  "Show commands (interactively callable functions) that match APROPOS-REGEXP.
+With optional prefix DO-ALL, or if `apropos-do-all' is non-nil, also show
+noninteractive functions.
+
+If VAR-PREDICATE is non-nil, show only variables, and only those that
+satisfy the predicate VAR-PREDICATE."
+  (interactive (list (read-string (concat
+                                  "Apropos command "
+                                  (if (or current-prefix-arg
+                                          apropos-do-all)
+                                      "or function ")
+                                  "(regexp): "))

                     current-prefix-arg))
   (let ((message
         (let ((standard-output (get-buffer-create "*Apropos*")))
                     current-prefix-arg))
   (let ((message
         (let ((standard-output (get-buffer-create "*Apropos*")))


@@ -138,38 +182,41 @@ variables."
     (or do-all (setq do-all apropos-do-all))
     (setq apropos-accumulator
          (apropos-internal apropos-regexp
     (or do-all (setq do-all apropos-do-all))
     (setq apropos-accumulator
          (apropos-internal apropos-regexp

-                           (if do-all
-                               (lambda (symbol) (or (commandp symbol)
-                                                    (user-variable-p symbol)))
-                             'commandp)))
-    (if (apropos-print
-        t
-        (lambda (p)
-          (let (doc symbol)
-            (while p
-              (setcar p (list
-                         (setq symbol (car p))
-                         (if (commandp symbol)
-                             (if (setq doc (documentation symbol t))
-                                 (substring doc 0 (string-match "\n" doc))
-                               "(not documented)"))
-                         (and do-all
-                              (user-variable-p symbol)
-                              (if (setq doc (documentation-property
-                                             symbol 'variable-documentation t))
-                                  (substring doc 0
-                                             (string-match "\n" doc))))))
-              (setq p (cdr p)))))
-        nil)
-       (and message (message message)))))
+                           (or var-predicate
+                               (if do-all 'functionp 'commandp))))
+    (let ((tem apropos-accumulator))
+      (while tem
+       (if (get (car tem) 'apropos-inhibit)
+           (setq apropos-accumulator (delq (car tem) apropos-accumulator)))
+       (setq tem (cdr tem))))
+    (let ((p apropos-accumulator)
+         doc symbol)
+      (while p
+       (setcar p (list
+                  (setq symbol (car p))
+                  (unless var-predicate
+                    (if (functionp symbol)
+                        (if (setq doc (documentation symbol t))
+                            (substring doc 0 (string-match "\n" doc))
+                          "(not documented)")))
+                  (and var-predicate
+                       (funcall var-predicate symbol)
+                       (if (setq doc (documentation-property
+                                      symbol 'variable-documentation t))
+                           (substring doc 0
+                                      (string-match "\n" doc))))))
+       (setq p (cdr p))))
+    (and (apropos-print t nil)
+        message
+        (message message))))

 
 
 ;;;###autoload
 (defun apropos (apropos-regexp &optional do-all)
 
 
 ;;;###autoload
 (defun apropos (apropos-regexp &optional do-all)

-  "Show all bound symbols whose names match REGEXP.
-With optional prefix ARG or if `apropos-do-all' is non-nil, also show unbound
-symbols and key bindings, which is a little more time-consuming.
-Returns list of symbols and documentation found."
+  "Show all bound symbols whose names match APROPOS-REGEXP.
+With optional prefix DO-ALL or if `apropos-do-all' is non-nil, also
+show unbound symbols and key bindings, which is a little more
+time-consuming.  Returns list of symbols and documentation found."

   (interactive "sApropos symbol (regexp): \nP")
   (setq apropos-accumulator
        (apropos-internal apropos-regexp
   (interactive "sApropos symbol (regexp): \nP")
   (setq apropos-accumulator
        (apropos-internal apropos-regexp


@@ -178,36 +225,63 @@ Returns list of symbols and documentation found."
                               (lambda (symbol)
                                 (or (fboundp symbol)
                                     (boundp symbol)
                               (lambda (symbol)
                                 (or (fboundp symbol)
                                     (boundp symbol)

+                                    (facep symbol)

                                     (symbol-plist symbol))))))
                                     (symbol-plist symbol))))))

+  (let ((tem apropos-accumulator))
+    (while tem
+      (if (get (car tem) 'apropos-inhibit)
+         (setq apropos-accumulator (delq (car tem) apropos-accumulator)))
+      (setq tem (cdr tem))))
+  (let ((p apropos-accumulator)
+       symbol doc properties)
+    (while p
+      (setcar p (list
+                (setq symbol (car p))
+                (when (fboundp symbol)
+                  (if (setq doc (condition-case nil
+                                    (documentation symbol t)
+                                  (void-function
+                                   "(alias for undefined function)")))
+                      (substring doc 0 (string-match "\n" doc))
+                    "(not documented)"))
+                (when (boundp symbol)
+                  (if (setq doc (documentation-property
+                                 symbol 'variable-documentation t))
+                      (substring doc 0 (string-match "\n" doc))
+                    "(not documented)"))
+                (when (setq properties (symbol-plist symbol))
+                  (setq doc (list (car properties)))
+                  (while (setq properties (cdr (cdr properties)))
+                    (setq doc (cons (car properties) doc)))
+                  (mapconcat #'symbol-name (nreverse doc) " "))
+                (when (get symbol 'widget-type)
+                  (if (setq doc (documentation-property
+                                 symbol 'widget-documentation t))
+                      (substring doc 0
+                                 (string-match "\n" doc))
+                    "(not documented)"))
+                (when (facep symbol)
+                  (if (setq doc (documentation-property
+                                 symbol 'face-documentation t))
+                      (substring doc 0
+                                 (string-match "\n" doc))
+                    "(not documented)"))
+                (when (get symbol 'custom-group)
+                  (if (setq doc (documentation-property
+                                 symbol 'group-documentation t))
+                      (substring doc 0
+                                 (string-match "\n" doc))
+                    "(not documented)"))))
+      (setq p (cdr p))))

   (apropos-print
    (or do-all apropos-do-all)
   (apropos-print
    (or do-all apropos-do-all)

-   (lambda (p)
-     (let (symbol doc)
-       (while p
-        (setcar p (list
-                   (setq symbol (car p))
-                   (if (fboundp symbol)
-                       (if (setq doc (documentation symbol t))
-                           (substring doc 0 (string-match "\n" doc))
-                         "(not documented)"))
-                   (if (boundp symbol)
-                       (if (setq doc (documentation-property
-                                      symbol 'variable-documentation t))
-                           (substring doc 0
-                                      (string-match "\n" doc))
-                         "(not documented)"))
-                   (if (setq doc (symbol-plist symbol))
-                       (if (eq (/ (length doc) 2) 1)
-                           (format "1 property (%s)" (car doc))
-                         (concat (/ (length doc) 2) " properties")))))
-        (setq p (cdr p)))))

    nil))
 
 
 ;;;###autoload
 (defun apropos-value (apropos-regexp &optional do-all)
    nil))
 
 
 ;;;###autoload
 (defun apropos-value (apropos-regexp &optional do-all)

-  "Show all symbols whose value's printed image matches REGEXP.
-With optional prefix ARG or if `apropos-do-all' is non-nil, also looks
+  "Show all symbols whose value's printed image matches APROPOS-REGEXP.
+With optional prefix DO-ALL or if `apropos-do-all' is non-nil, also looks

 at the function and at the names and values of properties.
 Returns list of symbols and values found."
   (interactive "sApropos value (regexp): \nP")
 at the function and at the names and values of properties.
 Returns list of symbols and values found."
   (interactive "sApropos value (regexp): \nP")


@@ -226,13 +300,13 @@ Returns list of symbols and values found."
        (if (or f v p)
            (setq apropos-accumulator (cons (list symbol f v p)
                                            apropos-accumulator))))))
        (if (or f v p)
            (setq apropos-accumulator (cons (list symbol f v p)
                                            apropos-accumulator))))))

-  (apropos-print nil nil t))
+  (apropos-print nil t))

 
 
 ;;;###autoload
 (defun apropos-documentation (apropos-regexp &optional do-all)
 
 
 ;;;###autoload
 (defun apropos-documentation (apropos-regexp &optional do-all)

-  "Show symbols whose documentation contain matches for REGEXP.
-With optional prefix ARG or if `apropos-do-all' is non-nil, also use
+  "Show symbols whose documentation contain matches for APROPOS-REGEXP.
+With optional prefix DO-ALL or if `apropos-do-all' is non-nil, also use

 documentation that is not stored in the documentation file and show key
 bindings.
 Returns list of symbols and documentation found."
 documentation that is not stored in the documentation file and show key
 bindings.
 Returns list of symbols and documentation found."


@@ -264,7 +338,7 @@ Returns list of symbols and documentation found."
                       (setq apropos-accumulator
                             (cons (list symbol f v)
                                   apropos-accumulator)))))))
                       (setq apropos-accumulator
                             (cons (list symbol f v)
                                   apropos-accumulator)))))))

-         (apropos-print nil nil t))
+         (apropos-print nil t))

       (kill-buffer standard-input))))
 
 \f
       (kill-buffer standard-input))))
 
 \f


@@ -397,7 +471,7 @@ Returns list of symbols and documentation found."
 
 
 (defun apropos-safe-documentation (function)
 
 
 (defun apropos-safe-documentation (function)

-  "Like documentation, except it avoids calling `get_doc_string'.
+  "Like `documentation', except it avoids calling `get_doc_string'.

 Will return nil instead."
   (while (and function (symbolp function))
     (setq function (if (fboundp function)
 Will return nil instead."
   (while (and function (symbolp function))
     (setq function (if (fboundp function)


@@ -420,30 +494,34 @@ Will return nil instead."
 
 
 
 
 
 

-(defun apropos-print (do-keys doc-fn spacing)
-  "Output result of various apropos commands with `apropos-regexp'.
-APROPOS-ACCUMULATOR is a list.  Optional DOC-FN is called for each element
-of apropos-accumulator and may modify it resulting in (symbol fn-doc
-var-doc [plist-doc]).  Returns sorted list of symbols and documentation
-found."
+(defvar apropos-label-properties nil
+  "List of face properties to use for a label.
+Bound by `apropos-print' for use by `apropos-print-doc'.")
+
+(defun apropos-print (do-keys spacing)
+  "Output result of apropos searching into buffer `*Apropos*'.
+The value of `apropos-accumulator' is the list of items to output.
+Each element should have the format (SYMBOL FN-DOC VAR-DOC [PLIST-DOC]).
+The return value is the list that was in `apropos-accumulator', sorted
+alphabetically by symbol name; but this function also sets
+`apropos-accumulator' to nil before returning."

   (if (null apropos-accumulator)
       (message "No apropos matches for `%s'" apropos-regexp)
   (if (null apropos-accumulator)
       (message "No apropos matches for `%s'" apropos-regexp)

-    (if doc-fn
-       (funcall doc-fn apropos-accumulator))

     (setq apropos-accumulator
          (sort apropos-accumulator (lambda (a b)
                                      (string-lessp (car a) (car b)))))
     (setq apropos-accumulator
          (sort apropos-accumulator (lambda (a b)
                                      (string-lessp (car a) (car b)))))

-    (and apropos-label-face
-        (symbolp apropos-label-face)
-        (setq apropos-label-face `(face ,apropos-label-face
-                                        mouse-face highlight)))
+    (setq apropos-label-properties
+         (if (and apropos-label-face
+                  (symbolp apropos-label-face))
+             `(face ,apropos-label-face
+                    mouse-face highlight)))

     (with-output-to-temp-buffer "*Apropos*"
       (let ((p apropos-accumulator)
            (old-buffer (current-buffer))
            symbol item point1 point2)
        (set-buffer standard-output)
        (apropos-mode)
     (with-output-to-temp-buffer "*Apropos*"
       (let ((p apropos-accumulator)
            (old-buffer (current-buffer))
            symbol item point1 point2)
        (set-buffer standard-output)
        (apropos-mode)

-       (if window-system
+       (if (display-mouse-p)

            (insert "If you move the mouse over text that changes color,\n"
                    (substitute-command-keys
                     "you can click \\[apropos-mouse-follow] to get more information.\n")))
            (insert "If you move the mouse over text that changes color,\n"
                    (substitute-command-keys
                     "you can click \\[apropos-mouse-follow] to get more information.\n")))


@@ -457,25 +535,50 @@ found."
                point1 (point))
          (princ symbol)                        ; print symbol name
          (setq point2 (point))
                point1 (point))
          (princ symbol)                        ; print symbol name
          (setq point2 (point))

-         ;; don't calculate key-bindings unless needed
+         ;; Calculate key-bindings if we want them.

          (and do-keys
               (commandp symbol)
               (indent-to 30 1)
          (and do-keys
               (commandp symbol)
               (indent-to 30 1)

-              (insert
-               (if (setq item (save-excursion
-                                (set-buffer old-buffer)
-                                (where-is-internal symbol)))
+              (if (let ((keys
+                         (save-excursion
+                           (set-buffer old-buffer)
+                           (where-is-internal symbol)))
+                        filtered)
+                    ;; Copy over the list of key sequences,
+                    ;; omitting any that contain a buffer or a frame.
+                    (while keys
+                      (let ((key (car keys))
+                            (i 0)
+                            loser)
+                        (while (< i (length key))
+                          (if (or (framep (aref key i))
+                                  (bufferp (aref key i)))
+                              (setq loser t))
+                          (setq i (1+ i)))
+                        (or loser
+                            (setq filtered (cons key filtered))))
+                      (setq keys (cdr keys)))
+                    (setq item filtered))
+                  ;; Convert the remaining keys to a string and insert.
+                  (insert

                    (mapconcat
                    (mapconcat

-                    (if apropos-keybinding-face
-                        (lambda (key)
-                          (setq key (key-description key))
+                    (lambda (key)
+                      (setq key (condition-case ()
+                                    (key-description key)
+                                  (error)))
+                      (if apropos-keybinding-face

                           (put-text-property 0 (length key)
                                              'face apropos-keybinding-face
                           (put-text-property 0 (length key)
                                              'face apropos-keybinding-face

-                                             key)
-                          key)
-                      'key-description)
-                    item ", ")
-                 "(not bound to any keys)")))
+                                             key))
+                      key)
+                    item ", "))
+                (insert "M-x")
+                (put-text-property (- (point) 3) (point)
+                                   'face apropos-keybinding-face)
+                (insert " " (symbol-name symbol) " ")
+                (insert "RET")
+                (put-text-property (- (point) 3) (point)
+                                   'face apropos-keybinding-face)))

          (terpri)
          ;; only now so we don't propagate text attributes all over
          (put-text-property point1 point2 'item
          (terpri)
          ;; only now so we don't propagate text attributes all over
          (put-text-property point1 point2 'item


@@ -490,11 +593,20 @@ found."
                               (if (apropos-macrop symbol)
                                   "Macro"
                                 "Function"))
                               (if (apropos-macrop symbol)
                                   "Macro"
                                 "Function"))

-                            do-keys)
-         (apropos-print-doc 'describe-variable 2
-                            "Variable" do-keys)
+                            t)
+         ;; We used to use `customize-variable-other-window' instead
+         ;; for a customizable variable, but that is slow.
+         ;; It is better to show an ordinary help buffer
+         ;; and let the user click on the customization button
+         ;; in that buffer, if he wants to.
+         ;; Likewise for `customize-face-other-window'.
+         (apropos-print-doc 'describe-variable 2 "Variable" t)
+         (apropos-print-doc 'customize-group-other-window 6 "Group" t)
+         (apropos-print-doc 'describe-face 5 "Face" t)
+         (apropos-print-doc 'widget-browse-other-window 4 "Widget" t)

          (apropos-print-doc 'apropos-describe-plist 3
          (apropos-print-doc 'apropos-describe-plist 3

-                            "Plist" nil)))))
+                            "Plist" nil))
+       (setq buffer-read-only t))))

   (prog1 apropos-accumulator
     (setq apropos-accumulator ())))    ; permit gc
 
   (prog1 apropos-accumulator
     (setq apropos-accumulator ())))    ; permit gc
 


@@ -517,10 +629,10 @@ found."
        (put-text-property (- (point) 2) (1- (point))
                           'action action)
        (insert str ": ")
        (put-text-property (- (point) 2) (1- (point))
                           'action action)
        (insert str ": ")

-       (if apropos-label-face
+       (if apropos-label-properties

            (add-text-properties (- (point) (length str) 2)
                                 (1- (point))
            (add-text-properties (- (point) (length str) 2)
                                 (1- (point))

-                                apropos-label-face))
+                                apropos-label-properties))

        (insert (if do-keys (substitute-command-keys i) i))
        (or (bolp) (terpri)))))
 
        (insert (if do-keys (substitute-command-keys i) i))
        (or (bolp) (terpri)))))
 


@@ -574,4 +686,6 @@ found."
     (princ ")")
     (print-help-return-message)))
 
     (princ ")")
     (print-help-return-message)))
 

+(provide 'apropos)
+

 ;;; apropos.el ends here
 ;;; apropos.el ends here