;;; apropos.el --- apropos commands for users and programmers
-;; Copyright (C) 1989, 1994, 1995, 2001, 2002, 2003, 2004, 2005, 2006,
-;; 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 1989, 1994-1995, 2001-2013 Free Software Foundation,
+;; Inc.
;; Author: Joe Wells <jbw@bigbird.bu.edu>
;; Daniel Pfeiffer <occitan@esperanto.org> (rewrite)
;; Keywords: help
+;; Package: emacs
;; This file is part of GNU Emacs.
;; Fixed bug, current-local-map can return nil.
;; Change, doesn't calculate key-bindings unless needed.
;; Added super-apropos capability, changed print functions.
-;;; Made fast-apropos and super-apropos share code.
-;;; Sped up fast-apropos again.
+;; Made fast-apropos and super-apropos share code.
+;; Sped up fast-apropos again.
;; Added apropos-do-all option.
-;;; Added fast-command-apropos.
+;; Added fast-command-apropos.
;; Changed doc strings to comments for helping functions.
-;;; Made doc file buffer read-only, buried it.
+;; Made doc file buffer read-only, buried it.
;; Only call substitute-command-keys if do-all set.
;; Optionally use configurable faces to make the output more legible.
;;; Code:
(require 'button)
-(eval-when-compile (require 'cl))
(defgroup apropos nil
"Apropos commands for users and programmers."
;; I see a degradation of maybe 10-20% only.
(defcustom apropos-do-all nil
- "Whether the apropos commands should do more.
-
-Slows them down more or less. Set this non-nil if you have a fast machine."
+ "Non nil means apropos commands will search more extensively.
+This may be slower. This option affects the following commands:
+
+`apropos-user-option' will search all variables, not just user options.
+`apropos-command' will also search non-interactive functions.
+`apropos' will search all symbols, not just functions, variables, faces,
+and those with property lists.
+`apropos-value' will also search in property lists and functions.
+`apropos-documentation' will search all documentation strings, not just
+those in the etc/DOC documentation file.
+
+This option only controls the default behavior. Each of the above
+commands also has an optional argument to request a more extensive search.
+
+Additionally, this option makes the function `apropos-library'
+include key-binding information in its output."
:group 'apropos
:type 'boolean)
+(defface apropos-symbol
+ '((t (:inherit bold)))
+ "Face for the symbol name in Apropos output."
+ :group 'apropos
+ :version "24.3")
+
+(defface apropos-keybinding
+ '((t (:inherit underline)))
+ "Face for lists of keybinding in Apropos output."
+ :group 'apropos
+ :version "24.3")
-(defcustom apropos-symbol-face 'bold
- "Face for symbol name in Apropos output, or nil for none."
+(defface apropos-property
+ '((t (:inherit font-lock-builtin-face)))
+ "Face for property name in apropos output, or nil for none."
:group 'apropos
- :type 'face)
+ :version "24.3")
-(defcustom apropos-keybinding-face 'underline
- "Face for lists of keybinding in Apropos output, or nil for none."
+(defface apropos-function-button
+ '((t (:inherit (font-lock-function-name-face button))))
+ "Button face indicating a function, macro, or command in Apropos."
:group 'apropos
- :type 'face)
+ :version "24.3")
-(defcustom apropos-label-face '(italic variable-pitch)
- "Face for label (`Command', `Variable' ...) in Apropos output.
-A value of nil means don't use any special font for them, and also
-turns off mouse highlighting."
+(defface apropos-variable-button
+ '((t (:inherit (font-lock-variable-name-face button))))
+ "Button face indicating a variable in Apropos."
:group 'apropos
- :type 'face)
+ :version "24.3")
-(defcustom apropos-property-face 'bold-italic
- "Face for property name in apropos output, or nil for none."
+(defface apropos-user-option-button
+ '((t (:inherit (font-lock-variable-name-face button))))
+ "Button face indicating a user option in Apropos."
:group 'apropos
- :type 'face)
+ :version "24.4")
+
+(defface apropos-misc-button
+ '((t (:inherit (font-lock-constant-face button))))
+ "Button face indicating a miscellaneous object type in Apropos."
+ :group 'apropos
+ :version "24.3")
(defcustom apropos-match-face 'match
"Face for matching text in Apropos documentation/value, or nil for none.
This applies when you look for matches in the documentation or variable value
for the pattern; the part that matches gets displayed in this font."
:group 'apropos
- :type 'face)
+ :version "24.3")
(defcustom apropos-sort-by-scores nil
"Non-nil means sort matches by scores; best match is shown first.
(const :tag "show scores" verbose)))
(defvar apropos-mode-map
- (let ((map (make-sparse-keymap)))
- (set-keymap-parent map button-buffer-map)
+ (let ((map (copy-keymap button-buffer-map)))
+ (set-keymap-parent map special-mode-map)
;; Use `apropos-follow' instead of just using the button
;; definition of RET, so that users can use it anywhere in an
;; apropos item, not just on top of a button.
(define-key map "\C-m" 'apropos-follow)
- (define-key map " " 'scroll-up)
- (define-key map "\177" 'scroll-down)
- (define-key map "q" 'quit-window)
map)
"Keymap used in Apropos mode.")
"List of elc files already scanned in current run of `apropos-documentation'.")
(defvar apropos-accumulator ()
- "Alist of symbols already found in current apropos run.")
+ "Alist of symbols already found in current apropos run.
+Each element has the form
+
+ (SYMBOL SCORE FUN-DOC VAR-DOC PLIST WIDGET-DOC FACE-DOC CUS-GROUP-DOC)
+
+where SYMBOL is the symbol name, SCORE is its relevance score (a
+number), FUN-DOC is the function docstring, VAR-DOC is the
+variable docstring, PLIST is the list of the symbols names in the
+property list, WIDGET-DOC is the widget docstring, FACE-DOC is
+the face docstring, and CUS-GROUP-DOC is the custom group
+docstring. Each docstring is either nil or a string.")
(defvar apropos-item ()
"Current item in or for `apropos-accumulator'.")
;;; Button types used by apropos
(define-button-type 'apropos-symbol
- 'face apropos-symbol-face
+ 'face 'apropos-symbol
'help-echo "mouse-2, RET: Display more help on this symbol"
'follow-link t
'action #'apropos-symbol-button-display-help)
(define-button-type 'apropos-function
'apropos-label "Function"
'apropos-short-label "f"
+ 'face 'apropos-function-button
'help-echo "mouse-2, RET: Display more help on this function"
'follow-link t
'action (lambda (button)
(define-button-type 'apropos-macro
'apropos-label "Macro"
'apropos-short-label "m"
+ 'face 'apropos-function-button
'help-echo "mouse-2, RET: Display more help on this macro"
'follow-link t
'action (lambda (button)
(define-button-type 'apropos-command
'apropos-label "Command"
'apropos-short-label "c"
+ 'face 'apropos-function-button
'help-echo "mouse-2, RET: Display more help on this command"
'follow-link t
'action (lambda (button)
(define-button-type 'apropos-variable
'apropos-label "Variable"
'apropos-short-label "v"
+ 'face 'apropos-variable-button
'help-echo "mouse-2, RET: Display more help on this variable"
'follow-link t
'action (lambda (button)
(describe-variable (button-get button 'apropos-symbol))))
+(define-button-type 'apropos-user-option
+ 'apropos-label "User option"
+ 'apropos-short-label "o"
+ 'face 'apropos-user-option-button
+ 'help-echo "mouse-2, RET: Display more help on this user option"
+ 'follow-link t
+ 'action (lambda (button)
+ (describe-variable (button-get button 'apropos-symbol))))
+
(define-button-type 'apropos-face
'apropos-label "Face"
'apropos-short-label "F"
+ 'face '(font-lock-variable-name-face button)
'help-echo "mouse-2, RET: Display more help on this face"
'follow-link t
'action (lambda (button)
(define-button-type 'apropos-group
'apropos-label "Group"
'apropos-short-label "g"
+ 'face 'apropos-misc-button
'help-echo "mouse-2, RET: Display more help on this group"
'follow-link t
'action (lambda (button)
(define-button-type 'apropos-widget
'apropos-label "Widget"
'apropos-short-label "w"
+ 'face 'apropos-misc-button
'help-echo "mouse-2, RET: Display more help on this widget"
'follow-link t
'action (lambda (button)
(widget-browse-other-window (button-get button 'apropos-symbol))))
(define-button-type 'apropos-plist
- 'apropos-label "Plist"
+ 'apropos-label "Properties"
'apropos-short-label "p"
+ 'face 'apropos-misc-button
'help-echo "mouse-2, RET: Display more help on this plist"
'follow-link t
'action (lambda (button)
SUBJECT is a string that is included in the prompt to identify what
kind of objects to search."
(let ((pattern
- (read-string (concat "Apropos " subject " (word list or regexp): "))))
+ (read-string (concat "Search for " subject " (word list or regexp): "))))
(if (string-equal (regexp-quote pattern) pattern)
;; Split into words
- (split-string pattern "[ \t]+")
+ (split-string pattern "[ \t]+" t)
pattern)))
(defun apropos-parse-pattern (pattern)
"Return apropos score for documentation string DOC."
(let ((l (length doc)))
(if (> l 0)
- (let ((score 0) i)
- (when (setq i (string-match apropos-pattern-quoted doc))
+ (let ((score 0))
+ (when (string-match apropos-pattern-quoted doc)
(setq score 10000))
(dolist (s (apropos-calc-scores doc apropos-all-words) score)
(setq score (+ score 50 (/ (* (- l s) 50) l)))))
"Return t if DOC is really matched by the current keywords."
(apropos-true-hit doc apropos-all-words))
-(define-derived-mode apropos-mode fundamental-mode "Apropos"
+(define-derived-mode apropos-mode special-mode "Apropos"
"Major mode for following hyperlinks in output of apropos commands.
\\{apropos-mode-map}")
This is used to decide whether to print the result's type or not.")
;;;###autoload
-(defun apropos-variable (pattern &optional do-all)
- "Show user variables that match PATTERN.
+(defun apropos-user-option (pattern &optional do-all)
+ "Show user options that match PATTERN.
PATTERN can be a word, a list of words (separated by spaces),
or a regexp (using some regexp special characters). If it is a word,
search for matches for that word as a substring. If it is a list of words,
search for matches for any two (or more) of those words.
With \\[universal-argument] prefix, or if `apropos-do-all' is non-nil, also show
-normal variables."
+variables, not just user options."
(interactive (list (apropos-read-pattern
(if (or current-prefix-arg apropos-do-all)
"variable" "user option"))
#'(lambda (symbol)
(and (boundp symbol)
(get symbol 'variable-documentation)))
- 'user-variable-p)))
+ 'custom-variable-p)))
+
+;;;###autoload
+(defun apropos-variable (pattern &optional do-not-all)
+ "Show variables that match PATTERN.
+When DO-NOT-ALL is not-nil, show user options only, i.e. behave
+like `apropos-user-option'."
+ (interactive (list (apropos-read-pattern
+ (if current-prefix-arg "user option" "variable"))
+ current-prefix-arg))
+ (let ((apropos-do-all (if do-not-all nil t)))
+ (apropos-user-option pattern)))
;; For auld lang syne:
;;;###autoload
(let ((name (copy-sequence (symbol-name sym))))
(make-text-button name nil
'type 'apropos-library
- 'face apropos-symbol-face
+ 'face 'apropos-symbol
'apropos-symbol name)
name)))
(defun apropos-library (file)
"List the variables and functions defined by library FILE.
FILE should be one of the libraries currently loaded and should
-thus be found in `load-history'."
+thus be found in `load-history'. If `apropos-do-all' is non-nil,
+the output includes key-bindings of commands."
(interactive
(let* ((libs (delq nil (mapcar 'car load-history)))
(libs
(setq lh (cdr lh)))))
(unless lh-entry (error "Unknown library `%s'" file)))
(dolist (x (cdr lh-entry))
- (case (car-safe x)
+ (pcase (car-safe x)
;; (autoload (push (cdr x) autoloads))
- (require (push (cdr x) requires))
- (provide (push (cdr x) provides))
- (t (push (or (cdr-safe x) x) symbols))))
+ (`require (push (cdr x) requires))
+ (`provide (push (cdr x) provides))
+ (_ (push (or (cdr-safe x) x) symbols))))
(let ((apropos-pattern "")) ;Dummy binding for apropos-symbols-internal.
(apropos-symbols-internal
symbols apropos-do-all
"(not documented)"))
(when (boundp symbol)
(apropos-documentation-property
- symbol 'variable-documentation t))
- (when (setq properties (symbol-plist symbol))
- (setq doc (list (car properties)))
- (while (setq properties (cdr (cdr properties)))
- (setq doc (cons (car properties) doc)))
- (mapconcat #'symbol-name (nreverse doc) " "))
- (when (get symbol 'widget-type)
- (apropos-documentation-property
- symbol 'widget-documentation t))
+ symbol 'variable-documentation t))
+ (when (setq properties (symbol-plist symbol))
+ (setq doc (list (car properties)))
+ (while (setq properties (cdr (cdr properties)))
+ (setq doc (cons (car properties) doc)))
+ (mapconcat #'symbol-name (nreverse doc) " "))
+ (when (get symbol 'widget-type)
+ (apropos-documentation-property
+ symbol 'widget-documentation t))
(when (facep symbol)
(let ((alias (get symbol 'face-alias)))
(if alias
(apropos-documentation-property
symbol 'face-documentation t))))
(when (get symbol 'custom-group)
- (apropos-documentation-property
- symbol 'group-documentation t)))))
+ (apropos-documentation-property
+ symbol 'group-documentation t)))))
symbols)))
(apropos-print keys nil text)))
search for matches for any two (or more) of those words.
With \\[universal-argument] prefix, or if `apropos-do-all' is non-nil, also looks
-at the function and at the names and values of properties.
+at function definitions (arguments, documentation and body) and at the
+names and values of properties.
+
Returns list of symbols and values found."
(interactive (list (apropos-read-pattern "value")
current-prefix-arg))
search for matches for that word as a substring. If it is a list of words,
search for matches for any two (or more) of those words.
-With \\[universal-argument] prefix, or if `apropos-do-all' is non-nil, also use
-documentation that is not stored in the documentation file and show key
-bindings.
+Note that by default this command only searches in the file specified by
+`internal-doc-file-name'; i.e., the etc/DOC file. With \\[universal-argument] prefix,
+or if `apropos-do-all' is non-nil, it searches all currently defined
+documentation strings.
+
Returns list of symbols and documentation found."
+ ;; The doc used to say that DO-ALL includes key-bindings info in the
+ ;; output, but I cannot see that that is true.
(interactive (list (apropos-read-pattern "documentation")
current-prefix-arg))
(apropos-parse-pattern pattern)
(while pl
(setq p (format "%s %S" (car pl) (nth 1 pl)))
(if (or (not compare) (string-match apropos-regexp p))
- (if apropos-property-face
- (put-text-property 0 (length (symbol-name (car pl)))
- 'face apropos-property-face p))
+ (put-text-property 0 (length (symbol-name (car pl)))
+ 'face 'apropos-property p)
(setq p nil))
(if p
(progn
(setq function (if (byte-code-function-p function)
(if (> (length function) 4)
(aref function 4))
- (if (eq (car-safe function) 'autoload)
+ (if (autoloadp function)
(nth 2 function)
(if (eq (car-safe function) 'lambda)
(if (stringp (nth 2 function))
(with-output-to-temp-buffer "*Apropos*"
(let ((p apropos-accumulator)
(old-buffer (current-buffer))
+ (inhibit-read-only t)
symbol item)
(set-buffer standard-output)
(apropos-mode)
- (if (display-mouse-p)
- (insert
- "If moving the mouse over text changes the text's color, "
- "you can click\n"
- "or press return on that text to get more information.\n"))
- (insert "In this buffer, go to the name of the command, or function,"
- " or variable,\n"
- (substitute-command-keys
- "and type \\[apropos-follow] to get full documentation.\n\n"))
+ (insert (substitute-command-keys "Type \\[apropos-follow] on ")
+ (if apropos-multi-type "a type label" "an entry")
+ " to view its full documentation.\n\n")
(if text (insert text "\n\n"))
(dolist (apropos-item p)
(when (and spacing (not (bobp)))
(insert-text-button (symbol-name symbol)
'type 'apropos-symbol
'skip apropos-multi-type
- ;; Can't use default, since user may have
- ;; changed the variable!
- ;; Just say `no' to variables containing faces!
- 'face apropos-symbol-face)
+ 'face 'apropos-symbol)
(if (and (eq apropos-sort-by-scores 'verbose)
(cadr apropos-item))
(insert " (" (number-to-string (cadr apropos-item)) ") "))
;; omitting any that contain a buffer or a frame.
;; FIXME: Why omit keys that contain buffers and
;; frames? This looks like a bad workaround rather
- ;; than a proper fix. Does anybod know what problem
+ ;; than a proper fix. Does anybody know what problem
;; this is trying to address? --Stef
(dolist (key keys)
(let ((i 0)
(setq key (condition-case ()
(key-description key)
(error)))
- (if apropos-keybinding-face
- (put-text-property 0 (length key)
- 'face apropos-keybinding-face
- key))
+ (put-text-property 0 (length key)
+ 'face 'apropos-keybinding
+ key)
key)
item ", "))
(insert "M-x ... RET")
- (when apropos-keybinding-face
- (put-text-property (- (point) 11) (- (point) 8)
- 'face apropos-keybinding-face)
- (put-text-property (- (point) 3) (point)
- 'face apropos-keybinding-face))))
+ (put-text-property (- (point) 11) (- (point) 8)
+ 'face 'apropos-keybinding)
+ (put-text-property (- (point) 3) (point)
+ 'face 'apropos-keybinding)))
(terpri))
(apropos-print-doc 2
(if (commandp symbol)
'apropos-macro
'apropos-function))
(not nosubst))
- (apropos-print-doc 3 'apropos-variable (not nosubst))
+ (apropos-print-doc 3
+ (if (custom-variable-p symbol)
+ 'apropos-user-option
+ 'apropos-variable)
+ (not nosubst))
(apropos-print-doc 7 'apropos-group t)
(apropos-print-doc 6 'apropos-face t)
(apropos-print-doc 5 'apropos-widget t)
(apropos-print-doc 4 'apropos-plist nil))
(set (make-local-variable 'truncate-partial-width-windows) t)
- (set (make-local-variable 'truncate-lines) t)
- (setq buffer-read-only t))))
+ (set (make-local-variable 'truncate-lines) t))))
(prog1 apropos-accumulator
(setq apropos-accumulator ()))) ; permit gc
(consp (setq symbol
(symbol-function symbol)))
(or (eq (car symbol) 'macro)
- (if (eq (car symbol) 'autoload)
+ (if (autoloadp symbol)
(memq (nth 4 symbol)
'(macro t))))))
(defun apropos-print-doc (i type do-keys)
- (when (stringp (setq i (nth i apropos-item)))
- (if apropos-compact-layout
- (insert (propertize "\t" 'display '(space :align-to 32)) " ")
- (insert " "))
- (if (null apropos-multi-type)
- ;; If the query is only for a single type, there's no point
- ;; writing it over and over again. Insert a blank button, and
- ;; put the 'apropos-label property there (needed by
- ;; apropos-symbol-button-display-help).
- (insert-text-button
+ (let ((doc (nth i apropos-item)))
+ (when (stringp doc)
+ (if apropos-compact-layout
+ (insert (propertize "\t" 'display '(space :align-to 32)) " ")
+ (insert " "))
+ (if apropos-multi-type
+ (let ((button-face (button-type-get type 'face)))
+ (unless (consp button-face)
+ (setq button-face (list button-face)))
+ (insert-text-button
+ (if apropos-compact-layout
+ (format "<%s>" (button-type-get type 'apropos-short-label))
+ (button-type-get type 'apropos-label))
+ 'type type
+ 'apropos-symbol (car apropos-item))
+ (insert (if apropos-compact-layout " " ": ")))
+
+ ;; If the query is only for a single type, there's no point
+ ;; writing it over and over again. Insert a blank button, and
+ ;; put the 'apropos-label property there (needed by
+ ;; apropos-symbol-button-display-help).
+ (insert-text-button
" " 'type type 'skip t
- 'face 'default 'apropos-symbol (car apropos-item))
- (insert-text-button
- (if apropos-compact-layout
- (format "<%s>" (button-type-get type 'apropos-short-label))
- (button-type-get type 'apropos-label))
- 'type type
- ;; Can't use the default button face, since user may have changed the
- ;; variable! Just say `no' to variables containing faces!
- 'face apropos-label-face
- 'apropos-symbol (car apropos-item))
- (insert (if apropos-compact-layout " " ": ")))
- (insert (if do-keys (substitute-command-keys i) i))
- (or (bolp) (terpri))))
+ 'face 'default 'apropos-symbol (car apropos-item)))
+
+ (let ((opoint (point))
+ (ocol (current-column)))
+ (cond ((equal doc "")
+ (setq doc "(not documented)"))
+ (do-keys
+ (setq doc (substitute-command-keys doc))))
+ (insert doc)
+ (if (equal doc "(not documented)")
+ (put-text-property opoint (point) 'font-lock-face 'shadow))
+ ;; The labeling buttons might make the line too long, so fill it if
+ ;; necessary.
+ (let ((fill-column (+ 5 (if (integerp emacs-lisp-docstring-fill-column)
+ emacs-lisp-docstring-fill-column
+ fill-column)))
+ (fill-prefix (make-string ocol ?\s)))
+ (fill-region opoint (point) nil t)))
+ (or (bolp) (terpri)))))
(defun apropos-follow ()
"Invokes any button at point, otherwise invokes the nearest label button."
(princ "Symbol ")
(prin1 symbol)
(princ "'s plist is\n (")
- (if apropos-symbol-face
- (put-text-property (+ (point-min) 7) (- (point) 14)
- 'face apropos-symbol-face))
+ (put-text-property (+ (point-min) 7) (- (point) 14)
+ 'face 'apropos-symbol)
(insert (apropos-format-plist symbol "\n "))
(princ ")")))
(provide 'apropos)
-;; arch-tag: d56fa2ac-e56b-4ce3-84ff-852f9c0dc66e
;;; apropos.el ends here