view lisp/apropos.el @ 9973:1d5a908f201e

(access_keymap): Use type test macros.

;;; apropos.el --- faster apropos commands.

;; Copyright (C) 1989, 1994 Free Software Foundation, Inc.

;; Author: Joe Wells <[e-mail]>
;; 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 <[e-mail]>.

;; 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))

;;;###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-accumulate fn-doc var-doc item)
    (setq apropos-accumulate (super-apropos-check-doc-file regexp))
    (if (null apropos-accumulate)
	(message "No apropos matches for `%s'" 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))))
	      item (assq symbol sym-list))
	(and (if (= type 1)
		 (and (fboundp symbol) (documentation symbol))
	       (documentation-property symbol 'variable-documentation))
	     (or item
		 (setq item (list symbol nil nil)
		       sym-list (cons item sym-list)))
	     (setcar (nthcdr type 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.  WARNING: this
;; function depends on the symbols fn-doc var-doc regexp and item being bound
;; correctly when it is called!"

(defun super-apropos-accumulate (symbol)
  (cond ((string-match regexp (symbol-name symbol))
	 (setq item (apropos-get-accum-item symbol))
	 (setcar (cdr item) (or (safe-documentation symbol)
				(nth 1 item)))
	 (setcar (nthcdr 2 item) (or (safe-documentation-property symbol)
				     (nth 2 item))))
	(t
	 (and (setq fn-doc (safe-documentation symbol))
	      (string-match regexp fn-doc)
	      (setcar (cdr (apropos-get-accum-item symbol)) fn-doc))
	 (and (setq var-doc (safe-documentation-property symbol))
	      (string-match regexp var-doc)
	      (setcar (nthcdr 2 (apropos-get-accum-item symbol)) 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))
	 (maps (append (and current-local-map
			    (accessible-keymaps current-local-map))
		       (accessible-keymaps (current-global-map))))
	 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 in this key binding.
	       (and (consp command) (symbolp (cdr 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 (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