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
))
96 ;; Variables bound by super-apropos and used by its subroutines.
97 ;; It would be good to say what each one is for, but I don't know -- rms.
99 (defvar apropos-var-doc
)
100 (defvar apropos-fn-doc
)
101 (defvar apropos-accumulate
)
102 (defvar apropos-regexp
103 "Within `super-apropos', this holds the REGEXP argument.")
104 (defvar apropos-files-scanned
)
107 (defun super-apropos (regexp &optional do-all
)
108 "Show symbols whose names/documentation contain matches for REGEXP.
109 If optional argument DO-ALL is non-nil (prefix argument if interactive),
110 or if `apropos-do-all' is non-nil, does more (time-consuming) work such as
111 showing key bindings and documentation that is not stored in the documentation
114 Returns list of symbols and documentation found."
115 (interactive "sSuper Apropos: \nP")
116 (setq do-all
(or apropos-do-all do-all
))
117 (let ((apropos-regexp regexp
)
118 apropos-accumulate apropos-fn-doc apropos-var-doc apropos-item
119 apropos-files-scanned
)
120 (setq apropos-accumulate
121 (super-apropos-check-doc-file apropos-regexp
))
122 (if do-all
(mapatoms 'super-apropos-accumulate
))
123 (if (null apropos-accumulate
)
124 (message "No apropos matches for `%s'" apropos-regexp
)
125 (with-output-to-temp-buffer "*Help*"
126 (setq apropos-accumulate
127 (apropos-print-matches apropos-accumulate nil t do-all
))))
130 ;; Finds all documentation related to REGEXP in internal-doc-file-name.
131 ;; Returns an alist of form ((symbol fn-doc var-doc) ...).
133 (defun super-apropos-check-doc-file (regexp)
134 (let* ((doc-file (concat doc-directory internal-doc-file-name
))
135 (doc-buffer (get-buffer-create " apropos-temp"))
136 type symbol doc sym-list
)
139 (set-buffer doc-buffer
)
140 (buffer-disable-undo)
142 (insert-file-contents doc-file
)
143 (while (re-search-forward regexp nil t
)
144 (search-backward "\C-_")
145 (setq type
(if (eq ?F
(char-after (1+ (point))))
146 1 ;function documentation
147 2) ;variable documentation
151 doc
(buffer-substring
154 (if (search-forward "\C-_" nil
'move
)
157 apropos-item
(assq symbol sym-list
))
159 (and (fboundp symbol
) (documentation symbol
))
160 (documentation-property symbol
'variable-documentation
))
162 (setq apropos-item
(list symbol nil nil
)
163 sym-list
(cons apropos-item sym-list
)))
164 (setcar (nthcdr type apropos-item
) doc
))))
165 (kill-buffer doc-buffer
))
168 (defun super-apropos-check-elc-file (regexp file
)
169 (let* ((doc-buffer (get-buffer-create " apropos-temp"))
170 symbol doc length beg end this-is-a-variable
)
173 (set-buffer doc-buffer
)
174 (buffer-disable-undo)
176 (insert-file-contents file
)
177 (while (search-forward "\n#@" nil t
)
178 ;; Read the comment length, and advance over it.
179 (setq length
(read (current-buffer)))
181 (setq end
(+ (point) length
1))
182 (if (re-search-forward regexp end t
)
184 (setq this-is-a-variable
(save-excursion
186 (looking-at "(defvar\\|(defconst"))
187 symbol
(save-excursion
189 (skip-chars-forward "(a-z")
192 symbol
(if (consp symbol
)
195 doc
(buffer-substring (1+ beg
) (- end
2))
196 apropos-item
(assq symbol apropos-accumulate
))
197 (and (if this-is-a-variable
198 (documentation-property symbol
'variable-documentation
)
199 (and (fboundp symbol
) (documentation symbol
)))
201 (setq apropos-item
(list symbol nil nil
)
202 apropos-accumulate
(cons apropos-item
203 apropos-accumulate
)))
204 (setcar (nthcdr (if this-is-a-variable
2 1)
208 (kill-buffer doc-buffer
))
211 ;; This is passed as the argument to map-atoms, so it is called once for every
212 ;; symbol in obarray. Takes one argument SYMBOL, and finds any memory-resident
213 ;; documentation on that symbol if it matches a variable regexp.
215 (defun super-apropos-accumulate (symbol)
217 (cond ((string-match apropos-regexp
(symbol-name symbol
))
218 (setq apropos-item
(apropos-get-accum-item symbol
))
219 (setcar (cdr apropos-item
)
220 (or (safe-documentation symbol
)
221 (nth 1 apropos-item
)))
222 (setcar (nthcdr 2 apropos-item
)
223 (or (safe-documentation-property symbol
)
224 (nth 2 apropos-item
))))
225 ((or (consp (setq doc
(safe-documentation symbol
)))
226 (consp (setq doc
(safe-documentation-property symbol
))))
227 ;; This symbol's doc is stored in a file.
228 ;; Scan the file if we have not scanned it before.
229 (let ((file (car doc
)))
230 (or (member file apropos-files-scanned
)
232 (setq apropos-files-scanned
233 (cons file apropos-files-scanned
))
234 (super-apropos-check-elc-file apropos-regexp file
)))))
236 (and (stringp (setq doc
(safe-documentation symbol
)))
237 (setq apropos-fn-doc doc
)
238 (string-match apropos-regexp apropos-fn-doc
)
239 (setcar (cdr (apropos-get-accum-item symbol
)) apropos-fn-doc
))
240 (and (stringp (setq doc
(safe-documentation-property symbol
)))
241 (setq apropos-var-doc doc
)
242 (string-match apropos-regexp apropos-var-doc
)
243 (setcar (nthcdr 2 (apropos-get-accum-item symbol
))
247 ;; Prints the symbols and documentation in alist MATCHES of form ((symbol
248 ;; fn-doc var-doc) ...). Uses optional argument REGEXP to speed up searching
249 ;; for keybindings. The names of all symbols in MATCHES must match REGEXP.
250 ;; Displays in the buffer pointed to by standard-output. Optional argument
251 ;; SPACING means put blank lines in between each symbol's documentation.
252 ;; Optional argument DO-ALL means do more time-consuming work, specifically,
253 ;; consulting key bindings. Should only be called within a
254 ;; with-output-to-temp-buffer.
256 (defun apropos-print-matches (matches &optional regexp
257 spacing do-all no-header
)
258 (setq matches
(sort matches
(function
260 (string-lessp (car a
) (car b
))))))
262 (old-buffer (current-buffer))
263 item keys-done symbol tem
)
265 (set-buffer standard-output
)
266 (or matches
(princ "No matches found."))
271 (or (not spacing
) (bobp) (terpri))
272 (princ symbol
) ;print symbol name
273 ;; don't calculate key-bindings unless needed
274 (cond ((and do-all
(commandp symbol
) (not keys-done
))
276 (set-buffer old-buffer
)
277 (apropos-match-keys matches regexp
))
280 (or (setq tem
(nthcdr 3 item
))
284 (princ (mapconcat 'key-description tem
", "))
285 (princ "(not bound to any keys)"))))
287 (cond ((setq tem
(nth 1 item
))
288 (let ((substed (if do-all
(substitute-command-keys tem
) tem
)))
291 (princ " Function: ")
292 (if (> (length substed
) 67)
296 (cond ((setq tem
(nth 2 item
))
297 (let ((substed (if do-all
(substitute-command-keys tem
) tem
)))
300 (princ " Variable: ")
301 (if (> (length substed
) 67)
304 (or (bolp) (terpri)))
308 ;; Find key bindings for symbols that are cars in ALIST. Optionally, first
309 ;; match the symbol name against REGEXP. Modifies ALIST in place. Each key
310 ;; binding is added as a string to the end of the list in ALIST whose car is
311 ;; the corresponding symbol. The pointer to ALIST is returned.
313 (defun apropos-match-keys (alist &optional regexp
)
314 (let* ((current-local-map (current-local-map))
315 ;; Get a list of the top-level maps now active.
317 (if overriding-local-map
318 (list overriding-local-map
(current-global-map))
319 (append (current-minor-mode-maps)
320 (if current-local-map
321 (list current-local-map
(current-global-map))
322 (list (current-global-map))))))
323 ;; Turn that into a list of all the maps including submaps.
324 (maps (apply 'append
(mapcar 'accessible-keymaps top-maps
)))
325 map
;map we are now inspecting
326 sequence
;key sequence to reach map
327 i
;index into vector map
328 command
;what is bound to current keys
329 key
;last key to reach command
330 local
;local binding for sequence + key
331 item
) ;symbol data item in alist
332 ;; examine all reachable keymaps
334 (setq map
(cdr (car maps
))
335 sequence
(car (car maps
)) ;keys to reach this map
337 ;; Skip the leading `keymap', doc string, etc.
338 (if (eq (car map
) 'keymap
)
339 (setq map
(cdr map
)))
340 (while (stringp (car-safe map
))
341 (setq map
(cdr map
)))
344 (cond ((consp (car map
))
345 (setq command
(cdr (car map
))
347 ;; Skip any menu prompt and help string in this key binding.
348 (while (and (consp command
) (stringp (car command
)))
349 (setq command
(cdr command
)))
350 ;; Skip any cached equivalent key.
352 (consp (car command
))
353 (setq command
(cdr command
)))
354 ;; if is a symbol, and matches optional regexp, and is a car
355 ;; in alist, and is not shadowed by a different local binding,
357 (and (symbolp command
)
359 (string-match regexp
(symbol-name command
))
361 (setq item
(assq command alist
))
362 (if (or (vectorp sequence
) (not (integerp key
)))
363 (setq key
(vconcat sequence
(vector key
)))
364 (setq key
(concat sequence
(char-to-string key
))))
365 ;; checking if shadowed by local binding.
366 ;; either no local map, no local binding, or runs off the
367 ;; binding tree (number), or is the same binding
368 (or (not current-local-map
)
369 (not (setq local
(lookup-key current-local-map key
)))
372 ;; check if this binding is already recorded
373 ;; (this can happen due to inherited keymaps)
374 (not (member key
(nthcdr 3 item
)))
375 ;; add this key binding to the item in alist
376 (nconc item
(cons key nil
))))
380 (len (length (car map
))))
382 (setq command
(aref vec i
))
384 ;; Skip any menu prompt in this key binding.
385 (and (consp command
) (symbolp (cdr command
))
386 (setq command
(cdr command
)))
387 ;; This is the same as the code in the previous case.
388 (and (symbolp command
)
390 (string-match regexp
(symbol-name command
))
392 (setq item
(assq command alist
))
393 (if (or (vectorp sequence
) (not (integerp key
)))
394 (setq key
(vconcat sequence
(vector key
)))
395 (setq key
(concat sequence
(char-to-string key
))))
396 ;; checking if shadowed by local binding.
397 ;; either no local map, no local binding, or runs off the
398 ;; binding tree (number), or is the same binding
399 (or (not current-local-map
)
400 (not (setq local
(lookup-key current-local-map key
)))
403 ;; check if this binding is already recorded
404 ;; (this can happen due to inherited keymaps)
405 (not (member key
(nthcdr 3 item
)))
406 ;; add this key binding to the item in alist
407 (nconc item
(cons key nil
)))
409 (setq map
(cdr map
)))))
412 ;; Get an alist item in alist apropos-accumulate whose car is SYMBOL. Creates
413 ;; the item if not already present. Modifies apropos-accumulate in place.
415 (defun apropos-get-accum-item (symbol)
416 (or (assq symbol apropos-accumulate
)
418 (setq apropos-accumulate
419 (cons (list symbol nil nil
) apropos-accumulate
))
420 (assq symbol apropos-accumulate
))))
422 (defun safe-documentation (function)
423 "Like documentation, except it avoids calling `get_doc_string'.
424 Will return nil instead."
425 (while (symbolp function
)
426 (setq function
(if (fboundp function
)
427 (symbol-function function
)
429 (if (eq (car-safe function
) 'macro
)
430 (setq function
(cdr function
)))
431 (if (byte-code-function-p function
)
432 (if (> (length function
) 4)
434 (if (not (consp function
))
436 (if (not (memq (car function
) '(lambda autoload
)))
438 (setq function
(nth 2 function
))
439 (if (stringp function
)
443 (defun safe-documentation-property (symbol)
444 "Like documentation-property, except it avoids calling `get_doc_string'.
445 Will return nil instead."
446 (setq symbol
(get symbol
'variable-documentation
))
451 ;;; apropos.el ends here