Mercurial > emacs
view lisp/apropos.el @ 10841:88926963f1ae
Clean up doc strings.
Remove cl.el and emacs-vers.el dependencies.
author | Thien-Thi Nguyen <ttn@gnuvola.org> |
---|---|
date | Sun, 26 Feb 1995 21:05:42 +0000 |
parents | 1d1c5ea9eb86 |
children | 509f78000a59 |
line wrap: on
line source
;;; apropos.el --- faster apropos commands. ;; Copyright (C) 1989, 1994 Free Software Foundation, Inc. ;; Author: Joe Wells <jbw@bigbird.bu.edu> ;; Keywords: help ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; 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. ;;; Commentary: ;; The ideas for this package were derived from the C code in ;; src/keymap.c and elsewhere. The functions in this file should ;; always be byte-compiled for speed. Someone should rewrite this in ;; C (as part of src/keymap.c) for speed. ;; The idea for super-apropos is based on the original implementation ;; by Lynn Slater <lrs@esl.com>. ;; History: ;; 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. ;; Added apropos-do-all option. ;; Added fast-command-apropos. ;; Changed doc strings to comments for helping functions. ;; Made doc file buffer read-only, buried it. ;; Only call substitute-command-keys if do-all set. ;;; 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.") ;;;###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. 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.") (defvar apropos-files-scanned) ;;;###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. 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 apropos-files-scanned) (setq apropos-accumulate (super-apropos-check-doc-file apropos-regexp)) (if do-all (mapatoms 'super-apropos-accumulate)) (if (null apropos-accumulate) (message "No apropos matches for `%s'" apropos-regexp) (with-output-to-temp-buffer "*Help*" (setq apropos-accumulate (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 (get-buffer-create " apropos-temp")) type symbol doc sym-list) (unwind-protect (save-excursion (set-buffer doc-buffer) (buffer-disable-undo) (erase-buffer) (insert-file-contents doc-file) (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)))) (kill-buffer doc-buffer)) sym-list)) (defun super-apropos-check-elc-file (regexp file) (let* ((doc-buffer (get-buffer-create " apropos-temp")) symbol doc length beg end this-is-a-variable) (unwind-protect (save-excursion (set-buffer doc-buffer) (buffer-disable-undo) (erase-buffer) (insert-file-contents file) (while (search-forward "\n#@" nil t) ;; Read the comment length, and advance over it. (setq length (read (current-buffer))) (setq beg (point)) (setq end (+ (point) length 1)) (if (re-search-forward regexp end t) (progn (setq this-is-a-variable (save-excursion (goto-char end) (looking-at "(defvar\\|(defconst")) symbol (save-excursion (goto-char end) (skip-chars-forward "(a-z") (forward-char 1) (read doc-buffer)) symbol (if (consp symbol) (nth 1 symbol) symbol) doc (buffer-substring (1+ beg) (- end 2)) apropos-item (assq symbol apropos-accumulate)) (and (if this-is-a-variable (documentation-property symbol 'variable-documentation) (and (fboundp symbol) (documentation symbol))) (or apropos-item (setq apropos-item (list symbol nil nil) apropos-accumulate (cons apropos-item apropos-accumulate))) (setcar (nthcdr (if this-is-a-variable 2 1) apropos-item) doc)))) (goto-char end))) (kill-buffer doc-buffer)) apropos-accumulate)) ;; 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) (let (doc) (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)))) ((or (consp (setq doc (safe-documentation symbol))) (consp (setq doc (safe-documentation-property symbol)))) ;; This symbol's doc is stored in a file. ;; Scan the file if we have not scanned it before. (let ((file (car doc))) (or (member file apropos-files-scanned) (progn (setq apropos-files-scanned (cons file apropos-files-scanned)) (super-apropos-check-elc-file apropos-regexp file))))) (t (and (stringp (setq doc (safe-documentation symbol))) (setq apropos-fn-doc doc) (string-match apropos-regexp apropos-fn-doc) (setcar (cdr (apropos-get-accum-item symbol)) apropos-fn-doc)) (and (stringp (setq doc (safe-documentation-property symbol))) (setq apropos-var-doc doc) (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))) matches) ;; 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) (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'. Will return nil instead." (while (symbolp function) (setq function (if (fboundp function) (symbol-function function) 0))) (if (eq (car-safe function) 'macro) (setq function (cdr function))) (if (byte-code-function-p function) (if (> (length function) 4) (aref function 4)) (if (not (consp 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)) ;;; apropos.el ends here