X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/a33b76c3eb717aff77676288debffa30f700a92b..03da5d089a8ed035cec443a27259e7d21487a22e:/lisp/apropos.el diff --git a/lisp/apropos.el b/lisp/apropos.el index d72c595ca6..fcad5cac0d 100644 --- a/lisp/apropos.el +++ b/lisp/apropos.el @@ -1,8 +1,10 @@ -;;; apropos.el --- faster apropos commands. +;;; apropos.el --- apropos commands for users and programmers -;; Copyright (C) 1989, 1994 Free Software Foundation, Inc. +;; Copyright (C) 1989, 1994, 1995, 2001, 2002, 2003, 2004, +;; 2005 Free Software Foundation, Inc. ;; Author: Joe Wells +;; Rewritten: Daniel Pfeiffer ;; Keywords: help ;; This file is part of GNU Emacs. @@ -18,8 +20,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., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: @@ -35,354 +38,905 @@ ;; Fixed bug, current-local-map can return nil. ;; Change, doesn't calculate key-bindings unless needed. ;; Added super-apropos capability, changed print functions. -;; Made fast-apropos and super-apropos share code. -;; Sped up fast-apropos again. +;;; Made fast-apropos and super-apropos share code. +;;; Sped up fast-apropos again. ;; Added apropos-do-all option. -;; Added fast-command-apropos. +;;; Added fast-command-apropos. ;; Changed doc strings to comments for helping functions. -;; Made doc file buffer read-only, buried it. +;;; Made doc file buffer read-only, buried it. ;; Only call substitute-command-keys if do-all set. +;; Optionally use configurable faces to make the output more legible. +;; Differentiate between command, function and macro. +;; Apropos-command (ex command-apropos) does cmd and optionally user var. +;; Apropos shows all 3 aspects of symbols (fn, var and plist) +;; Apropos-documentation (ex super-apropos) now finds all it should. +;; New apropos-value snoops through all values and optionally plists. +;; Reading DOC file doesn't load nroff. +;; Added hypertext following of documentation, mouse-2 on variable gives value +;; from buffer in active window. + ;;; Code: -(defvar apropos-do-all nil - "*Whether `apropos' and `super-apropos' should do everything that they can. -Makes them run 2 or 3 times slower. Set this non-nil if you have a fast -machine.") +(require 'button) +(eval-when-compile (require 'cl)) + +(defgroup apropos nil + "Apropos commands for users and programmers." + :group 'help + :prefix "apropos") + +;; I see a degradation of maybe 10-20% only. +(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." + :group 'apropos + :type 'boolean) + + +(defcustom apropos-symbol-face 'bold + "*Face for symbol name in Apropos output, or nil for none." + :group 'apropos + :type 'face) + +(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 '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 'bold-italic + "*Face for property name in apropos output, or nil for none." + :group 'apropos + :type 'face) + +(defcustom apropos-match-face 'match + "*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) + +(defcustom apropos-sort-by-scores nil + "*Non-nil means sort matches by scores; best match is shown first. +The computed score is shown for each match." + :group 'apropos + :type 'boolean) + +(defvar apropos-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map button-buffer-map) + ;; Use `apropos-follow' instead of just using the button + ;; definition of RET, so that users can use it anywhere in an + ;; apropos item, not just on top of a button. + (define-key map "\C-m" 'apropos-follow) + (define-key map " " 'scroll-up) + (define-key map "\177" 'scroll-down) + (define-key map "q" 'quit-window) + 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-orig-regexp nil + "Regexp as entered by user.") + +(defvar apropos-all-regexp nil + "Regexp matching apropos-all-words.") + +(defvar apropos-files-scanned () + "List of elc files already scanned in current run of `apropos-documentation'.") + +(defvar apropos-accumulator () + "Alist of symbols already found in current apropos run.") + +(defvar apropos-item () + "Current item in or for `apropos-accumulator'.") + +(defvar apropos-synonyms '( + ("find" "open" "edit") + ("kill" "cut") + ("yank" "paste")) + "List of synonyms known by apropos. +Each element is a list of words where the first word is the standard emacs +term, and the rest of the words are alternative terms.") + +(defvar apropos-words () + "Current list of words.") + +(defvar apropos-all-words () + "Current list of words and synonyms.") + + +;;; Button types used by apropos + +(define-button-type 'apropos-symbol + 'face apropos-symbol-face + 'help-echo "mouse-2, RET: Display more help on this symbol" + 'follow-link t + 'action #'apropos-symbol-button-display-help + 'skip t) + +(defun apropos-symbol-button-display-help (button) + "Display further help for the `apropos-symbol' button BUTTON." + (button-activate + (or (apropos-next-label-button (button-start button)) + (error "There is nothing to follow for `%s'" (button-label button))))) + +(define-button-type 'apropos-function + 'apropos-label "Function" + 'help-echo "mouse-2, RET: Display more help on this function" + 'follow-link t + 'action (lambda (button) + (describe-function (button-get button 'apropos-symbol)))) + +(define-button-type 'apropos-macro + 'apropos-label "Macro" + 'help-echo "mouse-2, RET: Display more help on this macro" + 'follow-link t + 'action (lambda (button) + (describe-function (button-get button 'apropos-symbol)))) + +(define-button-type 'apropos-command + 'apropos-label "Command" + 'help-echo "mouse-2, RET: Display more help on this command" + 'follow-link t + 'action (lambda (button) + (describe-function (button-get button 'apropos-symbol)))) + +;; 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'. +(define-button-type 'apropos-variable + 'apropos-label "Variable" + 'help-echo "mouse-2, RET: Display more help on this variable" + 'follow-link t + 'action (lambda (button) + (describe-variable (button-get button 'apropos-symbol)))) + +(define-button-type 'apropos-face + 'apropos-label "Face" + 'help-echo "mouse-2, RET: Display more help on this face" + 'follow-link t + 'action (lambda (button) + (describe-face (button-get button 'apropos-symbol)))) + +(define-button-type 'apropos-group + 'apropos-label "Group" + 'help-echo "mouse-2, RET: Display more help on this group" + 'follow-link t + 'action (lambda (button) + (customize-group-other-window + (button-get button 'apropos-symbol)))) + +(define-button-type 'apropos-widget + 'apropos-label "Widget" + 'help-echo "mouse-2, RET: Display more help on this widget" + 'follow-link t + 'action (lambda (button) + (widget-browse-other-window (button-get button 'apropos-symbol)))) + +(define-button-type 'apropos-plist + 'apropos-label "Plist" + 'help-echo "mouse-2, RET: Display more help on this plist" + 'follow-link t + 'action (lambda (button) + (apropos-describe-plist (button-get button 'apropos-symbol)))) + +(defun apropos-next-label-button (pos) + "Return the next apropos label button after POS, or nil if there's none. +Will also return nil if more than one `apropos-symbol' button is encountered +before finding a label." + (let* ((button (next-button pos t)) + (already-hit-symbol nil) + (label (and button (button-get button 'apropos-label))) + (type (and button (button-get button 'type)))) + (while (and button + (not label) + (or (not (eq type 'apropos-symbol)) + (not already-hit-symbol))) + (when (eq type 'apropos-symbol) + (setq already-hit-symbol t)) + (setq button (next-button (button-start button))) + (when button + (setq label (button-get button 'apropos-label)) + (setq type (button-get button 'type)))) + (and label button))) + + +(defun apropos-words-to-regexp (words wild) + "Make regexp matching any two of the words in WORDS." + (concat "\\(" + (mapconcat 'identity words "\\|") + "\\)" + (if (cdr words) + (concat wild + "\\(" + (mapconcat 'identity words "\\|") + "\\)") + ""))) + +(defun apropos-rewrite-regexp (regexp) + "Rewrite a list of words to a regexp matching all permutations. +If REGEXP is already a regexp, don't modify it." + (setq apropos-orig-regexp regexp) + (setq apropos-words () apropos-all-words ()) + (if (string-equal (regexp-quote regexp) regexp) + ;; We don't actually make a regexp matching all permutations. + ;; Instead, for e.g. "a b c", we make a regexp matching + ;; any combination of two or more words like this: + ;; (a|b|c).*(a|b|c) which may give some false matches, + ;; but as long as it also gives the right ones, that's ok. + (let ((words (split-string regexp "[ \t]+"))) + (dolist (word words) + (let ((syn apropos-synonyms) (s word) (a word)) + (while syn + (if (member word (car syn)) + (progn + (setq a (mapconcat 'identity (car syn) "\\|")) + (if (member word (cdr (car syn))) + (setq s a)) + (setq syn nil)) + (setq syn (cdr syn)))) + (setq apropos-words (cons s apropos-words) + apropos-all-words (cons a apropos-all-words)))) + (setq apropos-all-regexp (apropos-words-to-regexp apropos-all-words ".+")) + (apropos-words-to-regexp apropos-words ".*?")) + (setq apropos-all-regexp regexp))) + +(defun apropos-calc-scores (str words) + "Return apropos scores for string STR matching WORDS. +Value is a list of offsets of the words into the string." + (let ((scores ()) + i) + (if words + (dolist (word words scores) + (if (setq i (string-match word str)) + (setq scores (cons i scores)))) + ;; Return list of start and end position of regexp + (string-match apropos-regexp str) + (list (match-beginning 0) (match-end 0))))) + +(defun apropos-score-str (str) + "Return apropos score for string STR." + (if str + (let* ( + (l (length str)) + (score (- (/ l 10))) + i) + (dolist (s (apropos-calc-scores str apropos-all-words) score) + (setq score (+ score 1000 (/ (* (- l s) 1000) l))))) + 0)) + +(defun apropos-score-doc (doc) + "Return apropos score for documentation string DOC." + (let ((l (length doc))) + (if (> l 0) + (let ((score 0) + i) + (dolist (s (apropos-calc-scores doc apropos-all-words) score) + (setq score (+ score 50 (/ (* (- l s) 50) l))))) + 0))) + +(defun apropos-score-symbol (symbol &optional weight) + "Return apropos score for SYMBOL." + (setq symbol (symbol-name symbol)) + (let ((score 0) + (l (length symbol)) + i) + (dolist (s (apropos-calc-scores symbol apropos-words) (* score (or weight 3))) + (setq score (+ score (- 60 l) (/ (* (- l s) 60) l)))))) + +(defun apropos-true-hit (str words) + "Return t if STR is a genuine hit. +This may fail if only one of the keywords is matched more than once. +This requires that at least 2 keywords (unless only one was given)." + (or (not str) + (not words) + (not (cdr words)) + (> (length (apropos-calc-scores str words)) 1))) + +(defun apropos-false-hit-symbol (symbol) + "Return t if SYMBOL is not really matched by the current keywords." + (not (apropos-true-hit (symbol-name symbol) apropos-words))) + +(defun apropos-false-hit-str (str) + "Return t if STR is not really matched by the current keywords." + (not (apropos-true-hit str apropos-words))) + +(defun apropos-true-hit-doc (doc) + "Return t if DOC is really matched by the current keywords." + (apropos-true-hit doc apropos-all-words)) + +(define-derived-mode apropos-mode fundamental-mode "Apropos" + "Major mode for following hyperlinks in output of apropos commands. + +\\{apropos-mode-map}") ;;;###autoload -(defun apropos (regexp &optional do-all pred no-header) - "Show all symbols whose names contain matches for REGEXP. -If optional argument DO-ALL is non-nil (prefix argument if interactive), -or if `apropos-do-all' is non-nil, does more (time-consuming) work such as -showing key bindings. Optional argument PRED is called with each symbol, and -if it returns nil, the symbol is not shown. +(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 or words): ")) + 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 +(defalias 'command-apropos 'apropos-command) +;;;###autoload +(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 or words): ")) + current-prefix-arg)) + (setq apropos-regexp (apropos-rewrite-regexp apropos-regexp)) + (let ((message + (let ((standard-output (get-buffer-create "*Apropos*"))) + (print-help-return-message 'identity)))) + (or do-all (setq do-all apropos-do-all)) + (setq apropos-accumulator + (apropos-internal apropos-regexp + (or var-predicate + (if do-all 'functionp 'commandp)))) + (let ((tem apropos-accumulator)) + (while tem + (if (or (get (car tem) 'apropos-inhibit) + (apropos-false-hit-symbol (car tem))) + (setq apropos-accumulator (delq (car tem) apropos-accumulator))) + (setq tem (cdr tem)))) + (let ((p apropos-accumulator) + doc symbol score) + (while p + (setcar p (list + (setq symbol (car p)) + (setq score (apropos-score-symbol symbol)) + (unless var-predicate + (if (functionp symbol) + (if (setq doc (documentation symbol t)) + (progn + (setq score (+ score (apropos-score-doc doc))) + (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)) + (progn + (setq score (+ score (apropos-score-doc doc))) + (substring doc 0 + (string-match "\n" doc))))))) + (setcar (cdr (car p)) score) + (setq p (cdr p)))) + (and (apropos-print t nil) + message + (message message)))) -Optional argument NO-HEADER means don't print `Function:' or `Variable:' -in the output. -Returns list of symbols and documentation found." - (interactive "sApropos (regexp): \nP") - (setq do-all (or apropos-do-all do-all)) - (let ((apropos-accumulate (apropos-internal regexp pred))) - (if (null apropos-accumulate) - (message "No apropos matches for `%s'" regexp) - (apropos-get-doc apropos-accumulate) - (with-output-to-temp-buffer "*Help*" - (apropos-print-matches apropos-accumulate regexp nil - do-all no-header))) - apropos-accumulate)) - -;; Takes LIST of symbols and adds documentation. Modifies LIST in place. -;; Resulting alist is of form ((symbol fn-doc var-doc) ...). Should only be -;; called by apropos. Returns LIST. - -(defun apropos-get-doc (list) - (let ((p list) - fn-doc var-doc symbol) - (while (consp p) - (setq symbol (car p) - fn-doc (and (fboundp symbol) - (documentation symbol)) - var-doc (documentation-property symbol 'variable-documentation) - fn-doc (and fn-doc - (substring fn-doc 0 (string-match "\n" fn-doc))) - var-doc (and var-doc - (substring var-doc 0 (string-match "\n" var-doc)))) - (setcar p (list symbol fn-doc var-doc)) - (setq p (cdr p))) - list)) - -;; Variables bound by super-apropos and used by its subroutines. -;; It would be good to say what each one is for, but I don't know -- rms. -(defvar apropos-item) -(defvar apropos-var-doc) -(defvar apropos-fn-doc) -(defvar apropos-accumulate) -(defvar apropos-regexp - "Within `super-apropos', this holds the REGEXP argument.") +;;;###autoload +(defun apropos-documentation-property (symbol property raw) + "Like (documentation-property SYMBOL PROPERTY RAW) but handle errors." + (condition-case () + (let ((doc (documentation-property symbol property raw))) + (if doc (substring doc 0 (string-match "\n" doc)) + "(not documented)")) + (error "(error retrieving documentation)"))) + ;;;###autoload -(defun super-apropos (regexp &optional do-all) - "Show symbols whose names/documentation contain matches for REGEXP. -If optional argument DO-ALL is non-nil (prefix argument if interactive), -or if `apropos-do-all' is non-nil, does more (time-consuming) work such as -showing key bindings and documentation that is not stored in the documentation -file. +(defun apropos (apropos-regexp &optional do-all) + "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 or words): \nP") + (setq apropos-regexp (apropos-rewrite-regexp apropos-regexp)) + (apropos-symbols-internal + (apropos-internal apropos-regexp + (and (not do-all) + (not apropos-do-all) + (lambda (symbol) + (or (fboundp symbol) + (boundp symbol) + (facep symbol) + (symbol-plist symbol))))) + (or do-all apropos-do-all))) + +(defun apropos-symbols-internal (symbols keys &optional text) + ;; Filter out entries that are marked as apropos-inhibit. + (let ((all nil)) + (dolist (symbol symbols) + (unless (get symbol 'apropos-inhibit) + (push symbol all))) + (setq symbols all)) + (let ((apropos-accumulator + (mapcar + (lambda (symbol) + (let (doc properties) + (list + symbol + (apropos-score-symbol symbol) + (when (fboundp symbol) + (if (setq doc (condition-case nil + (documentation symbol t) + (void-function + "(alias for undefined function)") + (error + "(can't retrieve function documentation)"))) + (substring doc 0 (string-match "\n" doc)) + "(not documented)")) + (when (boundp symbol) + (apropos-documentation-property + symbol 'variable-documentation t)) + (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) + (apropos-documentation-property + symbol 'widget-documentation t)) + (when (facep symbol) + (apropos-documentation-property + symbol 'face-documentation t)) + (when (get symbol 'custom-group) + (apropos-documentation-property + symbol 'group-documentation t))))) + symbols))) + (apropos-print keys nil text))) + + +;;;###autoload +(defun apropos-value (apropos-regexp &optional do-all) + "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 or words): \nP") + (setq apropos-regexp (apropos-rewrite-regexp apropos-regexp)) + (or do-all (setq do-all apropos-do-all)) + (setq apropos-accumulator ()) + (let (f v p) + (mapatoms + (lambda (symbol) + (setq f nil v nil p nil) + (or (memq symbol '(apropos-regexp + apropos-orig-regexp apropos-all-regexp + apropos-words apropos-all-words + do-all apropos-accumulator + symbol f v p)) + (setq v (apropos-value-internal 'boundp symbol 'symbol-value))) + (if do-all + (setq f (apropos-value-internal 'fboundp symbol 'symbol-function) + p (apropos-format-plist symbol "\n " t))) + (if (apropos-false-hit-str v) + (setq v nil)) + (if (apropos-false-hit-str f) + (setq f nil)) + (if (apropos-false-hit-str p) + (setq p nil)) + (if (or f v p) + (setq apropos-accumulator (cons (list symbol + (+ (apropos-score-str f) + (apropos-score-str v) + (apropos-score-str p)) + f v p) + apropos-accumulator)))))) + (apropos-print nil "\n----------------\n")) + +;;;###autoload +(defun apropos-documentation (apropos-regexp &optional do-all) + "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." - (interactive "sSuper Apropos: \nP") - (setq do-all (or apropos-do-all do-all)) - (let ((apropos-regexp regexp) - apropos-accumulate apropos-fn-doc apropos-var-doc apropos-item) - (setq apropos-accumulate (super-apropos-check-doc-file apropos-regexp)) - (if (null apropos-accumulate) - (message "No apropos matches for `%s'" apropos-regexp) - (if do-all (mapatoms 'super-apropos-accumulate)) - (with-output-to-temp-buffer "*Help*" - (apropos-print-matches apropos-accumulate nil t do-all))) - apropos-accumulate)) - -;; Finds all documentation related to REGEXP in internal-doc-file-name. -;; Returns an alist of form ((symbol fn-doc var-doc) ...). - -(defun super-apropos-check-doc-file (regexp) - (let* ((doc-file (concat doc-directory internal-doc-file-name)) - (doc-buffer - ;; Force fundamental mode for the DOC file. - (let (auto-mode-alist) - (find-file-noselect doc-file t))) - type symbol doc sym-list) - (save-excursion - (set-buffer doc-buffer) - ;; a user said he might accidentally edit the doc file - (setq buffer-read-only t) - (bury-buffer doc-buffer) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (search-backward "\C-_") - (setq type (if (eq ?F (char-after (1+ (point)))) - 1 ;function documentation - 2) ;variable documentation - symbol (progn - (forward-char 2) - (read doc-buffer)) - doc (buffer-substring - (point) - (progn - (if (search-forward "\C-_" nil 'move) - (1- (point)) - (point)))) - apropos-item (assq symbol sym-list)) - (and (if (= type 1) - (and (fboundp symbol) (documentation symbol)) - (documentation-property symbol 'variable-documentation)) - (or apropos-item - (setq apropos-item (list symbol nil nil) - sym-list (cons apropos-item sym-list))) - (setcar (nthcdr type apropos-item) doc)))) - sym-list)) - -;; This is passed as the argument to map-atoms, so it is called once for every -;; symbol in obarray. Takes one argument SYMBOL, and finds any memory-resident -;; documentation on that symbol if it matches a variable regexp. - -(defun super-apropos-accumulate (symbol) - (cond ((string-match apropos-regexp (symbol-name symbol)) - (setq apropos-item (apropos-get-accum-item symbol)) - (setcar (cdr apropos-item) (or (safe-documentation symbol) - (nth 1 apropos-item))) - (setcar (nthcdr 2 apropos-item) (or (safe-documentation-property symbol) - (nth 2 apropos-item)))) - (t - (and (setq apropos-fn-doc (safe-documentation symbol)) - (string-match apropos-regexp apropos-fn-doc) - (setcar (cdr (apropos-get-accum-item symbol)) apropos-fn-doc)) - (and (setq apropos-var-doc (safe-documentation-property symbol)) - (string-match apropos-regexp apropos-var-doc) - (setcar (nthcdr 2 (apropos-get-accum-item symbol)) - apropos-var-doc)))) - nil) - -;; Prints the symbols and documentation in alist MATCHES of form ((symbol -;; fn-doc var-doc) ...). Uses optional argument REGEXP to speed up searching -;; for keybindings. The names of all symbols in MATCHES must match REGEXP. -;; Displays in the buffer pointed to by standard-output. Optional argument -;; SPACING means put blank lines in between each symbol's documentation. -;; Optional argument DO-ALL means do more time-consuming work, specifically, -;; consulting key bindings. Should only be called within a -;; with-output-to-temp-buffer. - -(defun apropos-print-matches (matches &optional regexp - spacing do-all no-header) - (setq matches (sort matches (function - (lambda (a b) - (string-lessp (car a) (car b)))))) - (let ((p matches) - (old-buffer (current-buffer)) - item keys-done symbol tem) - (save-excursion - (set-buffer standard-output) - (or matches (princ "No matches found.")) - (while (consp p) - (setq item (car p) - symbol (car item) - p (cdr p)) - (or (not spacing) (bobp) (terpri)) - (princ symbol) ;print symbol name - ;; don't calculate key-bindings unless needed - (cond ((and do-all (commandp symbol) (not keys-done)) - (save-excursion - (set-buffer old-buffer) - (apropos-match-keys matches regexp)) - (setq keys-done t))) - (cond ((and do-all - (or (setq tem (nthcdr 3 item)) - (commandp symbol))) - (indent-to 30 1) - (if tem - (princ (mapconcat 'key-description tem ", ")) - (princ "(not bound to any keys)")))) - (terpri) - (cond ((setq tem (nth 1 item)) - (let ((substed (if do-all (substitute-command-keys tem) tem))) - (if no-header - (princ " ") - (princ " Function: ") - (if (> (length substed) 67) - (princ "\n "))) - (princ substed)))) - (or (bolp) (terpri)) - (cond ((setq tem (nth 2 item)) - (let ((substed (if do-all (substitute-command-keys tem) tem))) - (if no-header - (princ " ") - (princ " Variable: ") - (if (> (length substed) 67) - (princ "\n "))) - (princ substed)))) - (or (bolp) (terpri))) - (help-mode))) - t) - -;; Find key bindings for symbols that are cars in ALIST. Optionally, first -;; match the symbol name against REGEXP. Modifies ALIST in place. Each key -;; binding is added as a string to the end of the list in ALIST whose car is -;; the corresponding symbol. The pointer to ALIST is returned. - -(defun apropos-match-keys (alist &optional regexp) - (let* ((current-local-map (current-local-map)) - ;; Get a list of the top-level maps now active. - (top-maps - (if overriding-local-map - (list overriding-local-map (current-global-map)) - (append (current-minor-mode-maps) - (if current-local-map - (list current-local-map (current-global-map)) - (list (current-global-map)))))) - ;; Turn that into a list of all the maps including submaps. - (maps (apply 'append (mapcar 'accessible-keymaps top-maps))) - map ;map we are now inspecting - sequence ;key sequence to reach map - i ;index into vector map - command ;what is bound to current keys - key ;last key to reach command - local ;local binding for sequence + key - item) ;symbol data item in alist - ;; examine all reachable keymaps - (while (consp maps) - (setq map (cdr (car maps)) - sequence (car (car maps)) ;keys to reach this map - maps (cdr maps)) - ;; Skip the leading `keymap', doc string, etc. - (if (eq (car map) 'keymap) - (setq map (cdr map))) - (while (stringp (car-safe map)) - (setq map (cdr map))) - - (while (consp map) - (cond ((consp (car map)) - (setq command (cdr (car map)) - key (car (car map))) - ;; Skip any menu prompt and help string in this key binding. - (while (and (consp command) (stringp (car command))) - (setq command (cdr command))) - ;; Skip any cached equivalent key. - (and (consp command) - (consp (car command)) - (setq command (cdr command))) - ;; if is a symbol, and matches optional regexp, and is a car - ;; in alist, and is not shadowed by a different local binding, - ;; record it - (and (symbolp command) - (if regexp - (string-match regexp (symbol-name command)) - t) - (setq item (assq command alist)) - (if (or (vectorp sequence) (not (integerp key))) - (setq key (vconcat sequence (vector key))) - (setq key (concat sequence (char-to-string key)))) - ;; checking if shadowed by local binding. - ;; either no local map, no local binding, or runs off the - ;; binding tree (number), or is the same binding - (or (not current-local-map) - (not (setq local (lookup-key current-local-map key))) - (numberp local) - (eq command local)) - ;; check if this binding is already recorded - ;; (this can happen due to inherited keymaps) - (not (member key (nthcdr 3 item))) - ;; add this key binding to the item in alist - (nconc item (cons key nil)))) - ((vectorp (car map)) - (let ((i 0) - (vec (car map)) - (len (length (car map)))) - (while (< i len) - (setq command (aref vec i)) - (setq key i) - ;; Skip any menu prompt in this key binding. - (and (consp command) (symbolp (cdr command)) - (setq command (cdr command))) - ;; This is the same as the code in the previous case. - (and (symbolp command) - (if regexp - (string-match regexp (symbol-name command)) - t) - (setq item (assq command alist)) - (if (or (vectorp sequence) (not (integerp key))) - (setq key (vconcat sequence (vector key))) - (setq key (concat sequence (char-to-string key)))) - ;; checking if shadowed by local binding. - ;; either no local map, no local binding, or runs off the - ;; binding tree (number), or is the same binding - (or (not current-local-map) - (not (setq local (lookup-key current-local-map key))) - (numberp local) - (eq command local)) - ;; check if this binding is already recorded - ;; (this can happen due to inherited keymaps) - (not (member key (nthcdr 3 item))) - ;; add this key binding to the item in alist - (nconc item (cons key nil))) - (setq i (1+ i)))))) - (setq map (cdr map))))) - alist) - -;; Get an alist item in alist apropos-accumulate whose car is SYMBOL. Creates -;; the item if not already present. Modifies apropos-accumulate in place. - -(defun apropos-get-accum-item (symbol) - (or (assq symbol apropos-accumulate) + (interactive "sApropos documentation (regexp or words): \nP") + (setq apropos-regexp (apropos-rewrite-regexp apropos-regexp)) + (or do-all (setq do-all apropos-do-all)) + (setq apropos-accumulator () apropos-files-scanned ()) + (let ((standard-input (get-buffer-create " apropos-temp")) + f v sf sv) + (unwind-protect + (save-excursion + (set-buffer standard-input) + (apropos-documentation-check-doc-file) + (if do-all + (mapatoms + (lambda (symbol) + (setq f (apropos-safe-documentation symbol) + v (get symbol 'variable-documentation)) + (if (integerp v) (setq v)) + (setq f (apropos-documentation-internal f) + v (apropos-documentation-internal v)) + (setq sf (apropos-score-doc f) + sv (apropos-score-doc v)) + (if (or f v) + (if (setq apropos-item + (cdr (assq symbol apropos-accumulator))) + (progn + (if f + (progn + (setcar (nthcdr 1 apropos-item) f) + (setcar apropos-item (+ (car apropos-item) sf)))) + (if v + (progn + (setcar (nthcdr 2 apropos-item) v) + (setcar apropos-item (+ (car apropos-item) sv))))) + (setq apropos-accumulator + (cons (list symbol + (+ (apropos-score-symbol symbol 2) sf sv) + f v) + apropos-accumulator))))))) + (apropos-print nil "\n----------------\n")) + (kill-buffer standard-input)))) + + +(defun apropos-value-internal (predicate symbol function) + (if (funcall predicate symbol) (progn - (setq apropos-accumulate - (cons (list symbol nil nil) apropos-accumulate)) - (assq symbol apropos-accumulate)))) - -(defun safe-documentation (function) - "Like documentation, except it avoids calling `get_doc_string'. + (setq symbol (prin1-to-string (funcall function symbol))) + (if (string-match apropos-regexp symbol) + (progn + (if apropos-match-face + (put-text-property (match-beginning 0) (match-end 0) + 'face apropos-match-face + symbol)) + symbol))))) + +(defun apropos-documentation-internal (doc) + (if (consp doc) + (apropos-documentation-check-elc-file (car doc)) + (and doc + (string-match apropos-all-regexp doc) + (save-match-data (apropos-true-hit-doc doc)) + (progn + (if apropos-match-face + (put-text-property (match-beginning 0) + (match-end 0) + 'face apropos-match-face + (setq doc (copy-sequence doc)))) + doc)))) + +(defun apropos-format-plist (pl sep &optional compare) + (setq pl (symbol-plist pl)) + (let (p p-out) + (while pl + (setq p (format "%s %S" (car pl) (nth 1 pl))) + (if (or (not compare) (string-match apropos-regexp p)) + (if apropos-property-face + (put-text-property 0 (length (symbol-name (car pl))) + 'face apropos-property-face p)) + (setq p nil)) + (if p + (progn + (and compare apropos-match-face + (put-text-property (match-beginning 0) (match-end 0) + 'face apropos-match-face + p)) + (setq p-out (concat p-out (if p-out sep) p)))) + (setq pl (nthcdr 2 pl))) + p-out)) + + +;; Finds all documentation related to APROPOS-REGEXP in internal-doc-file-name. + +(defun apropos-documentation-check-doc-file () + (let (type symbol (sepa 2) sepb beg end) + (insert ?\^_) + (backward-char) + (insert-file-contents (concat doc-directory internal-doc-file-name)) + (forward-char) + (while (save-excursion + (setq sepb (search-forward "\^_")) + (not (eobp))) + (beginning-of-line 2) + (if (save-restriction + (narrow-to-region (point) (1- sepb)) + (re-search-forward apropos-all-regexp nil t)) + (progn + (setq beg (match-beginning 0) + end (point)) + (goto-char (1+ sepa)) + (setq type (if (eq ?F (preceding-char)) + 2 ; function documentation + 3) ; variable documentation + symbol (read) + beg (- beg (point) 1) + end (- end (point) 1) + doc (buffer-substring (1+ (point)) (1- sepb))) + (when (apropos-true-hit-doc doc) + (or (and (setq apropos-item (assq symbol apropos-accumulator)) + (setcar (cdr apropos-item) + (+ (cadr apropos-item) (apropos-score-doc doc)))) + (setq apropos-item (list symbol + (+ (apropos-score-symbol symbol 2) + (apropos-score-doc doc)) + nil nil) + apropos-accumulator (cons apropos-item + apropos-accumulator))) + (if apropos-match-face + (put-text-property beg end 'face apropos-match-face doc)) + (setcar (nthcdr type apropos-item) doc)))) + (setq sepa (goto-char sepb))))) + +(defun apropos-documentation-check-elc-file (file) + (if (member file apropos-files-scanned) + nil + (let (symbol doc beg end this-is-a-variable) + (setq apropos-files-scanned (cons file apropos-files-scanned)) + (erase-buffer) + (insert-file-contents file) + (while (search-forward "\n#@" nil t) + ;; Read the comment length, and advance over it. + (setq end (read) + beg (1+ (point)) + end (+ (point) end -1)) + (forward-char) + (if (save-restriction + ;; match ^ and $ relative to doc string + (narrow-to-region beg end) + (re-search-forward apropos-all-regexp nil t)) + (progn + (goto-char (+ end 2)) + (setq doc (buffer-substring beg end) + end (- (match-end 0) beg) + beg (- (match-beginning 0) beg)) + (when (apropos-true-hit-doc doc) + (setq this-is-a-variable (looking-at "(def\\(var\\|const\\) ") + symbol (progn + (skip-chars-forward "(a-z") + (forward-char) + (read)) + symbol (if (consp symbol) + (nth 1 symbol) + symbol)) + (if (if this-is-a-variable + (get symbol 'variable-documentation) + (and (fboundp symbol) (apropos-safe-documentation symbol))) + (progn + (or (and (setq apropos-item (assq symbol apropos-accumulator)) + (setcar (cdr apropos-item) + (+ (cadr apropos-item) (apropos-score-doc doc)))) + (setq apropos-item (list symbol + (+ (apropos-score-symbol symbol 2) + (apropos-score-doc doc)) + nil nil) + apropos-accumulator (cons apropos-item + apropos-accumulator))) + (if apropos-match-face + (put-text-property beg end 'face apropos-match-face + doc)) + (setcar (nthcdr (if this-is-a-variable 3 2) + apropos-item) + doc)))))))))) + + + +(defun apropos-safe-documentation (function) + "Like `documentation', except it avoids calling `get_doc_string'. Will return nil instead." - (while (symbolp function) + (while (and function (symbolp function)) (setq function (if (fboundp function) - (symbol-function function) - 0))) + (symbol-function function)))) (if (eq (car-safe function) 'macro) (setq function (cdr function))) - (if (not (consp function)) + (setq function (if (byte-code-function-p function) + (if (> (length function) 4) + (aref function 4)) + (if (eq (car-safe function) 'autoload) + (nth 2 function) + (if (eq (car-safe function) 'lambda) + (if (stringp (nth 2 function)) + (nth 2 function) + (if (stringp (nth 3 function)) + (nth 3 function))))))) + (if (integerp function) nil - (if (not (memq (car function) '(lambda autoload))) - nil - (setq function (nth 2 function)) - (if (stringp function) - function - nil)))) - -(defun safe-documentation-property (symbol) - "Like documentation-property, except it avoids calling `get_doc_string'. -Will return nil instead." - (setq symbol (get symbol 'variable-documentation)) - (if (numberp symbol) - nil - symbol)) - + function)) + + +(defun apropos-print (do-keys spacing &optional text) + "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 SCORE FN-DOC VAR-DOC [PLIST-DOC WIDGET-DOC FACE-DOC GROUP-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 SPACING is non-nil, it should be a string; separate items with that string. +If non-nil TEXT is a string that will be printed as a heading." + (if (null apropos-accumulator) + (message "No apropos matches for `%s'" apropos-orig-regexp) + (setq apropos-accumulator + (sort apropos-accumulator + (lambda (a b) + ;; Don't sort by score if user can't see the score. + ;; It would be confusing. -- rms. + (if apropos-sort-by-scores + (or (> (cadr a) (cadr b)) + (and (= (cadr a) (cadr b)) + (string-lessp (car a) (car b)))) + (string-lessp (car a) (car b)))))) + (with-output-to-temp-buffer "*Apropos*" + (let ((p apropos-accumulator) + (old-buffer (current-buffer)) + symbol item) + (set-buffer standard-output) + (apropos-mode) + (if (display-mouse-p) + (insert + "If moving the mouse over text changes the text's color, " + "you can click\n" + "mouse-2 (second button from right) on that text to " + "get more information.\n")) + (insert "In this buffer, go to the name of the command, or function," + " or variable,\n" + (substitute-command-keys + "and type \\[apropos-follow] to get full documentation.\n\n")) + (if text (insert text "\n\n")) + (while (consp p) + (when (and spacing (not (bobp))) + (princ spacing)) + (setq apropos-item (car p) + symbol (car apropos-item) + p (cdr p)) + (insert-text-button (symbol-name symbol) + 'type 'apropos-symbol + ;; Can't use default, since user may have + ;; changed the variable! + ;; Just say `no' to variables containing faces! + 'face apropos-symbol-face) + (if apropos-sort-by-scores + (insert " (" (number-to-string (cadr apropos-item)) ") ")) + ;; Calculate key-bindings if we want them. + (and do-keys + (commandp symbol) + (indent-to 30 1) + (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 + (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) + item ", ")) + (insert "M-x ... RET") + (when apropos-keybinding-face + (put-text-property (- (point) 11) (- (point) 8) + 'face apropos-keybinding-face) + (put-text-property (- (point) 3) (point) + 'face apropos-keybinding-face)))) + (terpri) + (apropos-print-doc 2 + (if (commandp symbol) + 'apropos-command + (if (apropos-macrop symbol) + 'apropos-macro + 'apropos-function)) + t) + (apropos-print-doc 3 'apropos-variable t) + (apropos-print-doc 7 'apropos-group t) + (apropos-print-doc 6 'apropos-face t) + (apropos-print-doc 5 'apropos-widget t) + (apropos-print-doc 4 'apropos-plist nil)) + (setq buffer-read-only t)))) + (prog1 apropos-accumulator + (setq apropos-accumulator ()))) ; permit gc + + +(defun apropos-macrop (symbol) + "Return t if SYMBOL is a Lisp macro." + (and (fboundp symbol) + (consp (setq symbol + (symbol-function symbol))) + (or (eq (car symbol) 'macro) + (if (eq (car symbol) 'autoload) + (memq (nth 4 symbol) + '(macro t)))))) + + +(defun apropos-print-doc (i type do-keys) + (if (stringp (setq i (nth i apropos-item))) + (progn + (insert " ") + (insert-text-button (button-type-get type 'apropos-label) + 'type type + ;; Can't use the default button face, since + ;; user may have changed the variable! + ;; Just say `no' to variables containing faces! + 'face apropos-label-face + 'apropos-symbol (car apropos-item)) + (insert ": ") + (insert (if do-keys (substitute-command-keys i) i)) + (or (bolp) (terpri))))) + + +(defun apropos-follow () + "Invokes any button at point, otherwise invokes the nearest label button." + (interactive) + (button-activate + (or (apropos-next-label-button (line-beginning-position)) + (error "There is nothing to follow here")))) + + +(defun apropos-describe-plist (symbol) + "Display a pretty listing of SYMBOL's plist." + (help-setup-xref (list 'apropos-describe-plist symbol) (interactive-p)) + (with-output-to-temp-buffer (help-buffer) + (set-buffer standard-output) + (princ "Symbol ") + (prin1 symbol) + (princ "'s plist is\n (") + (if apropos-symbol-face + (put-text-property (+ (point-min) 7) (- (point) 14) + 'face apropos-symbol-face)) + (insert (apropos-format-plist symbol "\n ")) + (princ ")") + (print-help-return-message))) + + +(provide 'apropos) + +;;; arch-tag: d56fa2ac-e56b-4ce3-84ff-852f9c0dc66e ;;; apropos.el ends here