X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/1f64403f132fc120ff0b69db45edf85eaffaf9de..31f84d032894a5277d1d0f4a302baa3f6b4b3db4:/lisp/apropos.el diff --git a/lisp/apropos.el b/lisp/apropos.el index 04b0223e28..c184a689bf 100644 --- a/lisp/apropos.el +++ b/lisp/apropos.el @@ -3,7 +3,7 @@ ;; Copyright (C) 1989, 1994, 1995 Free Software Foundation, Inc. ;; Author: Joe Wells -;; Rewritten: Daniel.Pfeiffer@Informatik.START.dbp.de, fax (+49 69) 7588-2389 +;; Rewritten: Daniel Pfeiffer ;; 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 -;; 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: @@ -56,44 +57,63 @@ ;;; Code: +(defgroup apropos nil + "Apropos commands for users and programmers" + :group 'help + :prefix "apropos") + ;; 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. -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) + (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.") +(defvar apropos-mode-hook nil + "*Hook run when mode is turned on.") (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 () - "Current item in or for apropos-accumulator.") + "Current item in or for `apropos-accumulator'.") +;;;###autoload (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 - 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 -(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*"))) @@ -138,38 +182,41 @@ variables." (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) - "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 @@ -178,36 +225,63 @@ Returns list of symbols and documentation found." (lambda (symbol) (or (fboundp symbol) (boundp symbol) + (facep 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) - (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) - "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") @@ -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)))))) - (apropos-print nil nil t)) + (apropos-print nil t)) ;;;###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." @@ -264,7 +338,7 @@ Returns list of symbols and documentation found." (setq apropos-accumulator (cons (list symbol f v) apropos-accumulator))))))) - (apropos-print nil nil t)) + (apropos-print nil t)) (kill-buffer standard-input)))) @@ -397,7 +471,7 @@ Returns list of symbols and documentation found." (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) @@ -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 doc-fn - (funcall doc-fn apropos-accumulator)) (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) - (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"))) @@ -457,25 +535,50 @@ found." 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) - (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 - (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 - 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 @@ -490,11 +593,20 @@ found." (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 - "Plist" nil))))) + "Plist" nil)) + (setq buffer-read-only t)))) (prog1 apropos-accumulator (setq apropos-accumulator ()))) ; permit gc @@ -517,10 +629,10 @@ found." (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)) - apropos-label-face)) + apropos-label-properties)) (insert (if do-keys (substitute-command-keys i) i)) (or (bolp) (terpri))))) @@ -574,4 +686,6 @@ found." (princ ")") (print-help-return-message))) +(provide 'apropos) + ;;; apropos.el ends here