X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/045c4971c770f35bea5146eda89b98c2c3a15267..2d0ffc9aa8662ec6d931bcb0d755ceb36fc62020:/lisp/apropos.el diff --git a/lisp/apropos.el b/lisp/apropos.el index 1702cc3097..19a8aab206 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. @@ -59,7 +59,7 @@ (defgroup apropos nil "Apropos commands for users and programmers" - :group 'Help + :group 'help :prefix "apropos") ;; I see a degradation of maybe 10-20% only. @@ -71,36 +71,32 @@ Slows them down more or less. Set this non-nil if you have a fast machine." :type 'boolean) -(defcustom 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) -(defcustom 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) -(defcustom 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) -(defcustom 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) -(defcustom 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) @@ -189,27 +185,26 @@ satisfy the predicate VAR-PREDICATE." (if (get (car tem) 'apropos-inhibit) (setq apropos-accumulator (delq (car tem) apropos-accumulator))) (setq tem (cdr tem)))) - (if (apropos-print - t - (lambda (p) - (let (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))))) - nil) - (and message (message message))))) + (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 @@ -233,49 +228,49 @@ Returns list of symbols and documentation found." (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 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))))) nil)) @@ -301,7 +296,7 @@ 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 @@ -339,7 +334,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)))) @@ -495,23 +490,27 @@ 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)) @@ -560,7 +559,9 @@ found." (insert (mapconcat (lambda (key) - (setq key (key-description key)) + (setq key (condition-case () + (key-description key) + (error))) (if apropos-keybinding-face (put-text-property 0 (length key) 'face apropos-keybinding-face @@ -599,7 +600,8 @@ found." (apropos-print-doc 'customize-face-other-window 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 @@ -622,10 +624,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)))))