]> code.delx.au - gnu-emacs/blob - lisp/apropos.el
Use cl only at compile time.
[gnu-emacs] / lisp / apropos.el
1 ;;; apropos.el --- apropos commands for users and programmers.
2
3 ;; Copyright (C) 1989, 1994, 1995 Free Software Foundation, Inc.
4
5 ;; Author: Joe Wells <jbw@bigbird.bu.edu>
6 ;; Rewritten: Daniel.Pfeiffer@Informatik.START.dbp.de, fax (+49 69) 7588-2389
7 ;; Keywords: help
8
9 ;; This file is part of GNU Emacs.
10
11 ;; GNU Emacs is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 2, or (at your option)
14 ;; any later version.
15
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
20
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
25
26 ;;; Commentary:
27
28 ;; The ideas for this package were derived from the C code in
29 ;; src/keymap.c and elsewhere. The functions in this file should
30 ;; always be byte-compiled for speed. Someone should rewrite this in
31 ;; C (as part of src/keymap.c) for speed.
32
33 ;; The idea for super-apropos is based on the original implementation
34 ;; by Lynn Slater <lrs@esl.com>.
35
36 ;; History:
37 ;; Fixed bug, current-local-map can return nil.
38 ;; Change, doesn't calculate key-bindings unless needed.
39 ;; Added super-apropos capability, changed print functions.
40 ;;; Made fast-apropos and super-apropos share code.
41 ;;; Sped up fast-apropos again.
42 ;; Added apropos-do-all option.
43 ;;; Added fast-command-apropos.
44 ;; Changed doc strings to comments for helping functions.
45 ;;; Made doc file buffer read-only, buried it.
46 ;; Only call substitute-command-keys if do-all set.
47
48 ;; Optionally use configurable faces to make the output more legible.
49 ;; Differentiate between command, function and macro.
50 ;; Apropos-command (ex command-apropos) does cmd and optionally user var.
51 ;; Apropos shows all 3 aspects of symbols (fn, var and plist)
52 ;; Apropos-documentation (ex super-apropos) now finds all it should.
53 ;; New apropos-value snoops through all values and optionally plists.
54 ;; Reading DOC file doesn't load nroff.
55 ;; Added hypertext following of documentation, mouse-2 on variable gives value
56 ;; from buffer in active window.
57
58 ;;; Code:
59
60 ;; I see a degradation of maybe 10-20% only.
61 (defvar apropos-do-all nil
62 "*Whether the apropos commands should do more.
63 Slows them down more or less. Set this non-nil if you have a fast machine.")
64
65
66 (defvar apropos-symbol-face (if window-system 'bold)
67 "*Face for symbol name in apropos output or `nil'.
68 This looks good, but slows down the commands several times.")
69
70 (defvar apropos-keybinding-face (if window-system 'underline)
71 "*Face for keybinding display in apropos output or `nil'.
72 This looks good, but slows down the commands several times.")
73
74 (defvar apropos-label-face (if window-system 'italic)
75 "*Face for label (Command, Variable ...) in apropos output or `nil'.
76 If this is `nil' no mouse highlighting occurs.
77 This looks good, but slows down the commands several times.
78 When this is a face name, as it is initially, it gets transformed to a
79 text-property list for efficiency.")
80
81 (defvar apropos-property-face (if window-system 'bold-italic)
82 "*Face for property name in apropos output or `nil'.
83 This looks good, but slows down the commands several times.")
84
85 (defvar apropos-match-face (if window-system 'secondary-selection)
86 "*Face for matching part in apropos-documentation/value output or `nil'.
87 This looks good, but slows down the commands several times.")
88
89
90 (defvar apropos-mode-map
91 (let ((map (make-sparse-keymap)))
92 (define-key map "\C-m" 'apropos-follow)
93 (define-key map " " 'scroll-up)
94 (define-key map "\177" 'scroll-down)
95 (define-key map [mouse-2] 'apropos-mouse-follow)
96 (define-key map [down-mouse-2] nil)
97 map)
98 "Keymap used in Apropos mode.")
99
100
101 (defvar apropos-regexp nil
102 "Regexp used in current apropos run.")
103
104 (defvar apropos-files-scanned ()
105 "List of elc files already scanned in current run of `apropos-documentation'.")
106
107 (defvar apropos-accumulator ()
108 "Alist of symbols already found in current apropos run.")
109
110 (defvar apropos-item ()
111 "Current item in or for apropos-accumulator.")
112 \f
113 (defun apropos-mode ()
114 "Major mode for following hyperlinks in output of apropos commands.
115
116 \\{apropos-mode-map}"
117 (interactive)
118 (kill-all-local-variables)
119 (use-local-map apropos-mode-map)
120 (setq major-mode 'apropos-mode
121 mode-name "Apropos"))
122
123
124 ;; For auld lang syne:
125 ;;;###autoload
126 (fset 'command-apropos 'apropos-command)
127 ;;;###autoload
128 (defun apropos-command (apropos-regexp &optional do-all)
129 "Shows commands (interactively callable functions) that match REGEXP.
130 With optional prefix ARG or if `apropos-do-all' is non-nil, also show
131 variables."
132 (interactive (list (read-string (concat "Apropos command "
133 (if (or current-prefix-arg
134 apropos-do-all)
135 "or variable ")
136 "(regexp): "))
137 current-prefix-arg))
138 (let ((message
139 (let ((standard-output (get-buffer-create "*Apropos*")))
140 (print-help-return-message 'identity))))
141 (or do-all (setq do-all apropos-do-all))
142 (setq apropos-accumulator
143 (apropos-internal apropos-regexp
144 (if do-all
145 (lambda (symbol) (or (commandp symbol)
146 (user-variable-p symbol)))
147 'commandp)))
148 (if (apropos-print
149 t
150 (lambda (p)
151 (let (doc symbol)
152 (while p
153 (setcar p (list
154 (setq symbol (car p))
155 (if (commandp symbol)
156 (if (setq doc (documentation symbol t))
157 (substring doc 0 (string-match "\n" doc))
158 "(not documented)"))
159 (and do-all
160 (user-variable-p symbol)
161 (if (setq doc (documentation-property
162 symbol 'variable-documentation t))
163 (substring doc 0
164 (string-match "\n" doc))))))
165 (setq p (cdr p)))))
166 nil)
167 (and message (message message)))))
168
169
170 ;;;###autoload
171 (defun apropos (apropos-regexp &optional do-all)
172 "Show all bound symbols whose names match REGEXP.
173 With optional prefix ARG or if `apropos-do-all' is non-nil, also show unbound
174 symbols and key bindings, which is a little more time-consuming.
175 Returns list of symbols and documentation found."
176 (interactive "sApropos symbol (regexp): \nP")
177 (setq apropos-accumulator
178 (apropos-internal apropos-regexp
179 (and (not do-all)
180 (not apropos-do-all)
181 (lambda (symbol)
182 (or (fboundp symbol)
183 (boundp symbol)
184 (facep symbol)
185 (symbol-plist symbol))))))
186 (apropos-print
187 (or do-all apropos-do-all)
188 (lambda (p)
189 (let (symbol doc properties)
190 (while p
191 (setcar p (list
192 (setq symbol (car p))
193 (when (fboundp symbol)
194 (if (setq doc (documentation symbol t))
195 (substring doc 0 (string-match "\n" doc))
196 "(not documented)"))
197 (when (boundp symbol)
198 (if (setq doc (documentation-property
199 symbol 'variable-documentation t))
200 (substring doc 0 (string-match "\n" doc))
201 "(not documented)"))
202 (when (setq properties (symbol-plist symbol))
203 (setq doc (list (car properties)))
204 (while (setq properties (cdr (cdr properties)))
205 (setq doc (cons (car properties) doc)))
206 (mapconcat #'symbol-name (nreverse doc) " "))
207 (when (get symbol 'widget-type)
208 (if (setq doc (documentation-property
209 symbol 'widget-documentation t))
210 (substring doc 0
211 (string-match "\n" doc))
212 "(not documented)"))
213 (when (facep symbol)
214 (if (setq doc (documentation-property
215 symbol 'face-documentation t))
216 (substring doc 0
217 (string-match "\n" doc))
218 "(not documented)"))))
219 (setq p (cdr p)))))
220 nil))
221
222
223 ;;;###autoload
224 (defun apropos-value (apropos-regexp &optional do-all)
225 "Show all symbols whose value's printed image matches REGEXP.
226 With optional prefix ARG or if `apropos-do-all' is non-nil, also looks
227 at the function and at the names and values of properties.
228 Returns list of symbols and values found."
229 (interactive "sApropos value (regexp): \nP")
230 (or do-all (setq do-all apropos-do-all))
231 (setq apropos-accumulator ())
232 (let (f v p)
233 (mapatoms
234 (lambda (symbol)
235 (setq f nil v nil p nil)
236 (or (memq symbol '(apropos-regexp do-all apropos-accumulator
237 symbol f v p))
238 (setq v (apropos-value-internal 'boundp symbol 'symbol-value)))
239 (if do-all
240 (setq f (apropos-value-internal 'fboundp symbol 'symbol-function)
241 p (apropos-format-plist symbol "\n " t)))
242 (if (or f v p)
243 (setq apropos-accumulator (cons (list symbol f v p)
244 apropos-accumulator))))))
245 (apropos-print nil nil t))
246
247
248 ;;;###autoload
249 (defun apropos-documentation (apropos-regexp &optional do-all)
250 "Show symbols whose documentation contain matches for REGEXP.
251 With optional prefix ARG or if `apropos-do-all' is non-nil, also use
252 documentation that is not stored in the documentation file and show key
253 bindings.
254 Returns list of symbols and documentation found."
255 (interactive "sApropos documentation (regexp): \nP")
256 (or do-all (setq do-all apropos-do-all))
257 (setq apropos-accumulator () apropos-files-scanned ())
258 (let ((standard-input (get-buffer-create " apropos-temp"))
259 f v)
260 (unwind-protect
261 (save-excursion
262 (set-buffer standard-input)
263 (apropos-documentation-check-doc-file)
264 (if do-all
265 (mapatoms
266 (lambda (symbol)
267 (setq f (apropos-safe-documentation symbol)
268 v (get symbol 'variable-documentation))
269 (if (integerp v) (setq v))
270 (setq f (apropos-documentation-internal f)
271 v (apropos-documentation-internal v))
272 (if (or f v)
273 (if (setq apropos-item
274 (cdr (assq symbol apropos-accumulator)))
275 (progn
276 (if f
277 (setcar apropos-item f))
278 (if v
279 (setcar (cdr apropos-item) v)))
280 (setq apropos-accumulator
281 (cons (list symbol f v)
282 apropos-accumulator)))))))
283 (apropos-print nil nil t))
284 (kill-buffer standard-input))))
285
286 \f
287 (defun apropos-value-internal (predicate symbol function)
288 (if (funcall predicate symbol)
289 (progn
290 (setq symbol (prin1-to-string (funcall function symbol)))
291 (if (string-match apropos-regexp symbol)
292 (progn
293 (if apropos-match-face
294 (put-text-property (match-beginning 0) (match-end 0)
295 'face apropos-match-face
296 symbol))
297 symbol)))))
298
299 (defun apropos-documentation-internal (doc)
300 (if (consp doc)
301 (apropos-documentation-check-elc-file (car doc))
302 (and doc
303 (string-match apropos-regexp doc)
304 (progn
305 (if apropos-match-face
306 (put-text-property (match-beginning 0)
307 (match-end 0)
308 'face apropos-match-face
309 (setq doc (copy-sequence doc))))
310 doc))))
311
312 (defun apropos-format-plist (pl sep &optional compare)
313 (setq pl (symbol-plist pl))
314 (let (p p-out)
315 (while pl
316 (setq p (format "%s %S" (car pl) (nth 1 pl)))
317 (if (or (not compare) (string-match apropos-regexp p))
318 (if apropos-property-face
319 (put-text-property 0 (length (symbol-name (car pl)))
320 'face apropos-property-face p))
321 (setq p nil))
322 (if p
323 (progn
324 (and compare apropos-match-face
325 (put-text-property (match-beginning 0) (match-end 0)
326 'face apropos-match-face
327 p))
328 (setq p-out (concat p-out (if p-out sep) p))))
329 (setq pl (nthcdr 2 pl)))
330 p-out))
331
332
333 ;; Finds all documentation related to APROPOS-REGEXP in internal-doc-file-name.
334
335 (defun apropos-documentation-check-doc-file ()
336 (let (type symbol (sepa 2) sepb beg end)
337 (insert ?\^_)
338 (backward-char)
339 (insert-file-contents (concat doc-directory internal-doc-file-name))
340 (forward-char)
341 (while (save-excursion
342 (setq sepb (search-forward "\^_"))
343 (not (eobp)))
344 (beginning-of-line 2)
345 (if (save-restriction
346 (narrow-to-region (point) (1- sepb))
347 (re-search-forward apropos-regexp nil t))
348 (progn
349 (setq beg (match-beginning 0)
350 end (point))
351 (goto-char (1+ sepa))
352 (or (setq type (if (eq ?F (preceding-char))
353 1 ; function documentation
354 2) ; variable documentation
355 symbol (read)
356 beg (- beg (point) 1)
357 end (- end (point) 1)
358 doc (buffer-substring (1+ (point)) (1- sepb))
359 apropos-item (assq symbol apropos-accumulator))
360 (setq apropos-item (list symbol nil nil)
361 apropos-accumulator (cons apropos-item
362 apropos-accumulator)))
363 (if apropos-match-face
364 (put-text-property beg end 'face apropos-match-face doc))
365 (setcar (nthcdr type apropos-item) doc)))
366 (setq sepa (goto-char sepb)))))
367
368 (defun apropos-documentation-check-elc-file (file)
369 (if (member file apropos-files-scanned)
370 nil
371 (let (symbol doc beg end this-is-a-variable)
372 (setq apropos-files-scanned (cons file apropos-files-scanned))
373 (erase-buffer)
374 (insert-file-contents file)
375 (while (search-forward "\n#@" nil t)
376 ;; Read the comment length, and advance over it.
377 (setq end (read)
378 beg (1+ (point))
379 end (+ (point) end -1))
380 (forward-char)
381 (if (save-restriction
382 ;; match ^ and $ relative to doc string
383 (narrow-to-region beg end)
384 (re-search-forward apropos-regexp nil t))
385 (progn
386 (goto-char (+ end 2))
387 (setq doc (buffer-substring beg end)
388 end (- (match-end 0) beg)
389 beg (- (match-beginning 0) beg)
390 this-is-a-variable (looking-at "(def\\(var\\|const\\) ")
391 symbol (progn
392 (skip-chars-forward "(a-z")
393 (forward-char)
394 (read))
395 symbol (if (consp symbol)
396 (nth 1 symbol)
397 symbol))
398 (if (if this-is-a-variable
399 (get symbol 'variable-documentation)
400 (and (fboundp symbol) (apropos-safe-documentation symbol)))
401 (progn
402 (or (setq apropos-item (assq symbol apropos-accumulator))
403 (setq apropos-item (list symbol nil nil)
404 apropos-accumulator (cons apropos-item
405 apropos-accumulator)))
406 (if apropos-match-face
407 (put-text-property beg end 'face apropos-match-face
408 doc))
409 (setcar (nthcdr (if this-is-a-variable 2 1)
410 apropos-item)
411 doc)))))))))
412
413
414
415 (defun apropos-safe-documentation (function)
416 "Like documentation, except it avoids calling `get_doc_string'.
417 Will return nil instead."
418 (while (and function (symbolp function))
419 (setq function (if (fboundp function)
420 (symbol-function function))))
421 (if (eq (car-safe function) 'macro)
422 (setq function (cdr function)))
423 (setq function (if (byte-code-function-p function)
424 (if (> (length function) 4)
425 (aref function 4))
426 (if (eq (car-safe function) 'autoload)
427 (nth 2 function)
428 (if (eq (car-safe function) 'lambda)
429 (if (stringp (nth 2 function))
430 (nth 2 function)
431 (if (stringp (nth 3 function))
432 (nth 3 function)))))))
433 (if (integerp function)
434 nil
435 function))
436
437
438
439 (defun apropos-print (do-keys doc-fn spacing)
440 "Output result of various apropos commands with `apropos-regexp'.
441 APROPOS-ACCUMULATOR is a list. Optional DOC-FN is called for each element
442 of apropos-accumulator and may modify it resulting in (symbol fn-doc
443 var-doc [plist-doc]). Returns sorted list of symbols and documentation
444 found."
445 (if (null apropos-accumulator)
446 (message "No apropos matches for `%s'" apropos-regexp)
447 (if doc-fn
448 (funcall doc-fn apropos-accumulator))
449 (setq apropos-accumulator
450 (sort apropos-accumulator (lambda (a b)
451 (string-lessp (car a) (car b)))))
452 (and apropos-label-face
453 (symbolp apropos-label-face)
454 (setq apropos-label-face `(face ,apropos-label-face
455 mouse-face highlight)))
456 (with-output-to-temp-buffer "*Apropos*"
457 (let ((p apropos-accumulator)
458 (old-buffer (current-buffer))
459 symbol item point1 point2)
460 (set-buffer standard-output)
461 (apropos-mode)
462 (if window-system
463 (insert "If you move the mouse over text that changes color,\n"
464 (substitute-command-keys
465 "you can click \\[apropos-mouse-follow] to get more information.\n")))
466 (insert (substitute-command-keys
467 "In this buffer, type \\[apropos-follow] to get full documentation.\n\n"))
468 (while (consp p)
469 (or (not spacing) (bobp) (terpri))
470 (setq apropos-item (car p)
471 symbol (car apropos-item)
472 p (cdr p)
473 point1 (point))
474 (princ symbol) ; print symbol name
475 (setq point2 (point))
476 ;; Calculate key-bindings if we want them.
477 (and do-keys
478 (commandp symbol)
479 (indent-to 30 1)
480 (if (let ((keys
481 (save-excursion
482 (set-buffer old-buffer)
483 (where-is-internal symbol)))
484 filtered)
485 ;; Copy over the list of key sequences,
486 ;; omitting any that contain a buffer or a frame.
487 (while keys
488 (let ((key (car keys))
489 (i 0)
490 loser)
491 (while (< i (length key))
492 (if (or (framep (aref key i))
493 (bufferp (aref key i)))
494 (setq loser t))
495 (setq i (1+ i)))
496 (or loser
497 (setq filtered (cons key filtered))))
498 (setq keys (cdr keys)))
499 (setq item filtered))
500 ;; Convert the remaining keys to a string and insert.
501 (insert
502 (mapconcat
503 (lambda (key)
504 (setq key (key-description key))
505 (if apropos-keybinding-face
506 (put-text-property 0 (length key)
507 'face apropos-keybinding-face
508 key))
509 key)
510 item ", "))
511 (insert "M-x")
512 (put-text-property (- (point) 3) (point)
513 'face apropos-keybinding-face)
514 (insert " " (symbol-name symbol) " ")
515 (insert "RET")
516 (put-text-property (- (point) 3) (point)
517 'face apropos-keybinding-face)))
518 (terpri)
519 ;; only now so we don't propagate text attributes all over
520 (put-text-property point1 point2 'item
521 (if (eval `(or ,@(cdr apropos-item)))
522 (car apropos-item)
523 apropos-item))
524 (if apropos-symbol-face
525 (put-text-property point1 point2 'face apropos-symbol-face))
526 (apropos-print-doc 'describe-function 1
527 (if (commandp symbol)
528 "Command"
529 (if (apropos-macrop symbol)
530 "Macro"
531 "Function"))
532 do-keys)
533 (if (get symbol 'custom-type)
534 (apropos-print-doc 'customize-variable-other-window 2
535 "User Option" do-keys)
536 (apropos-print-doc 'describe-variable 2
537 "Variable" do-keys))
538 (apropos-print-doc 'customize-face-other-window 5 "Face" do-keys)
539 (apropos-print-doc 'widget-browse-other-window 4 "Widget" do-keys)
540 (apropos-print-doc 'apropos-describe-plist 3
541 "Plist" nil)))))
542 (prog1 apropos-accumulator
543 (setq apropos-accumulator ()))) ; permit gc
544
545
546 (defun apropos-macrop (symbol)
547 "T if SYMBOL is a Lisp macro."
548 (and (fboundp symbol)
549 (consp (setq symbol
550 (symbol-function symbol)))
551 (or (eq (car symbol) 'macro)
552 (if (eq (car symbol) 'autoload)
553 (memq (nth 4 symbol)
554 '(macro t))))))
555
556
557 (defun apropos-print-doc (action i str do-keys)
558 (if (stringp (setq i (nth i apropos-item)))
559 (progn
560 (insert " ")
561 (put-text-property (- (point) 2) (1- (point))
562 'action action)
563 (insert str ": ")
564 (if apropos-label-face
565 (add-text-properties (- (point) (length str) 2)
566 (1- (point))
567 apropos-label-face))
568 (insert (if do-keys (substitute-command-keys i) i))
569 (or (bolp) (terpri)))))
570
571
572 (defun apropos-mouse-follow (event)
573 (interactive "e")
574 (let ((other (if (eq (current-buffer) (get-buffer "*Apropos*"))
575 ()
576 (current-buffer))))
577 (save-excursion
578 (set-buffer (window-buffer (posn-window (event-start event))))
579 (goto-char (posn-point (event-start event)))
580 (or (and (not (eobp)) (get-text-property (point) 'mouse-face))
581 (and (not (bobp)) (get-text-property (1- (point)) 'mouse-face))
582 (error "There is nothing to follow here"))
583 (apropos-follow other))))
584
585
586 (defun apropos-follow (&optional other)
587 (interactive)
588 (let* (;; Properties are always found at the beginning of the line.
589 (bol (save-excursion (beginning-of-line) (point)))
590 ;; If there is no `item' property here, look behind us.
591 (item (get-text-property bol 'item))
592 (item-at (if item nil (previous-single-property-change bol 'item)))
593 ;; Likewise, if there is no `action' property here, look in front.
594 (action (get-text-property bol 'action))
595 (action-at (if action nil (next-single-property-change bol 'action))))
596 (and (null item) item-at
597 (setq item (get-text-property (1- item-at) 'item)))
598 (and (null action) action-at
599 (setq action (get-text-property action-at 'action)))
600 (if (not (and item action))
601 (error "There is nothing to follow here"))
602 (if (consp item) (error "There is nothing to follow in `%s'" (car item)))
603 (if other (set-buffer other))
604 (funcall action item)))
605
606
607
608 (defun apropos-describe-plist (symbol)
609 "Display a pretty listing of SYMBOL's plist."
610 (with-output-to-temp-buffer "*Help*"
611 (set-buffer standard-output)
612 (princ "Symbol ")
613 (prin1 symbol)
614 (princ "'s plist is\n (")
615 (if apropos-symbol-face
616 (put-text-property 8 (- (point) 14) 'face apropos-symbol-face))
617 (insert (apropos-format-plist symbol "\n "))
618 (princ ")")
619 (print-help-return-message)))
620
621 ;;; apropos.el ends here