1 ;;; apropos.el --- faster apropos commands.
3 ;; Copyright (C) 1989, 1994 Free Software Foundation, Inc.
5 ;; Author: Joe Wells <jbw@bigbird.bu.edu>
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to
22 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
26 ;; The ideas for this package were derived from the C code in
27 ;; src/keymap.c and elsewhere. The functions in this file should
28 ;; always be byte-compiled for speed. Someone should rewrite this in
29 ;; C (as part of src/keymap.c) for speed.
31 ;; The idea for super-apropos is based on the original implementation
32 ;; by Lynn Slater <lrs@esl.com>.
35 ;; Fixed bug, current-local-map can return nil.
36 ;; Change, doesn't calculate key-bindings unless needed.
37 ;; Added super-apropos capability, changed print functions.
38 ;; Made fast-apropos and super-apropos share code.
39 ;; Sped up fast-apropos again.
40 ;; Added apropos-do-all option.
41 ;; Added fast-command-apropos.
42 ;; Changed doc strings to comments for helping functions.
43 ;; Made doc file buffer read-only, buried it.
44 ;; Only call substitute-command-keys if do-all set.
48 (defvar apropos-do-all nil
49 "*Whether `apropos' and `super-apropos' should do everything that they can.
50 Makes them run 2 or 3 times slower. Set this non-nil if you have a fast
54 (defun apropos (regexp &optional do-all pred no-header)
55 "Show all symbols whose names contain matches for REGEXP.
56 If optional argument DO-ALL is non-nil (prefix argument if interactive),
57 or if `apropos-do-all' is non-nil, does more (time-consuming) work such as
58 showing key bindings. Optional argument PRED is called with each symbol, and
59 if it returns nil, the symbol is not shown.
61 Optional argument NO-HEADER means don't print `Function:' or `Variable:'
64 Returns list of symbols and documentation found."
65 (interactive "sApropos (regexp): \nP")
66 (setq do-all (or apropos-do-all do-all))
67 (let ((apropos-accumulate (apropos-internal regexp pred)))
68 (if (null apropos-accumulate)
69 (message "No apropos matches for `%s'" regexp)
70 (apropos-get-doc apropos-accumulate)
71 (with-output-to-temp-buffer "*Help*"
72 (apropos-print-matches apropos-accumulate regexp nil
76 ;; Takes LIST of symbols and adds documentation. Modifies LIST in place.
77 ;; Resulting alist is of form ((symbol fn-doc var-doc) ...). Should only be
78 ;; called by apropos. Returns LIST.
80 (defun apropos-get-doc (list)
82 fn-doc var-doc symbol)
85 fn-doc (and (fboundp symbol)
86 (documentation symbol))
87 var-doc (documentation-property symbol 'variable-documentation)
89 (substring fn-doc 0 (string-match "\n" fn-doc)))
91 (substring var-doc 0 (string-match "\n" var-doc))))
92 (setcar p (list symbol fn-doc var-doc))
97 (defun super-apropos (regexp &optional do-all)
98 "Show symbols whose names/documentation contain matches for REGEXP.
99 If optional argument DO-ALL is non-nil (prefix argument if interactive),
100 or if `apropos-do-all' is non-nil, does more (time-consuming) work such as
101 showing key bindings and documentation that is not stored in the documentation
104 Returns list of symbols and documentation found."
105 (interactive "sSuper Apropos: \nP")
106 (setq do-all (or apropos-do-all do-all))
107 (let (apropos-accumulate fn-doc var-doc item)
108 (setq apropos-accumulate (super-apropos-check-doc-file regexp))
109 (if (null apropos-accumulate)
110 (message "No apropos matches for `%s'" regexp)
111 (if do-all (mapatoms 'super-apropos-accumulate))
112 (with-output-to-temp-buffer "*Help*"
113 (apropos-print-matches apropos-accumulate nil t do-all)))
116 ;; Finds all documentation related to REGEXP in internal-doc-file-name.
117 ;; Returns an alist of form ((symbol fn-doc var-doc) ...).
119 (defun super-apropos-check-doc-file (regexp)
120 (let* ((doc-file (concat doc-directory internal-doc-file-name))
122 ;; Force fundamental mode for the DOC file.
123 (let (auto-mode-alist)
124 (find-file-noselect doc-file t)))
125 type symbol doc sym-list)
127 (set-buffer doc-buffer)
128 ;; a user said he might accidentally edit the doc file
129 (setq buffer-read-only t)
130 (bury-buffer doc-buffer)
131 (goto-char (point-min))
132 (while (re-search-forward regexp nil t)
133 (search-backward "\C-_")
134 (setq type (if (eq ?F (char-after (1+ (point))))
135 1 ;function documentation
136 2) ;variable documentation
140 doc (buffer-substring
143 (if (search-forward "\C-_" nil 'move)
146 item (assq symbol sym-list))
148 (and (fboundp symbol) (documentation symbol))
149 (documentation-property symbol 'variable-documentation))
151 (setq item (list symbol nil nil)
152 sym-list (cons item sym-list)))
153 (setcar (nthcdr type item) doc))))
156 ;; This is passed as the argument to map-atoms, so it is called once for every
157 ;; symbol in obarray. Takes one argument SYMBOL, and finds any memory-resident
158 ;; documentation on that symbol if it matches a variable regexp. WARNING: this
159 ;; function depends on the symbols fn-doc var-doc regexp and item being bound
160 ;; correctly when it is called!"
162 (defun super-apropos-accumulate (symbol)
163 (cond ((string-match regexp (symbol-name symbol))
164 (setq item (apropos-get-accum-item symbol))
165 (setcar (cdr item) (or (safe-documentation symbol)
167 (setcar (nthcdr 2 item) (or (safe-documentation-property symbol)
170 (and (setq fn-doc (safe-documentation symbol))
171 (string-match regexp fn-doc)
172 (setcar (cdr (apropos-get-accum-item symbol)) fn-doc))
173 (and (setq var-doc (safe-documentation-property symbol))
174 (string-match regexp var-doc)
175 (setcar (nthcdr 2 (apropos-get-accum-item symbol)) var-doc))))
178 ;; Prints the symbols and documentation in alist MATCHES of form ((symbol
179 ;; fn-doc var-doc) ...). Uses optional argument REGEXP to speed up searching
180 ;; for keybindings. The names of all symbols in MATCHES must match REGEXP.
181 ;; Displays in the buffer pointed to by standard-output. Optional argument
182 ;; SPACING means put blank lines in between each symbol's documentation.
183 ;; Optional argument DO-ALL means do more time-consuming work, specifically,
184 ;; consulting key bindings. Should only be called within a
185 ;; with-output-to-temp-buffer.
187 (defun apropos-print-matches (matches &optional regexp
188 spacing do-all no-header)
189 (setq matches (sort matches (function
191 (string-lessp (car a) (car b))))))
193 (old-buffer (current-buffer))
194 item keys-done symbol tem)
196 (set-buffer standard-output)
197 (or matches (princ "No matches found."))
202 (or (not spacing) (bobp) (terpri))
203 (princ symbol) ;print symbol name
204 ;; don't calculate key-bindings unless needed
205 (cond ((and do-all (commandp symbol) (not keys-done))
207 (set-buffer old-buffer)
208 (apropos-match-keys matches regexp))
211 (or (setq tem (nthcdr 3 item))
215 (princ (mapconcat 'key-description tem ", "))
216 (princ "(not bound to any keys)"))))
218 (cond ((setq tem (nth 1 item))
219 (let ((substed (if do-all (substitute-command-keys tem) tem)))
222 (princ " Function: ")
223 (if (> (length substed) 67)
227 (cond ((setq tem (nth 2 item))
228 (let ((substed (if do-all (substitute-command-keys tem) tem)))
231 (princ " Variable: ")
232 (if (> (length substed) 67)
235 (or (bolp) (terpri)))
239 ;; Find key bindings for symbols that are cars in ALIST. Optionally, first
240 ;; match the symbol name against REGEXP. Modifies ALIST in place. Each key
241 ;; binding is added as a string to the end of the list in ALIST whose car is
242 ;; the corresponding symbol. The pointer to ALIST is returned.
244 (defun apropos-match-keys (alist &optional regexp)
245 (let* ((current-local-map (current-local-map))
246 (maps (append (and current-local-map
247 (accessible-keymaps current-local-map))
248 (accessible-keymaps (current-global-map))))
249 map ;map we are now inspecting
250 sequence ;key sequence to reach map
251 i ;index into vector map
252 command ;what is bound to current keys
253 key ;last key to reach command
254 local ;local binding for sequence + key
255 item) ;symbol data item in alist
256 ;; examine all reachable keymaps
258 (setq map (cdr (car maps))
259 sequence (car (car maps)) ;keys to reach this map
261 ;; Skip the leading `keymap', doc string, etc.
262 (if (eq (car map) 'keymap)
263 (setq map (cdr map)))
264 (while (stringp (car-safe map))
265 (setq map (cdr map)))
267 (cond ((consp (car map))
268 (setq command (cdr (car map))
270 ;; Skip any menu prompt in this key binding.
271 (and (consp command) (symbolp (cdr command))
272 (setq command (cdr command)))
273 ;; if is a symbol, and matches optional regexp, and is a car
274 ;; in alist, and is not shadowed by a different local binding,
276 (and (symbolp command)
278 (string-match regexp (symbol-name command))
280 (setq item (assq command alist))
281 (if (or (vectorp sequence) (not (integerp key)))
282 (setq key (vconcat sequence (vector key)))
283 (setq key (concat sequence (char-to-string key))))
284 ;; checking if shadowed by local binding.
285 ;; either no local map, no local binding, or runs off the
286 ;; binding tree (number), or is the same binding
287 (or (not current-local-map)
288 (not (setq local (lookup-key current-local-map key)))
291 ;; check if this binding is already recorded
292 ;; (this can happen due to inherited keymaps)
293 (not (member key (nthcdr 3 item)))
294 ;; add this key binding to the item in alist
295 (nconc item (cons key nil))))
299 (len (length (car map))))
301 (setq command (aref vec i))
303 ;; Skip any menu prompt in this key binding.
304 (and (consp command) (symbolp (cdr command))
305 (setq command (cdr command)))
306 ;; This is the same as the code in the previous case.
307 (and (symbolp command)
309 (string-match regexp (symbol-name command))
311 (setq item (assq command alist))
312 (if (or (vectorp sequence) (not (integerp key)))
313 (setq key (vconcat sequence (vector key)))
314 (setq key (concat sequence (char-to-string key))))
315 ;; checking if shadowed by local binding.
316 ;; either no local map, no local binding, or runs off the
317 ;; binding tree (number), or is the same binding
318 (or (not current-local-map)
319 (not (setq local (lookup-key current-local-map key)))
322 ;; check if this binding is already recorded
323 ;; (this can happen due to inherited keymaps)
324 (not (member key (nthcdr 3 item)))
325 ;; add this key binding to the item in alist
326 (nconc item (cons key nil)))
328 (setq map (cdr map)))))
331 ;; Get an alist item in alist apropos-accumulate whose car is SYMBOL. Creates
332 ;; the item if not already present. Modifies apropos-accumulate in place.
334 (defun apropos-get-accum-item (symbol)
335 (or (assq symbol apropos-accumulate)
337 (setq apropos-accumulate
338 (cons (list symbol nil nil) apropos-accumulate))
339 (assq symbol apropos-accumulate))))
341 (defun safe-documentation (function)
342 "Like documentation, except it avoids calling `get_doc_string'.
343 Will return nil instead."
344 (while (symbolp function)
345 (setq function (if (fboundp function)
346 (symbol-function function)
348 (if (eq (car-safe function) 'macro)
349 (setq function (cdr function)))
350 (if (not (consp function))
352 (if (not (memq (car function) '(lambda autoload)))
354 (setq function (nth 2 function))
355 (if (stringp function)
359 (defun safe-documentation-property (symbol)
360 "Like documentation-property, except it avoids calling `get_doc_string'.
361 Will return nil instead."
362 (setq symbol (get symbol 'variable-documentation))
367 ;;; apropos.el ends here