Mercurial > emacs

comparison lisp/apropos.el @ 12498:9fb6a9b6658b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Restructured, largely rewritten and extended. (apropos-use-faces, apropos-local-map): New variables. (apropos-command): New name for `command-apropos' no longer in help.el. (apropos-value): New command. (apropos-documentation): New name for `super-apropos' (apropos-follow, apropos-mouse-follow): New commands for hypertext. (apropos-describe-plist): New function.
author Karl Heuer <kwzh@gnu.org>
date Fri, 07 Jul 1995 18:53:58 +0000
parents 509f78000a59
children d194c63cb75c
comparison
equal deleted inserted replaced
12497:a48e520afeb6 12498:9fb6a9b6658b
1 ;;; apropos.el --- faster apropos commands. 1 ;;; apropos.el --- apropos commands for users and programmers.
2 2
3 ;; Copyright (C) 1989, 1994 Free Software Foundation, Inc. 3 ;; Copyright (C) 1989, 1994, 1995 Free Software Foundation, Inc.
4 4
5 ;; Author: Joe Wells <jbw@bigbird.bu.edu> 5 ;; Author: Joe Wells <jbw@bigbird.bu.edu>
6 ;; Rewritten: Daniel.Pfeiffer@Informatik.START.dbp.de, fax (+49 69) 7588-2389
6 ;; Keywords: help 7 ;; Keywords: help
7 8
8 ;; This file is part of GNU Emacs. 9 ;; This file is part of GNU Emacs.
9 10
10 ;; GNU Emacs is free software; you can redistribute it and/or modify 11 ;; GNU Emacs is free software; you can redistribute it and/or modify
33 34
34 ;; History: 35 ;; History:
35 ;; Fixed bug, current-local-map can return nil. 36 ;; Fixed bug, current-local-map can return nil.
36 ;; Change, doesn't calculate key-bindings unless needed. 37 ;; Change, doesn't calculate key-bindings unless needed.
37 ;; Added super-apropos capability, changed print functions. 38 ;; Added super-apropos capability, changed print functions.
38 ;; Made fast-apropos and super-apropos share code. 39 ;;; Made fast-apropos and super-apropos share code.
39 ;; Sped up fast-apropos again. 40 ;;; Sped up fast-apropos again.
40 ;; Added apropos-do-all option. 41 ;; Added apropos-do-all option.
41 ;; Added fast-command-apropos. 42 ;;; Added fast-command-apropos.
42 ;; Changed doc strings to comments for helping functions. 43 ;; Changed doc strings to comments for helping functions.
43 ;; Made doc file buffer read-only, buried it. 44 ;;; Made doc file buffer read-only, buried it.
44 ;; Only call substitute-command-keys if do-all set. 45 ;; Only call substitute-command-keys if do-all set.
45 46
47 ;; Optionally use faces to make the output more legible.
48 ;; Differentiate between command and function.
49 ;; Apropos-command (ex command-apropos) does cmd and optionally user var.
50 ;; Apropos shows all 3 aspects of symbols (fn, var and plist)
51 ;; Apropos-documentation (ex super-apropos) now finds all it should.
52 ;; New apropos-value snoops through all values and optionally plists.
53 ;; Reading DOC file doesn't load nroff.
54 ;; Added hypertext following of documentation, mouse-2 on variable gives value
55 ;; from buffer in active window.
56
46 ;;; Code: 57 ;;; Code:
47 58
59 ;; I see a degradation of maybe 10-20% only.
48 (defvar apropos-do-all nil 60 (defvar apropos-do-all nil
49 "*Whether `apropos' and `super-apropos' should do everything that they can. 61 "*Whether the apropos commands should do more.
50 Makes them run 2 or 3 times slower. Set this non-nil if you have a fast 62 Slows them down more or less. Set this non-nil if you have a fast machine.")
51 machine.") 63
52 64
53 (defun apropos-worthy-symbol-p (symbol) 65 (defvar apropos-use-faces window-system
54 "Return non-nil if SYMBOL is not worthless." 66 "*Whether the apropos commands display output using bold and italic.
55 (or (fboundp symbol) 67 This looks good, but slows down the commands several times.")
56 (boundp symbol) 68
57 (symbol-plist symbol))) 69
58 70 (defvar apropos-local-map
71 (let ((map (make-sparse-keymap)))
72 (define-key map "\C-m" 'apropos-follow)
73 (define-key map [mouse-2] 'apropos-mouse-follow)
74 (define-key map [down-mouse-2] nil)
75 map)
76 "Local map active when displaying apropos output.")
77
78
79
80 ;;;###autoload (fset 'command-apropos 'apropos-command)
59 ;;;###autoload 81 ;;;###autoload
60 (defun apropos (regexp &optional do-all pred no-header) 82 (defun apropos-command (regexp &optional do-all)
61 "Show all symbols whose names contain matches for REGEXP. 83 "Shows commands (interactively callable functions) that match REGEXP.
62 If optional argument DO-ALL is non-nil (prefix argument if interactive), 84 With optional prefix ARG or if `apropos-do-all' is non-nil, also show
63 or if `apropos-do-all' is non-nil, does more (time-consuming) work such as 85 variables."
64 showing key bindings. Optional argument PRED is called with each symbol, and 86 (interactive (list (read-string (concat "Apropos command "
65 if it returns nil, the symbol is not shown. If PRED is nil, the 87 (if (or current-prefix-arg
66 default predicate is that the symbol has a value, function definition 88 apropos-do-all)
67 or property list. 89 "or variable ")
68 90 "(regexp): "))
69 Optional argument NO-HEADER means don't print `Function:' or `Variable:' 91 (or current-prefix-arg apropos-do-all)))
70 in the output. 92 (let ((message
71 93 (let ((standard-output (get-buffer-create "*Help*")))
94 (print-help-return-message 'identity))))
95 (if (apropos-print
96 regexp
97 (apropos-internal regexp
98 (if do-all
99 (lambda (x) (or (commandp x)
100 (user-variable-p x)))
101 'commandp))
102 t
103 (lambda (p)
104 (let (doc symbol)
105 (while p
106 (setcar p (list
107 (setq symbol (car p))
108 (if (commandp symbol)
109 (if (setq doc (documentation symbol t))
110 (substring doc 0 (string-match "\n" doc))
111 "(not documented)"))
112 (and do-all
113 (user-variable-p symbol)
114 (if (setq doc (documentation-property
115 symbol 'variable-documentation t))
116 (substring doc 0
117 (string-match "\n" doc))))))
118 (setq p (cdr p)))))
119 nil)
120 (and message (message message)))))
121
122
123
124 ;;;###autoload
125 (defun apropos (regexp &optional do-all)
126 "Show all symbols whose names match REGEXP.
127 With optional prefix ARG or if `apropos-do-all' is non-nil, also show key
128 bindings, which is a little more time-consuming.
72 Returns list of symbols and documentation found." 129 Returns list of symbols and documentation found."
73 (interactive "sApropos (regexp): \nP") 130 (interactive "sApropos symbol (regexp): \nP")
131 (apropos-print
132 regexp (apropos-internal regexp)
133 (or apropos-do-all do-all)
134 (lambda (p)
135 (let (symbol doc)
136 (while p
137 (setcar p (list
138 (setq symbol (car p))
139 (if (fboundp symbol)
140 (if (setq doc (documentation symbol t))
141 (substring doc 0 (string-match "\n" doc))
142 "(not documented)"))
143 (if (boundp symbol)
144 (if (setq doc (documentation-property
145 symbol 'variable-documentation t))
146 (substring doc 0
147 (string-match "\n" doc))
148 "(not documented)"))
149 (if (setq doc (symbol-plist symbol))
150 (if (eq (setq doc (/ (length doc) 2)) 1)
151 "1 property"
152 (concat doc " properties")))))
153 (setq p (cdr p)))))
154 nil))
155
156
157
158 ;;;###autoload
159 (defun apropos-value (regexp &optional do-all)
160 "Show all symbols whose value's printed image matches REGEXP.
161 With optional prefix ARG or if `apropos-do-all' is non-nil, also looks
162 at the function and at the names and values of properties.
163 Returns list of symbols and documentation found."
164 (interactive "sApropos value (regexp): \nP")
74 (setq do-all (or apropos-do-all do-all)) 165 (setq do-all (or apropos-do-all do-all))
75 (setq pred (or pred 'apropos-worthy-symbol-p)) 166 (apropos-print
76 (let ((apropos-accumulate (apropos-internal regexp pred))) 167 regexp
77 (if (null apropos-accumulate) 168 (let (accumulator f v p)
78 (message "No apropos matches for `%s'" regexp) 169 (mapatoms
79 (apropos-get-doc apropos-accumulate) 170 (lambda (symbol)
80 (with-output-to-temp-buffer "*Help*" 171 (setq f nil v nil p nil)
81 (apropos-print-matches apropos-accumulate regexp nil 172 (or (memq symbol '(regexp do-all accumulator symbol v pl p))
82 do-all no-header))) 173 (if (boundp symbol)
83 apropos-accumulate)) 174 (setq v (prin1-to-string (symbol-value symbol))
84 175 v (if (string-match regexp v) v))))
85 ;; Takes LIST of symbols and adds documentation. Modifies LIST in place. 176 (if do-all
86 ;; Resulting alist is of form ((symbol fn-doc var-doc) ...). Should only be 177 (progn
87 ;; called by apropos. Returns LIST. 178 (if (fboundp symbol)
88 179 (setq f (prin1-to-string (symbol-function symbol))
89 (defun apropos-get-doc (list) 180 f (if (string-match regexp f) f)))
90 (let ((p list) 181 (setq p (apropos-format-plist symbol "\n " regexp))))
91 fn-doc var-doc symbol) 182 ;; (if p-out (insert p-out))
92 (while (consp p) 183 (if (or f v p)
93 (setq symbol (car p) 184 (setq accumulator (cons (list symbol f v p) accumulator)))))
94 fn-doc (and (fboundp symbol) 185 accumulator)
95 (documentation symbol)) 186 nil nil t))
96 var-doc (documentation-property symbol 'variable-documentation) 187
97 fn-doc (and fn-doc 188
98 (substring fn-doc 0 (string-match "\n" fn-doc))) 189 (defun apropos-format-plist (pl sep &optional regexp)
99 var-doc (and var-doc 190 (setq pl (symbol-plist pl))
100 (substring var-doc 0 (string-match "\n" var-doc)))) 191 (let (p p-out)
101 (setcar p (list symbol fn-doc var-doc)) 192 (while pl
102 (setq p (cdr p))) 193 (setq p (format "%s %S" (car pl) (nth 1 pl)))
103 list)) 194 (if (string-match (or regexp "") p)
104 195 (if apropos-use-faces
105 ;; Variables bound by super-apropos and used by its subroutines. 196 (put-text-property 0 (length (symbol-name (car pl)))
106 ;; It would be good to say what each one is for, but I don't know -- rms. 197 'face 'bold-italic p))
107 (defvar apropos-item) 198 (setq p nil))
108 (defvar apropos-var-doc) 199 (if p (setq p-out (concat p-out (if p-out sep) p)))
109 (defvar apropos-fn-doc) 200 (setq pl (nthcdr 2 pl)))
110 (defvar apropos-accumulate) 201 p-out))
111 (defvar apropos-regexp 202
112 "Within `super-apropos', this holds the REGEXP argument.") 203
113 (defvar apropos-files-scanned)
114 204
115 ;;;###autoload 205 ;;;###autoload
116 (defun super-apropos (regexp &optional do-all) 206 (defun apropos-documentation (regexp &optional do-all)
117 "Show symbols whose names/documentation contain matches for REGEXP. 207 "Show symbols whose names or documentation contain matches for REGEXP.
118 If optional argument DO-ALL is non-nil (prefix argument if interactive), 208 With optional prefix ARG or if `apropos-do-all' is non-nil, also use
119 or if `apropos-do-all' is non-nil, does more (time-consuming) work such as 209 documentation that is not stored in the documentation file and show key
120 showing key bindings and documentation that is not stored in the documentation 210 bindings.
121 file.
122
123 Returns list of symbols and documentation found." 211 Returns list of symbols and documentation found."
124 (interactive "sSuper Apropos: \nP") 212 (interactive "sApropos documentation (regexp): \nP")
125 (setq do-all (or apropos-do-all do-all)) 213 (setq do-all (or apropos-do-all do-all))
126 (let ((apropos-regexp regexp) 214 (let (accumulator fn-doc var-doc item)
127 apropos-accumulate apropos-fn-doc apropos-var-doc apropos-item 215 (setq accumulator (apropos-documentation-check-doc-file regexp))
128 apropos-files-scanned) 216 (if do-all
129 (setq apropos-accumulate 217 (mapatoms
130 (super-apropos-check-doc-file apropos-regexp)) 218 (lambda (symbol)
131 (if do-all (mapatoms 'super-apropos-accumulate)) 219 (setq fn-doc (safe-documentation symbol)
132 (if (null apropos-accumulate) 220 var-doc (get symbol 'variable-documentation))
133 (message "No apropos matches for `%s'" apropos-regexp) 221 (if (numberp var-doc)
134 (with-output-to-temp-buffer "*Help*" 222 (setq var-doc nil))
135 (setq apropos-accumulate 223 (if (string-match regexp (symbol-name symbol))
136 (apropos-print-matches apropos-accumulate nil t do-all)))) 224 ()
137 apropos-accumulate)) 225 (if fn-doc
226 (or (string-match regexp fn-doc)
227 (setq fn-doc nil)))
228 (if var-doc
229 (or (string-match regexp var-doc)
230 (setq var-doc nil))))
231 (if (or fn-doc var-doc)
232 (if (setq item (cdr (assq symbol accumulator)))
233 (progn
234 (if fn-doc
235 (setcar item fn-doc))
236 (if var-doc
237 (setcar (cdr item) var-doc)))
238 (setq accumulator
239 (cons (list symbol fn-doc var-doc)
240 accumulator)))))))
241 (apropos-print regexp accumulator do-all nil t)))
242
243
138 244
139 ;; Finds all documentation related to REGEXP in internal-doc-file-name. 245 ;; Finds all documentation related to REGEXP in internal-doc-file-name.
140 ;; Returns an alist of form ((symbol fn-doc var-doc) ...). 246 ;; Returns an alist of form ((symbol fn-doc var-doc) ...).
141 247
142 (defun super-apropos-check-doc-file (regexp) 248 (defun apropos-documentation-check-doc-file (regexp)
143 (let* ((doc-file (concat doc-directory internal-doc-file-name)) 249 (let ((doc-buffer (get-buffer-create " *apropos-doc*"))
144 (doc-buffer (get-buffer-create " apropos-temp")) 250 ;; item is already let
145 type symbol doc sym-list) 251 type symbol sym-list)
146 (unwind-protect 252 (set-buffer doc-buffer)
147 (save-excursion 253 (goto-char (point-min))
148 (set-buffer doc-buffer) 254 (if (eobp)
149 (buffer-disable-undo) 255 (insert-file-contents (concat doc-directory internal-doc-file-name)))
150 (erase-buffer) 256 (while (re-search-forward regexp nil t)
151 (insert-file-contents doc-file) 257 (search-backward "\C-_")
152 (while (re-search-forward regexp nil t) 258 (or (setq type (if (eq ?F (char-after (1+ (point))))
153 (search-backward "\C-_") 259 1 ;function documentation
154 (setq type (if (eq ?F (char-after (1+ (point)))) 260 2) ;variable documentation
155 1 ;function documentation 261 symbol (progn
156 2) ;variable documentation 262 (forward-char 2)
157 symbol (progn 263 (read doc-buffer))
158 (forward-char 2) 264 doc (buffer-substring
159 (read doc-buffer)) 265 (1+ (point))
160 doc (buffer-substring 266 (if (search-forward "\C-_" nil 'move)
161 (point) 267 (1- (point))
162 (progn 268 (point)))
163 (if (search-forward "\C-_" nil 'move) 269 item (assq symbol sym-list))
164 (1- (point)) 270 (setq item (list symbol nil nil)
165 (point)))) 271 sym-list (cons item sym-list)))
166 apropos-item (assq symbol sym-list)) 272 (setcar (nthcdr type item) doc))
167 (and (if (= type 1)
168 (and (fboundp symbol) (documentation symbol))
169 (documentation-property symbol 'variable-documentation))
170 (or apropos-item
171 (setq apropos-item (list symbol nil nil)
172 sym-list (cons apropos-item sym-list)))
173 (setcar (nthcdr type apropos-item) doc))))
174 (kill-buffer doc-buffer))
175 sym-list)) 273 sym-list))
176 274
177 (defun super-apropos-check-elc-file (regexp file) 275
178 (let* ((doc-buffer (get-buffer-create " apropos-temp")) 276
179 symbol doc length beg end this-is-a-variable) 277 ;; This function is misnamed, it is simply a variety of the original
180 (unwind-protect 278 ;; that might be handled easier and more efficiently by that with a flag.
181 (save-excursion 279 ;; Otherwise it might be inlined above.
182 (set-buffer doc-buffer)
183 (buffer-disable-undo)
184 (erase-buffer)
185 (insert-file-contents file)
186 (while (search-forward "\n#@" nil t)
187 ;; Read the comment length, and advance over it.
188 (setq length (read (current-buffer)))
189 (setq beg (point))
190 (setq end (+ (point) length 1))
191 (if (re-search-forward regexp end t)
192 (progn
193 (setq this-is-a-variable (save-excursion
194 (goto-char end)
195 (looking-at "(defvar\\|(defconst"))
196 symbol (save-excursion
197 (goto-char end)
198 (skip-chars-forward "(a-z")
199 (forward-char 1)
200 (read doc-buffer))
201 symbol (if (consp symbol)
202 (nth 1 symbol)
203 symbol)
204 doc (buffer-substring (1+ beg) (- end 2))
205 apropos-item (assq symbol apropos-accumulate))
206 (and (if this-is-a-variable
207 (documentation-property symbol 'variable-documentation)
208 (and (fboundp symbol) (documentation symbol)))
209 (or apropos-item
210 (setq apropos-item (list symbol nil nil)
211 apropos-accumulate (cons apropos-item
212 apropos-accumulate)))
213 (setcar (nthcdr (if this-is-a-variable 2 1)
214 apropos-item)
215 doc))))
216 (goto-char end)))
217 (kill-buffer doc-buffer))
218 apropos-accumulate))
219
220 ;; This is passed as the argument to map-atoms, so it is called once for every
221 ;; symbol in obarray. Takes one argument SYMBOL, and finds any memory-resident
222 ;; documentation on that symbol if it matches a variable regexp.
223
224 (defun super-apropos-accumulate (symbol)
225 (let (doc)
226 (cond ((string-match apropos-regexp (symbol-name symbol))
227 (setq apropos-item (apropos-get-accum-item symbol))
228 (setcar (cdr apropos-item)
229 (or (safe-documentation symbol)
230 (nth 1 apropos-item)))
231 (setcar (nthcdr 2 apropos-item)
232 (or (safe-documentation-property symbol)
233 (nth 2 apropos-item))))
234 ((or (consp (setq doc (safe-documentation symbol)))
235 (consp (setq doc (safe-documentation-property symbol))))
236 ;; This symbol's doc is stored in a file.
237 ;; Scan the file if we have not scanned it before.
238 (let ((file (car doc)))
239 (or (member file apropos-files-scanned)
240 (progn
241 (setq apropos-files-scanned
242 (cons file apropos-files-scanned))
243 (super-apropos-check-elc-file apropos-regexp file)))))
244 (t
245 (and (stringp (setq doc (safe-documentation symbol)))
246 (setq apropos-fn-doc doc)
247 (string-match apropos-regexp apropos-fn-doc)
248 (setcar (cdr (apropos-get-accum-item symbol)) apropos-fn-doc))
249 (and (stringp (setq doc (safe-documentation-property symbol)))
250 (setq apropos-var-doc doc)
251 (string-match apropos-regexp apropos-var-doc)
252 (setcar (nthcdr 2 (apropos-get-accum-item symbol))
253 apropos-var-doc)))))
254 nil)
255
256 ;; Prints the symbols and documentation in alist MATCHES of form ((symbol
257 ;; fn-doc var-doc) ...). Uses optional argument REGEXP to speed up searching
258 ;; for keybindings. The names of all symbols in MATCHES must match REGEXP.
259 ;; Displays in the buffer pointed to by standard-output. Optional argument
260 ;; SPACING means put blank lines in between each symbol's documentation.
261 ;; Optional argument DO-ALL means do more time-consuming work, specifically,
262 ;; consulting key bindings. Should only be called within a
263 ;; with-output-to-temp-buffer.
264
265 (defun apropos-print-matches (matches &optional regexp
266 spacing do-all no-header)
267 (setq matches (sort matches (function
268 (lambda (a b)
269 (string-lessp (car a) (car b))))))
270 (let ((p matches)
271 (old-buffer (current-buffer))
272 item keys-done symbol tem)
273 (save-excursion
274 (set-buffer standard-output)
275 (or matches (princ "No matches found."))
276 (while (consp p)
277 (setq item (car p)
278 symbol (car item)
279 p (cdr p))
280 (or (not spacing) (bobp) (terpri))
281 (princ symbol) ;print symbol name
282 ;; don't calculate key-bindings unless needed
283 (cond ((and do-all (commandp symbol) (not keys-done))
284 (save-excursion
285 (set-buffer old-buffer)
286 (apropos-match-keys matches regexp))
287 (setq keys-done t)))
288 (cond ((and do-all
289 (or (setq tem (nthcdr 3 item))
290 (commandp symbol)))
291 (indent-to 30 1)
292 (if tem
293 (princ (mapconcat 'key-description tem ", "))
294 (princ "(not bound to any keys)"))))
295 (terpri)
296 (cond ((setq tem (nth 1 item))
297 (let ((substed (if do-all (substitute-command-keys tem) tem)))
298 (if no-header
299 (princ " ")
300 (princ " Function: ")
301 (if (> (length substed) 67)
302 (princ "\n ")))
303 (princ substed))))
304 (or (bolp) (terpri))
305 (cond ((setq tem (nth 2 item))
306 (let ((substed (if do-all (substitute-command-keys tem) tem)))
307 (if no-header
308 (princ " ")
309 (princ " Variable: ")
310 (if (> (length substed) 67)
311 (princ "\n ")))
312 (princ substed))))
313 (or (bolp) (terpri)))
314 (help-mode)))
315 matches)
316
317 ;; Find key bindings for symbols that are cars in ALIST. Optionally, first
318 ;; match the symbol name against REGEXP. Modifies ALIST in place. Each key
319 ;; binding is added as a string to the end of the list in ALIST whose car is
320 ;; the corresponding symbol. The pointer to ALIST is returned.
321
322 (defun apropos-match-keys (alist &optional regexp)
323 (let* ((current-local-map (current-local-map))
324 ;; Get a list of the top-level maps now active.
325 (top-maps
326 (if overriding-local-map
327 (list overriding-local-map (current-global-map))
328 (append (current-minor-mode-maps)
329 (if current-local-map
330 (list current-local-map (current-global-map))
331 (list (current-global-map))))))
332 ;; Turn that into a list of all the maps including submaps.
333 (maps (apply 'append (mapcar 'accessible-keymaps top-maps)))
334 map ;map we are now inspecting
335 sequence ;key sequence to reach map
336 i ;index into vector map
337 command ;what is bound to current keys
338 key ;last key to reach command
339 local ;local binding for sequence + key
340 item) ;symbol data item in alist
341 ;; examine all reachable keymaps
342 (while (consp maps)
343 (setq map (cdr (car maps))
344 sequence (car (car maps)) ;keys to reach this map
345 maps (cdr maps))
346 ;; Skip the leading `keymap', doc string, etc.
347 (if (eq (car map) 'keymap)
348 (setq map (cdr map)))
349 (while (stringp (car-safe map))
350 (setq map (cdr map)))
351
352 (while (consp map)
353 (cond ((consp (car map))
354 (setq command (cdr (car map))
355 key (car (car map)))
356 ;; Skip any menu prompt and help string in this key binding.
357 (while (and (consp command) (stringp (car command)))
358 (setq command (cdr command)))
359 ;; Skip any cached equivalent key.
360 (and (consp command)
361 (consp (car command))
362 (setq command (cdr command)))
363 ;; if is a symbol, and matches optional regexp, and is a car
364 ;; in alist, and is not shadowed by a different local binding,
365 ;; record it
366 (and (symbolp command)
367 (if regexp
368 (string-match regexp (symbol-name command))
369 t)
370 (setq item (assq command alist))
371 (if (or (vectorp sequence) (not (integerp key)))
372 (setq key (vconcat sequence (vector key)))
373 (setq key (concat sequence (char-to-string key))))
374 ;; checking if shadowed by local binding.
375 ;; either no local map, no local binding, or runs off the
376 ;; binding tree (number), or is the same binding
377 (or (not current-local-map)
378 (not (setq local (lookup-key current-local-map key)))
379 (numberp local)
380 (eq command local))
381 ;; check if this binding is already recorded
382 ;; (this can happen due to inherited keymaps)
383 (not (member key (nthcdr 3 item)))
384 ;; add this key binding to the item in alist
385 (nconc item (cons key nil))))
386 ((vectorp (car map))
387 (let ((i 0)
388 (vec (car map))
389 (len (length (car map))))
390 (while (< i len)
391 (setq command (aref vec i))
392 (setq key i)
393 ;; Skip any menu prompt in this key binding.
394 (and (consp command) (symbolp (cdr command))
395 (setq command (cdr command)))
396 ;; This is the same as the code in the previous case.
397 (and (symbolp command)
398 (if regexp
399 (string-match regexp (symbol-name command))
400 t)
401 (setq item (assq command alist))
402 (if (or (vectorp sequence) (not (integerp key)))
403 (setq key (vconcat sequence (vector key)))
404 (setq key (concat sequence (char-to-string key))))
405 ;; checking if shadowed by local binding.
406 ;; either no local map, no local binding, or runs off the
407 ;; binding tree (number), or is the same binding
408 (or (not current-local-map)
409 (not (setq local (lookup-key current-local-map key)))
410 (numberp local)
411 (eq command local))
412 ;; check if this binding is already recorded
413 ;; (this can happen due to inherited keymaps)
414 (not (member key (nthcdr 3 item)))
415 ;; add this key binding to the item in alist
416 (nconc item (cons key nil)))
417 (setq i (1+ i))))))
418 (setq map (cdr map)))))
419 alist)
420
421 ;; Get an alist item in alist apropos-accumulate whose car is SYMBOL. Creates
422 ;; the item if not already present. Modifies apropos-accumulate in place.
423
424 (defun apropos-get-accum-item (symbol)
425 (or (assq symbol apropos-accumulate)
426 (progn
427 (setq apropos-accumulate
428 (cons (list symbol nil nil) apropos-accumulate))
429 (assq symbol apropos-accumulate))))
430 280
431 (defun safe-documentation (function) 281 (defun safe-documentation (function)
432 "Like documentation, except it avoids calling `get_doc_string'. 282 "Like documentation, except it avoids calling `get_doc_string'.
433 Will return nil instead." 283 Will return nil instead."
434 (while (symbolp function) 284 (while (and function (symbolp function))
435 (setq function (if (fboundp function) 285 (setq function (if (fboundp function)
436 (symbol-function function) 286 (symbol-function function))))
437 0)))
438 (if (eq (car-safe function) 'macro) 287 (if (eq (car-safe function) 'macro)
439 (setq function (cdr function))) 288 (setq function (cdr function)))
440 (if (byte-code-function-p function) 289 (setq function (if (byte-code-function-p function)
441 (if (> (length function) 4) 290 (condition-case nil
442 (aref function 4)) 291 (aref function 4)
443 (if (not (consp function)) 292 (error))
444 nil 293 (if (memq (car-safe function) '(lambda autoload))
445 (if (not (memq (car function) '(lambda autoload))) 294 (nth 2 function))))
446 nil 295 (if (stringp function)
447 (setq function (nth 2 function)) 296 function))
448 (if (stringp function) 297
449 function 298
450 nil))))) 299
451 300 (defun apropos-print (regexp apropos-result do-keys doc-fn spacing)
452 (defun safe-documentation-property (symbol) 301 "Output result of various appropos commands with REGEXP.
453 "Like documentation-property, except it avoids calling `get_doc_string'. 302 APROPOS-RESULT is a list. Optional DOC-FN is called for each element
454 Will return nil instead." 303 of apropos-result and may modify it resulting in (symbol fn-doc
455 (setq symbol (get symbol 'variable-documentation)) 304 var-doc [plist-doc]). Returns sorted list of symbols and documentation
456 (if (numberp symbol) 305 found."
457 nil 306 (if (null apropos-result)
458 symbol)) 307 (message "No apropos matches for `%s'" regexp)
308 (if doc-fn
309 (funcall doc-fn apropos-result))
310 (setq apropos-result
311 (sort apropos-result (lambda (a b)
312 (string-lessp (car a) (car b)))))
313 (with-output-to-temp-buffer "*Help*"
314 (let ((p apropos-result)
315 (old-buffer (current-buffer))
316 symbol item tem point1 point2)
317 (save-excursion
318 (set-buffer standard-output)
319 (if window-system
320 (insert (substitute-command-keys
321 "Click \\<apropos-local-map>\\[apropos-mouse-follow] to get full documentation.\n")))
322 (insert (substitute-command-keys
323 "In this buffer, type \\<apropos-local-map>\\[apropos-follow] to get full documentation.\n\n"))
324 (while (consp p)
325 (or (not spacing) (bobp) (terpri))
326 (setq item (car p)
327 symbol (car item)
328 p (cdr p)
329 point1 (point))
330 (princ symbol) ;print symbol name
331 (setq point2 (point))
332 ;; don't calculate key-bindings unless needed
333 (and do-keys
334 (commandp symbol)
335 (indent-to 30 1)
336 (princ (if (setq tem (save-excursion
337 (set-buffer old-buffer)
338 (where-is-internal symbol)))
339 (mapconcat 'key-description tem ", ")
340 "(not bound to any keys)")))
341 (terpri)
342 ;; only now so we don't propagate text attributes all over
343 (put-text-property point1 (1+ point1) 'item
344 (if (or (nth 1 item) (nth 2 item) (nth 3 item))
345 (car item)
346 item))
347 (if apropos-use-faces
348 (put-text-property point1 point2 'face 'bold))
349 (apropos-print-documentation 'describe-function (nth 1 item)
350 (if (commandp symbol)
351 "Command: "
352 "Function: ")
353 do-keys)
354 (apropos-print-documentation 'describe-variable (nth 2 item)
355 "Variable: " do-keys)
356 (apropos-print-documentation 'apropos-describe-plist (nth 3 item)
357 "Plist: " nil))
358 (put-text-property 1 (point) 'local-map apropos-local-map)))))
359 apropos-result)
360
361
362 (defun apropos-print-documentation (action tem str do-keys)
363 (if tem
364 (progn
365 (insert " ")
366 (put-text-property (- (point) 2) (1- (point))
367 'action action)
368 (princ str)
369 (if apropos-use-faces
370 (add-text-properties (- (point) (length str))
371 (1- (point))
372 '(face italic
373 mouse-face highlight)))
374 (insert (if do-keys (substitute-command-keys tem) tem))))
375 (or (bolp) (terpri)))
376
377
378
379 (defun apropos-mouse-follow (event)
380 (interactive "e")
381 (let ((other (if (eq (current-buffer) (get-buffer "*Help*"))
382 ()
383 (current-buffer))))
384 (set-buffer (window-buffer (posn-window (event-start event))))
385 (goto-char (posn-point (event-start event)))
386 ;; somehow when clicking with the point in another window, doesn't undo
387 (undo-boundary)
388 (apropos-follow other)))
389
390
391 (defun apropos-follow (&optional other)
392 (interactive)
393 (let ((point (point))
394 (item (get-text-property (point) 'item))
395 action action-point)
396 (or item
397 (setq item (if (bobp)
398 ()
399 (previous-single-property-change (point) 'item))
400 item (get-text-property
401 (1- (goto-char
402 (if item
403 item
404 (1+ (next-single-property-change (point) 'item)))))
405 'item)))
406 (if (consp item)
407 (error "%s is just a lonely smbol." (car item)))
408 (while (if (setq action-point
409 (next-single-property-change (point) 'action))
410 (<= action-point point))
411 (goto-char (1+ action-point))
412 (setq action action-point))
413 (funcall
414 (prog1 (get-text-property (or action action-point (point)) 'action)
415 (if other (set-buffer other)))
416 item))
417 (message "%sype %s (undo) to get back to apropos-listing."
418 (if other "In *Help* buffer t" "T")
419 (key-description (where-is-internal 'undo nil 1))))
420
421
422
423 (defun apropos-describe-plist (symbol)
424 "Display a pretty listing of SYMBOL's plist."
425 (with-output-to-temp-buffer "*Help*"
426 (set-buffer standard-output)
427 (princ "Symbol ")
428 (prin1 symbol)
429 (princ "'s plist is\n (")
430 (if apropos-use-faces
431 (put-text-property 8 (- (point) 14) 'face 'bold))
432 (insert (apropos-format-plist symbol "\n "))
433 (princ ")")))
459 434
460 ;;; apropos.el ends here 435 ;;; apropos.el ends here