;;; apropos.el --- apropos commands for users and programmers
-;; Copyright (C) 1989, 1994, 1995, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;; Copyright (C) 1989, 1994-1995, 2001-2011 Free Software Foundation, Inc.
;; Author: Joe Wells <jbw@bigbird.bu.edu>
-;; Rewritten: Daniel Pfeiffer <occitan@esperanto.org>
+;; Daniel Pfeiffer <occitan@esperanto.org> (rewrite)
;; Keywords: help
+;; Package: emacs
;; This file is part of GNU Emacs.
:group 'apropos
:type 'face)
-(defcustom apropos-label-face '(italic variable-pitch)
+(defcustom apropos-label-face '(italic)
"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."
(const :tag "show scores" verbose)))
(defcustom apropos-documentation-sort-by-scores t
- "*Non-nil means sort matches by scores; best match is shown first.
+ "Non-nil means sort matches by scores; best match is shown first.
This applies to `apropos-documentation' only.
If value is `verbose', the computed score is shown for each match."
:group 'apropos
(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'.")
'face apropos-symbol-face
'help-echo "mouse-2, RET: Display more help on this symbol"
'follow-link t
- 'action #'apropos-symbol-button-display-help
- 'skip t)
+ 'action #'apropos-symbol-button-display-help)
(defun apropos-symbol-button-display-help (button)
"Display further help for the `apropos-symbol' button BUTTON."
(define-button-type 'apropos-function
'apropos-label "Function"
'apropos-short-label "f"
+ 'face '(font-lock-function-name-face 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 '(font-lock-function-name-face 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 '(font-lock-function-name-face 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 '(font-lock-variable-name-face button)
'help-echo "mouse-2, RET: Display more help on this variable"
'follow-link t
'action (lambda (button)
(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 '(font-lock-builtin-face 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 '(font-lock-builtin-face 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 '(font-lock-keyword-face button)
'help-echo "mouse-2, RET: Display more help on this plist"
'follow-link t
'action (lambda (button)
"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}")
(apropos-parse-pattern pattern)
(let ((message
(let ((standard-output (get-buffer-create "*Apropos*")))
- (print-help-return-message 'identity))))
+ (help-print-return-message 'identity))))
(or do-all (setq do-all apropos-do-all))
(setq apropos-accumulator
(apropos-internal apropos-regexp
(setq score (apropos-score-symbol symbol))
(unless var-predicate
(if (fboundp symbol)
- (if (setq doc (documentation symbol t))
- (progn
+ (if (setq doc (condition-case nil
+ (documentation symbol t)
+ (error 'error)))
+ ;; Eg alias to undefined function.
+ (if (eq doc 'error)
+ "(documentation error)"
(setq score (+ score (apropos-score-doc doc)))
(substring doc 0 (string-match "\n" doc)))
"(not documented)")))
FILE should be one of the libraries currently loaded and should
thus be found in `load-history'."
(interactive
- (let ((libs
- (nconc (delq nil
- (mapcar
- (lambda (l)
- (setq l (file-name-nondirectory l))
- (while
- (not (equal (setq l (file-name-sans-extension l))
- l)))
- l)
- (mapcar 'car load-history)))
- (mapcar 'car load-history))))
+ (let* ((libs (delq nil (mapcar 'car load-history)))
+ (libs
+ (nconc (delq nil
+ (mapcar
+ (lambda (l)
+ (setq l (file-name-nondirectory l))
+ (while
+ (not (equal (setq l (file-name-sans-extension l))
+ l)))
+ l)
+ libs))
+ libs)))
(list (completing-read "Describe library: " libs nil t))))
(let ((symbols nil)
;; (autoloads nil)
(re (concat "\\(?:\\`\\|[\\/]\\)" (regexp-quote file)
"\\(\\.\\|\\'\\)")))
(while (and lh (null lh-entry))
- (if (string-match re (caar lh))
+ (if (and (caar lh) (string-match re (caar lh)))
(setq lh-entry (car lh))
(setq lh (cdr lh)))))
(unless lh-entry (error "Unknown library `%s'" file)))
"(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))
- (when (facep symbol)
+ 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 'face-documentation t))
+ symbol 'widget-documentation t))
+ (when (facep symbol)
+ (let ((alias (get symbol 'face-alias)))
+ (if alias
+ (if (facep alias)
+ (format "%slias for the face `%s'."
+ (if (get symbol 'obsolete-face)
+ "Obsolete a"
+ "A")
+ alias)
+ ;; Never happens in practice because fails
+ ;; (facep symbol) test.
+ "(alias for undefined face)")
+ (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)))
(apropos-sort-by-scores apropos-documentation-sort-by-scores)
f v sf sv)
(unwind-protect
- (save-excursion
- (set-buffer standard-input)
+ (with-current-buffer standard-input
(apropos-documentation-check-doc-file)
(if do-all
(mapatoms
;; Finds all documentation related to APROPOS-REGEXP in internal-doc-file-name.
(defun apropos-documentation-check-doc-file ()
- (let (type symbol (sepa 2) sepb)
+ (let (type symbol (sepa 2) sepb doc)
(insert ?\^_)
(backward-char)
(insert-file-contents (concat doc-directory internal-doc-file-name))
3) ; variable documentation
symbol (read)
doc (buffer-substring (1+ (point)) (1- sepb)))
- (when (apropos-true-hit-doc doc)
+ (when (and (apropos-true-hit-doc doc)
+ ;; The DOC file lists all built-in funcs and vars.
+ ;; If any are not currently bound, they can
+ ;; only be platform-specific stuff (eg NS) not
+ ;; in use on the current platform.
+ ;; So we exclude them.
+ (cond ((= 3 type) (boundp symbol))
+ ((= 2 type) (fboundp symbol))))
(or (and (setq apropos-item (assq symbol apropos-accumulator))
(setcar (cdr apropos-item)
(apropos-score-doc doc)))
(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"
- "mouse-2 (second button from right) 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)))
(cons nil (cdr apropos-item)))))
(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!
(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
(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 the query is only for a single type, there's
- ;; no point writing it over and over again.
- (when apropos-multi-type
- (insert-text-button
- (if apropos-compact-layout
- (button-type-get type 'apropos-label)
- (format "<%s>" (button-type-get type 'apropos-short-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))))
+ (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
+ ;; Can't use the default button face, since user may have changed the
+ ;; variable! Just say `no' to variables containing faces!
+ 'face (append button-face apropos-label-face)
+ '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)))
+
+ (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."
(defun apropos-describe-plist (symbol)
"Display a pretty listing of SYMBOL's plist."
- (help-setup-xref (list 'apropos-describe-plist symbol) (interactive-p))
+ (help-setup-xref (list 'apropos-describe-plist symbol)
+ (called-interactively-p 'interactive))
(with-help-window (help-buffer)
(set-buffer standard-output)
(princ "Symbol ")
(provide 'apropos)
-;; arch-tag: d56fa2ac-e56b-4ce3-84ff-852f9c0dc66e
;;; apropos.el ends here