1 ;;; apropos.el --- apropos commands for users and programmers
3 ;; Copyright (C) 1989, 1994, 1995, 2001, 2002, 2003, 2004,
4 ;; 2005 Free Software Foundation, Inc.
6 ;; Author: Joe Wells <jbw@bigbird.bu.edu>
7 ;; Rewritten: Daniel Pfeiffer <occitan@esperanto.org>
10 ;; This file is part of GNU Emacs.
12 ;; GNU Emacs is free software; you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 2, or (at your option)
17 ;; GNU Emacs is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;; GNU General Public License for more details.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs; see the file COPYING. If not, write to the
24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
25 ;; Boston, MA 02110-1301, USA.
29 ;; The ideas for this package were derived from the C code in
30 ;; src/keymap.c and elsewhere. The functions in this file should
31 ;; always be byte-compiled for speed. Someone should rewrite this in
32 ;; C (as part of src/keymap.c) for speed.
34 ;; The idea for super-apropos is based on the original implementation
35 ;; by Lynn Slater <lrs@esl.com>.
38 ;; Fixed bug, current-local-map can return nil.
39 ;; Change, doesn't calculate key-bindings unless needed.
40 ;; Added super-apropos capability, changed print functions.
41 ;;; Made fast-apropos and super-apropos share code.
42 ;;; Sped up fast-apropos again.
43 ;; Added apropos-do-all option.
44 ;;; Added fast-command-apropos.
45 ;; Changed doc strings to comments for helping functions.
46 ;;; Made doc file buffer read-only, buried it.
47 ;; Only call substitute-command-keys if do-all set.
49 ;; Optionally use configurable faces to make the output more legible.
50 ;; Differentiate between command, function and macro.
51 ;; Apropos-command (ex command-apropos) does cmd and optionally user var.
52 ;; Apropos shows all 3 aspects of symbols (fn, var and plist)
53 ;; Apropos-documentation (ex super-apropos) now finds all it should.
54 ;; New apropos-value snoops through all values and optionally plists.
55 ;; Reading DOC file doesn't load nroff.
56 ;; Added hypertext following of documentation, mouse-2 on variable gives value
57 ;; from buffer in active window.
62 (eval-when-compile (require 'cl
))
65 "Apropos commands for users and programmers."
69 ;; I see a degradation of maybe 10-20% only.
70 (defcustom apropos-do-all nil
71 "*Whether the apropos commands should do more.
73 Slows them down more or less. Set this non-nil if you have a fast machine."
78 (defcustom apropos-symbol-face
'bold
79 "*Face for symbol name in Apropos output, or nil for none."
83 (defcustom apropos-keybinding-face
'underline
84 "*Face for lists of keybinding in Apropos output, or nil for none."
88 (defcustom apropos-label-face
'italic
89 "*Face for label (`Command', `Variable' ...) in Apropos output.
90 A value of nil means don't use any special font for them, and also
91 turns off mouse highlighting."
95 (defcustom apropos-property-face
'bold-italic
96 "*Face for property name in apropos output, or nil for none."
100 (defcustom apropos-match-face
'match
101 "*Face for matching text in Apropos documentation/value, or nil for none.
102 This applies when you look for matches in the documentation or variable value
103 for the pattern; the part that matches gets displayed in this font."
107 (defcustom apropos-sort-by-scores nil
108 "*Non-nil means sort matches by scores; best match is shown first.
109 This applies to all `apropos' commands except `apropos-documentation'.
110 If value is `verbose', the computed score is shown for each match."
112 :type
'(choice (const :tag
"off" nil
)
114 (const :tag
"show scores" verbose
)))
116 (defcustom apropos-documentation-sort-by-scores t
117 "*Non-nil means sort matches by scores; best match is shown first.
118 This applies to `apropos-documentation' only.
119 If value is `verbose', the computed score is shown for each match."
121 :type
'(choice (const :tag
"off" nil
)
123 (const :tag
"show scores" verbose
)))
125 (defvar apropos-mode-map
126 (let ((map (make-sparse-keymap)))
127 (set-keymap-parent map button-buffer-map
)
128 ;; Use `apropos-follow' instead of just using the button
129 ;; definition of RET, so that users can use it anywhere in an
130 ;; apropos item, not just on top of a button.
131 (define-key map
"\C-m" 'apropos-follow
)
132 (define-key map
" " 'scroll-up
)
133 (define-key map
"\177" 'scroll-down
)
134 (define-key map
"q" 'quit-window
)
136 "Keymap used in Apropos mode.")
138 (defvar apropos-mode-hook nil
139 "*Hook run when mode is turned on.")
141 (defvar apropos-pattern nil
142 "Apropos pattern as entered by user.")
144 (defvar apropos-pattern-quoted nil
145 "Apropos pattern passed through `regexp-quoute'.")
147 (defvar apropos-words
()
148 "Current list of apropos words extracted from `apropos-pattern'.")
150 (defvar apropos-all-words
()
151 "Current list of words and synonyms.")
153 (defvar apropos-regexp nil
154 "Regexp used in current apropos run.")
156 (defvar apropos-all-words-regexp nil
157 "Regexp matching apropos-all-words.")
159 (defvar apropos-files-scanned
()
160 "List of elc files already scanned in current run of `apropos-documentation'.")
162 (defvar apropos-accumulator
()
163 "Alist of symbols already found in current apropos run.")
165 (defvar apropos-item
()
166 "Current item in or for `apropos-accumulator'.")
168 (defvar apropos-synonyms
'(
169 ("find" "open" "edit")
172 "List of synonyms known by apropos.
173 Each element is a list of words where the first word is the standard emacs
174 term, and the rest of the words are alternative terms.")
177 ;;; Button types used by apropos
179 (define-button-type 'apropos-symbol
180 'face apropos-symbol-face
181 'help-echo
"mouse-2, RET: Display more help on this symbol"
183 'action
#'apropos-symbol-button-display-help
186 (defun apropos-symbol-button-display-help (button)
187 "Display further help for the `apropos-symbol' button BUTTON."
189 (or (apropos-next-label-button (button-start button
))
190 (error "There is nothing to follow for `%s'" (button-label button
)))))
192 (define-button-type 'apropos-function
193 'apropos-label
"Function"
194 'help-echo
"mouse-2, RET: Display more help on this function"
196 'action
(lambda (button)
197 (describe-function (button-get button
'apropos-symbol
))))
199 (define-button-type 'apropos-macro
200 'apropos-label
"Macro"
201 'help-echo
"mouse-2, RET: Display more help on this macro"
203 'action
(lambda (button)
204 (describe-function (button-get button
'apropos-symbol
))))
206 (define-button-type 'apropos-command
207 'apropos-label
"Command"
208 'help-echo
"mouse-2, RET: Display more help on this command"
210 'action
(lambda (button)
211 (describe-function (button-get button
'apropos-symbol
))))
213 ;; We used to use `customize-variable-other-window' instead for a
214 ;; customizable variable, but that is slow. It is better to show an
215 ;; ordinary help buffer and let the user click on the customization
216 ;; button in that buffer, if he wants to.
217 ;; Likewise for `customize-face-other-window'.
218 (define-button-type 'apropos-variable
219 'apropos-label
"Variable"
220 'help-echo
"mouse-2, RET: Display more help on this variable"
222 'action
(lambda (button)
223 (describe-variable (button-get button
'apropos-symbol
))))
225 (define-button-type 'apropos-face
226 'apropos-label
"Face"
227 'help-echo
"mouse-2, RET: Display more help on this face"
229 'action
(lambda (button)
230 (describe-face (button-get button
'apropos-symbol
))))
232 (define-button-type 'apropos-group
233 'apropos-label
"Group"
234 'help-echo
"mouse-2, RET: Display more help on this group"
236 'action
(lambda (button)
237 (customize-group-other-window
238 (button-get button
'apropos-symbol
))))
240 (define-button-type 'apropos-widget
241 'apropos-label
"Widget"
242 'help-echo
"mouse-2, RET: Display more help on this widget"
244 'action
(lambda (button)
245 (widget-browse-other-window (button-get button
'apropos-symbol
))))
247 (define-button-type 'apropos-plist
248 'apropos-label
"Plist"
249 'help-echo
"mouse-2, RET: Display more help on this plist"
251 'action
(lambda (button)
252 (apropos-describe-plist (button-get button
'apropos-symbol
))))
254 (defun apropos-next-label-button (pos)
255 "Return the next apropos label button after POS, or nil if there's none.
256 Will also return nil if more than one `apropos-symbol' button is encountered
257 before finding a label."
258 (let* ((button (next-button pos t
))
259 (already-hit-symbol nil
)
260 (label (and button
(button-get button
'apropos-label
)))
261 (type (and button
(button-get button
'type
))))
264 (or (not (eq type
'apropos-symbol
))
265 (not already-hit-symbol
)))
266 (when (eq type
'apropos-symbol
)
267 (setq already-hit-symbol t
))
268 (setq button
(next-button (button-start button
)))
270 (setq label
(button-get button
'apropos-label
))
271 (setq type
(button-get button
'type
))))
275 (defun apropos-words-to-regexp (words wild
)
276 "Make regexp matching any two of the words in WORDS."
278 (mapconcat 'identity words
"\\|")
283 (mapconcat 'identity words
"\\|")
288 (defun apropos-read-pattern (subject)
289 "Read an apropos pattern, either a word list or a regexp.
290 Returns the user pattern, either a list of words which are matched
291 literally, or a string which is used as a regexp to search for.
293 SUBJECT is a string that is included in the prompt to identify what
294 kind of objects to search."
296 (read-string (concat "Apropos " subject
" (word list or regexp): "))))
297 (if (string-equal (regexp-quote pattern
) pattern
)
299 (split-string pattern
"[ \t]+")
302 (defun apropos-parse-pattern (pattern)
303 "Rewrite a list of words to a regexp matching all permutations.
304 If PATTERN is a string, that means it is already a regexp.
305 This updates variables `apropos-pattern', `apropos-pattern-quoted',
306 `apropos-regexp', `apropos-words', and `apropos-all-words-regexp'."
307 (setq apropos-words nil
308 apropos-all-words nil
)
310 ;; We don't actually make a regexp matching all permutations.
311 ;; Instead, for e.g. "a b c", we make a regexp matching
312 ;; any combination of two or more words like this:
313 ;; (a|b|c).*(a|b|c) which may give some false matches,
314 ;; but as long as it also gives the right ones, that's ok.
315 (let ((words pattern
))
316 (setq apropos-pattern
(mapconcat 'identity pattern
" ")
317 apropos-pattern-quoted
(regexp-quote apropos-pattern
))
319 (let ((syn apropos-synonyms
) (s word
) (a word
))
321 (if (member word
(car syn
))
323 (setq a
(mapconcat 'identity
(car syn
) "\\|"))
324 (if (member word
(cdr (car syn
)))
327 (setq syn
(cdr syn
))))
328 (setq apropos-words
(cons s apropos-words
)
329 apropos-all-words
(cons a apropos-all-words
))))
330 (setq apropos-all-words-regexp
331 (apropos-words-to-regexp apropos-all-words
".+"))
333 (apropos-words-to-regexp apropos-words
".*?")))
334 (setq apropos-pattern-quoted
(regexp-quote pattern
)
335 apropos-all-words-regexp pattern
336 apropos-pattern pattern
337 apropos-regexp pattern
)))
340 (defun apropos-calc-scores (str words
)
341 "Return apropos scores for string STR matching WORDS.
342 Value is a list of offsets of the words into the string."
345 (dolist (word words scores
)
346 (if (setq i
(string-match word str
))
347 (setq scores
(cons i scores
))))
348 ;; Return list of start and end position of regexp
349 (and (string-match apropos-pattern str
)
350 (list (match-beginning 0) (match-end 0))))))
352 (defun apropos-score-str (str)
353 "Return apropos score for string STR."
355 (let* ((l (length str
))
356 (score (- (/ l
10))))
357 (dolist (s (apropos-calc-scores str apropos-all-words
) score
)
358 (setq score
(+ score
1000 (/ (* (- l s
) 1000) l
)))))
361 (defun apropos-score-doc (doc)
362 "Return apropos score for documentation string DOC."
363 (let ((l (length doc
)))
366 (when (setq i
(string-match apropos-pattern-quoted doc
))
368 (dolist (s (apropos-calc-scores doc apropos-all-words
) score
)
369 (setq score
(+ score
50 (/ (* (- l s
) 50) l
)))))
372 (defun apropos-score-symbol (symbol &optional weight
)
373 "Return apropos score for SYMBOL."
374 (setq symbol
(symbol-name symbol
))
377 (dolist (s (apropos-calc-scores symbol apropos-words
) (* score
(or weight
3)))
378 (setq score
(+ score
(- 60 l
) (/ (* (- l s
) 60) l
))))))
380 (defun apropos-true-hit (str words
)
381 "Return t if STR is a genuine hit.
382 This may fail if only one of the keywords is matched more than once.
383 This requires that at least 2 keywords (unless only one was given)."
387 (> (length (apropos-calc-scores str words
)) 1)))
389 (defun apropos-false-hit-symbol (symbol)
390 "Return t if SYMBOL is not really matched by the current keywords."
391 (not (apropos-true-hit (symbol-name symbol
) apropos-words
)))
393 (defun apropos-false-hit-str (str)
394 "Return t if STR is not really matched by the current keywords."
395 (not (apropos-true-hit str apropos-words
)))
397 (defun apropos-true-hit-doc (doc)
398 "Return t if DOC is really matched by the current keywords."
399 (apropos-true-hit doc apropos-all-words
))
401 (define-derived-mode apropos-mode fundamental-mode
"Apropos"
402 "Major mode for following hyperlinks in output of apropos commands.
404 \\{apropos-mode-map}")
407 (defun apropos-variable (pattern &optional do-all
)
408 "Show user variables that match PATTERN.
409 PATTERN can be a word, a list of words (separated by spaces),
410 or a regexp (using some regexp special characters). If it is a word,
411 search for matches for that word as a substring. If it is a list of words,
412 search for matches for any two (or more) of those words.
414 With \\[universal-argument] prefix, or if `apropos-do-all' is non-nil, also show
416 (interactive (list (apropos-read-pattern
417 (if (or current-prefix-arg apropos-do-all
)
418 "variable" "user option"))
420 (apropos-command pattern nil
421 (if (or do-all apropos-do-all
)
424 (get symbol
'variable-documentation
)))
427 ;; For auld lang syne:
429 (defalias 'command-apropos
'apropos-command
)
431 (defun apropos-command (pattern &optional do-all var-predicate
)
432 "Show commands (interactively callable functions) that match PATTERN.
433 PATTERN can be a word, a list of words (separated by spaces),
434 or a regexp (using some regexp special characters). If it is a word,
435 search for matches for that word as a substring. If it is a list of words,
436 search for matches for any two (or more) of those words.
438 With \\[universal-argument] prefix, or if `apropos-do-all' is non-nil, also show
439 noninteractive functions.
441 If VAR-PREDICATE is non-nil, show only variables, and only those that
442 satisfy the predicate VAR-PREDICATE.
444 When called from a Lisp program, a string PATTERN is used as a regexp,
445 while a list of strings is used as a word list."
446 (interactive (list (apropos-read-pattern
447 (if (or current-prefix-arg apropos-do-all
)
448 "command or function" "command"))
450 (apropos-parse-pattern pattern
)
452 (let ((standard-output (get-buffer-create "*Apropos*")))
453 (print-help-return-message 'identity
))))
454 (or do-all
(setq do-all apropos-do-all
))
455 (setq apropos-accumulator
456 (apropos-internal apropos-regexp
458 (if do-all
'functionp
'commandp
))))
459 (let ((tem apropos-accumulator
))
461 (if (or (get (car tem
) 'apropos-inhibit
)
462 (apropos-false-hit-symbol (car tem
)))
463 (setq apropos-accumulator
(delq (car tem
) apropos-accumulator
)))
464 (setq tem
(cdr tem
))))
465 (let ((p apropos-accumulator
)
469 (setq symbol
(car p
))
470 (setq score
(apropos-score-symbol symbol
))
471 (unless var-predicate
472 (if (functionp symbol
)
473 (if (setq doc
(documentation symbol t
))
475 (setq score
(+ score
(apropos-score-doc doc
)))
476 (substring doc
0 (string-match "\n" doc
)))
477 "(not documented)")))
479 (funcall var-predicate symbol
)
480 (if (setq doc
(documentation-property
481 symbol
'variable-documentation t
))
483 (setq score
(+ score
(apropos-score-doc doc
)))
485 (string-match "\n" doc
)))))))
486 (setcar (cdr (car p
)) score
)
488 (and (apropos-print t nil nil t
)
490 (message "%s" message
))))
494 (defun apropos-documentation-property (symbol property raw
)
495 "Like (documentation-property SYMBOL PROPERTY RAW) but handle errors."
497 (let ((doc (documentation-property symbol property raw
)))
498 (if doc
(substring doc
0 (string-match "\n" doc
))
500 (error "(error retrieving documentation)")))
504 (defun apropos (pattern &optional do-all
)
505 "Show all bound symbols whose names match PATTERN.
506 PATTERN can be a word, a list of words (separated by spaces),
507 or a regexp (using some regexp special characters). If it is a word,
508 search for matches for that word as a substring. If it is a list of words,
509 search for matches for any two (or more) of those words.
511 With \\[universal-argument] prefix, or if `apropos-do-all' is non-nil, also
512 show unbound symbols and key bindings, which is a little more
513 time-consuming. Returns list of symbols and documentation found."
514 (interactive (list (apropos-read-pattern "symbol")
516 (apropos-parse-pattern pattern
)
517 (apropos-symbols-internal
518 (apropos-internal apropos-regexp
525 (symbol-plist symbol
)))))
526 (or do-all apropos-do-all
)))
528 (defun apropos-symbols-internal (symbols keys
&optional text
)
529 ;; Filter out entries that are marked as apropos-inhibit.
531 (dolist (symbol symbols
)
532 (unless (get symbol
'apropos-inhibit
)
535 (let ((apropos-accumulator
538 (let (doc properties
)
541 (apropos-score-symbol symbol
)
542 (when (fboundp symbol
)
543 (if (setq doc
(condition-case nil
544 (documentation symbol t
)
546 "(alias for undefined function)")
548 "(can't retrieve function documentation)")))
549 (substring doc
0 (string-match "\n" doc
))
551 (when (boundp symbol
)
552 (apropos-documentation-property
553 symbol
'variable-documentation t
))
554 (when (setq properties
(symbol-plist symbol
))
555 (setq doc
(list (car properties
)))
556 (while (setq properties
(cdr (cdr properties
)))
557 (setq doc
(cons (car properties
) doc
)))
558 (mapconcat #'symbol-name
(nreverse doc
) " "))
559 (when (get symbol
'widget-type
)
560 (apropos-documentation-property
561 symbol
'widget-documentation t
))
563 (apropos-documentation-property
564 symbol
'face-documentation t
))
565 (when (get symbol
'custom-group
)
566 (apropos-documentation-property
567 symbol
'group-documentation t
)))))
569 (apropos-print keys nil text
)))
573 (defun apropos-value (pattern &optional do-all
)
574 "Show all symbols whose value's printed image matches PATTERN.
575 PATTERN can be a word, a list of words (separated by spaces),
576 or a regexp (using some regexp special characters). If it is a word,
577 search for matches for that word as a substring. If it is a list of words,
578 search for matches for any two (or more) of those words.
580 With \\[universal-argument] prefix, or if `apropos-do-all' is non-nil, also looks
581 at the function and at the names and values of properties.
582 Returns list of symbols and values found."
583 (interactive (list (apropos-read-pattern "value")
585 (apropos-parse-pattern pattern
)
586 (or do-all
(setq do-all apropos-do-all
))
587 (setq apropos-accumulator
())
591 (setq f nil v nil p nil
)
592 (or (memq symbol
'(apropos-regexp
593 apropos-pattern apropos-all-words-regexp
594 apropos-words apropos-all-words
595 do-all apropos-accumulator
597 (setq v
(apropos-value-internal 'boundp symbol
'symbol-value
)))
599 (setq f
(apropos-value-internal 'fboundp symbol
'symbol-function
)
600 p
(apropos-format-plist symbol
"\n " t
)))
601 (if (apropos-false-hit-str v
)
603 (if (apropos-false-hit-str f
)
605 (if (apropos-false-hit-str p
)
608 (setq apropos-accumulator
(cons (list symbol
609 (+ (apropos-score-str f
)
610 (apropos-score-str v
)
611 (apropos-score-str p
))
613 apropos-accumulator
))))))
614 (apropos-print nil
"\n----------------\n"))
618 (defun apropos-documentation (pattern &optional do-all
)
619 "Show symbols whose documentation contain matches for PATTERN.
620 PATTERN can be a word, a list of words (separated by spaces),
621 or a regexp (using some regexp special characters). If it is a word,
622 search for matches for that word as a substring. If it is a list of words,
623 search for matches for any two (or more) of those words.
625 With \\[universal-argument] prefix, or if `apropos-do-all' is non-nil, also use
626 documentation that is not stored in the documentation file and show key
628 Returns list of symbols and documentation found."
629 (interactive (list (apropos-read-pattern "documentation")
631 (apropos-parse-pattern pattern
)
632 (or do-all
(setq do-all apropos-do-all
))
633 (setq apropos-accumulator
() apropos-files-scanned
())
634 (let ((standard-input (get-buffer-create " apropos-temp"))
635 (apropos-sort-by-scores apropos-documentation-sort-by-scores
)
639 (set-buffer standard-input
)
640 (apropos-documentation-check-doc-file)
644 (setq f
(apropos-safe-documentation symbol
)
645 v
(get symbol
'variable-documentation
))
646 (if (integerp v
) (setq v
))
647 (setq f
(apropos-documentation-internal f
)
648 v
(apropos-documentation-internal v
))
649 (setq sf
(apropos-score-doc f
)
650 sv
(apropos-score-doc v
))
652 (if (setq apropos-item
653 (cdr (assq symbol apropos-accumulator
)))
657 (setcar (nthcdr 1 apropos-item
) f
)
658 (setcar apropos-item
(+ (car apropos-item
) sf
))))
661 (setcar (nthcdr 2 apropos-item
) v
)
662 (setcar apropos-item
(+ (car apropos-item
) sv
)))))
663 (setq apropos-accumulator
665 (+ (apropos-score-symbol symbol
2) sf sv
)
667 apropos-accumulator
)))))))
668 (apropos-print nil
"\n----------------\n" nil t
))
669 (kill-buffer standard-input
))))
672 (defun apropos-value-internal (predicate symbol function
)
673 (if (funcall predicate symbol
)
675 (setq symbol
(prin1-to-string (funcall function symbol
)))
676 (if (string-match apropos-regexp symbol
)
678 (if apropos-match-face
679 (put-text-property (match-beginning 0) (match-end 0)
680 'face apropos-match-face
684 (defun apropos-documentation-internal (doc)
686 (apropos-documentation-check-elc-file (car doc
))
688 (string-match apropos-all-words-regexp doc
)
689 (apropos-true-hit-doc doc
))
690 (when apropos-match-face
691 (setq doc
(substitute-command-keys (copy-sequence doc
)))
692 (if (or (string-match apropos-pattern-quoted doc
)
693 (string-match apropos-all-words-regexp doc
))
694 (put-text-property (match-beginning 0)
696 'face apropos-match-face doc
))
699 (defun apropos-format-plist (pl sep
&optional compare
)
700 (setq pl
(symbol-plist pl
))
703 (setq p
(format "%s %S" (car pl
) (nth 1 pl
)))
704 (if (or (not compare
) (string-match apropos-regexp p
))
705 (if apropos-property-face
706 (put-text-property 0 (length (symbol-name (car pl
)))
707 'face apropos-property-face p
))
711 (and compare apropos-match-face
712 (put-text-property (match-beginning 0) (match-end 0)
713 'face apropos-match-face
715 (setq p-out
(concat p-out
(if p-out sep
) p
))))
716 (setq pl
(nthcdr 2 pl
)))
720 ;; Finds all documentation related to APROPOS-REGEXP in internal-doc-file-name.
722 (defun apropos-documentation-check-doc-file ()
723 (let (type symbol
(sepa 2) sepb
)
726 (insert-file-contents (concat doc-directory internal-doc-file-name
))
728 (while (save-excursion
729 (setq sepb
(search-forward "\^_"))
731 (beginning-of-line 2)
732 (if (save-restriction
733 (narrow-to-region (point) (1- sepb
))
734 (re-search-forward apropos-all-words-regexp nil t
))
736 (goto-char (1+ sepa
))
737 (setq type
(if (eq ?F
(preceding-char))
738 2 ; function documentation
739 3) ; variable documentation
741 doc
(buffer-substring (1+ (point)) (1- sepb
)))
742 (when (apropos-true-hit-doc doc
)
743 (or (and (setq apropos-item
(assq symbol apropos-accumulator
))
744 (setcar (cdr apropos-item
)
745 (apropos-score-doc doc
)))
746 (setq apropos-item
(list symbol
747 (+ (apropos-score-symbol symbol
2)
748 (apropos-score-doc doc
))
750 apropos-accumulator
(cons apropos-item
751 apropos-accumulator
)))
752 (when apropos-match-face
753 (setq doc
(substitute-command-keys doc
))
754 (if (or (string-match apropos-pattern-quoted doc
)
755 (string-match apropos-all-words-regexp doc
))
756 (put-text-property (match-beginning 0)
758 'face apropos-match-face doc
)))
759 (setcar (nthcdr type apropos-item
) doc
))))
760 (setq sepa
(goto-char sepb
)))))
762 (defun apropos-documentation-check-elc-file (file)
763 (if (member file apropos-files-scanned
)
765 (let (symbol doc beg end this-is-a-variable
)
766 (setq apropos-files-scanned
(cons file apropos-files-scanned
))
768 (insert-file-contents file
)
769 (while (search-forward "\n#@" nil t
)
770 ;; Read the comment length, and advance over it.
773 end
(+ (point) end -
1))
775 (if (save-restriction
776 ;; match ^ and $ relative to doc string
777 (narrow-to-region beg end
)
778 (re-search-forward apropos-all-words-regexp nil t
))
780 (goto-char (+ end
2))
781 (setq doc
(buffer-substring beg end
)
782 end
(- (match-end 0) beg
)
783 beg
(- (match-beginning 0) beg
))
784 (when (apropos-true-hit-doc doc
)
785 (setq this-is-a-variable
(looking-at "(def\\(var\\|const\\) ")
787 (skip-chars-forward "(a-z")
790 symbol
(if (consp symbol
)
793 (if (if this-is-a-variable
794 (get symbol
'variable-documentation
)
795 (and (fboundp symbol
) (apropos-safe-documentation symbol
)))
797 (or (and (setq apropos-item
(assq symbol apropos-accumulator
))
798 (setcar (cdr apropos-item
)
799 (+ (cadr apropos-item
) (apropos-score-doc doc
))))
800 (setq apropos-item
(list symbol
801 (+ (apropos-score-symbol symbol
2)
802 (apropos-score-doc doc
))
804 apropos-accumulator
(cons apropos-item
805 apropos-accumulator
)))
806 (when apropos-match-face
807 (setq doc
(substitute-command-keys doc
))
808 (if (or (string-match apropos-pattern-quoted doc
)
809 (string-match apropos-all-words-regexp doc
))
810 (put-text-property (match-beginning 0)
812 'face apropos-match-face doc
)))
813 (setcar (nthcdr (if this-is-a-variable
3 2)
819 (defun apropos-safe-documentation (function)
820 "Like `documentation', except it avoids calling `get_doc_string'.
821 Will return nil instead."
822 (while (and function
(symbolp function
))
823 (setq function
(if (fboundp function
)
824 (symbol-function function
))))
825 (if (eq (car-safe function
) 'macro
)
826 (setq function
(cdr function
)))
827 (setq function
(if (byte-code-function-p function
)
828 (if (> (length function
) 4)
830 (if (eq (car-safe function
) 'autoload
)
832 (if (eq (car-safe function
) 'lambda
)
833 (if (stringp (nth 2 function
))
835 (if (stringp (nth 3 function
))
836 (nth 3 function
)))))))
837 (if (integerp function
)
842 (defun apropos-print (do-keys spacing
&optional text nosubst
)
843 "Output result of apropos searching into buffer `*Apropos*'.
844 The value of `apropos-accumulator' is the list of items to output.
845 Each element should have the format
846 (SYMBOL SCORE FN-DOC VAR-DOC [PLIST-DOC WIDGET-DOC FACE-DOC GROUP-DOC]).
847 The return value is the list that was in `apropos-accumulator', sorted
848 alphabetically by symbol name; but this function also sets
849 `apropos-accumulator' to nil before returning.
851 If SPACING is non-nil, it should be a string; separate items with that string.
852 If non-nil TEXT is a string that will be printed as a heading."
853 (if (null apropos-accumulator
)
854 (message "No apropos matches for `%s'" apropos-pattern
)
855 (setq apropos-accumulator
856 (sort apropos-accumulator
858 ;; Don't sort by score if user can't see the score.
859 ;; It would be confusing. -- rms.
860 (if apropos-sort-by-scores
861 (or (> (cadr a
) (cadr b
))
862 (and (= (cadr a
) (cadr b
))
863 (string-lessp (car a
) (car b
))))
864 (string-lessp (car a
) (car b
))))))
865 (with-output-to-temp-buffer "*Apropos*"
866 (let ((p apropos-accumulator
)
867 (old-buffer (current-buffer))
869 (set-buffer standard-output
)
871 (if (display-mouse-p)
873 "If moving the mouse over text changes the text's color, "
875 "mouse-2 (second button from right) on that text to "
876 "get more information.\n"))
877 (insert "In this buffer, go to the name of the command, or function,"
879 (substitute-command-keys
880 "and type \\[apropos-follow] to get full documentation.\n\n"))
881 (if text
(insert text
"\n\n"))
883 (when (and spacing
(not (bobp)))
885 (setq apropos-item
(car p
)
886 symbol
(car apropos-item
)
888 ;; Insert dummy score element for backwards compatibility with 21.x
889 ;; apropos-item format.
890 (if (not (numberp (cadr apropos-item
)))
892 (cons (car apropos-item
)
893 (cons nil
(cdr apropos-item
)))))
894 (insert-text-button (symbol-name symbol
)
895 'type
'apropos-symbol
896 ;; Can't use default, since user may have
897 ;; changed the variable!
898 ;; Just say `no' to variables containing faces!
899 'face apropos-symbol-face
)
900 (if (and (eq apropos-sort-by-scores
'verbose
)
902 (insert " (" (number-to-string (cadr apropos-item
)) ") "))
903 ;; Calculate key-bindings if we want them.
909 (set-buffer old-buffer
)
910 (where-is-internal symbol
)))
912 ;; Copy over the list of key sequences,
913 ;; omitting any that contain a buffer or a frame.
915 (let ((key (car keys
))
918 (while (< i
(length key
))
919 (if (or (framep (aref key i
))
920 (bufferp (aref key i
)))
924 (setq filtered
(cons key filtered
))))
925 (setq keys
(cdr keys
)))
926 (setq item filtered
))
927 ;; Convert the remaining keys to a string and insert.
931 (setq key
(condition-case ()
932 (key-description key
)
934 (if apropos-keybinding-face
935 (put-text-property 0 (length key
)
936 'face apropos-keybinding-face
940 (insert "M-x ... RET")
941 (when apropos-keybinding-face
942 (put-text-property (- (point) 11) (- (point) 8)
943 'face apropos-keybinding-face
)
944 (put-text-property (- (point) 3) (point)
945 'face apropos-keybinding-face
))))
948 (if (commandp symbol
)
950 (if (apropos-macrop symbol
)
954 (apropos-print-doc 3 'apropos-variable
(not nosubst
))
955 (apropos-print-doc 7 'apropos-group t
)
956 (apropos-print-doc 6 'apropos-face t
)
957 (apropos-print-doc 5 'apropos-widget t
)
958 (apropos-print-doc 4 'apropos-plist nil
))
959 (setq buffer-read-only t
))))
960 (prog1 apropos-accumulator
961 (setq apropos-accumulator
()))) ; permit gc
964 (defun apropos-macrop (symbol)
965 "Return t if SYMBOL is a Lisp macro."
966 (and (fboundp symbol
)
968 (symbol-function symbol
)))
969 (or (eq (car symbol
) 'macro
)
970 (if (eq (car symbol
) 'autoload
)
975 (defun apropos-print-doc (i type do-keys
)
976 (if (stringp (setq i
(nth i apropos-item
)))
979 (insert-text-button (button-type-get type
'apropos-label
)
981 ;; Can't use the default button face, since
982 ;; user may have changed the variable!
983 ;; Just say `no' to variables containing faces!
984 'face apropos-label-face
985 'apropos-symbol
(car apropos-item
))
987 (insert (if do-keys
(substitute-command-keys i
) i
))
988 (or (bolp) (terpri)))))
991 (defun apropos-follow ()
992 "Invokes any button at point, otherwise invokes the nearest label button."
995 (or (apropos-next-label-button (line-beginning-position))
996 (error "There is nothing to follow here"))))
999 (defun apropos-describe-plist (symbol)
1000 "Display a pretty listing of SYMBOL's plist."
1001 (help-setup-xref (list 'apropos-describe-plist symbol
) (interactive-p))
1002 (with-output-to-temp-buffer (help-buffer)
1003 (set-buffer standard-output
)
1006 (princ "'s plist is\n (")
1007 (if apropos-symbol-face
1008 (put-text-property (+ (point-min) 7) (- (point) 14)
1009 'face apropos-symbol-face
))
1010 (insert (apropos-format-plist symbol
"\n "))
1012 (print-help-return-message)))
1017 ;;; arch-tag: d56fa2ac-e56b-4ce3-84ff-852f9c0dc66e
1018 ;;; apropos.el ends here