;;; apropos.el --- apropos commands for users and programmers
-;; Copyright (C) 1989, 1994, 1995, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007 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.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 3, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; I see a degradation of maybe 10-20% only.
(defcustom apropos-do-all nil
- "*Whether the apropos commands should do more.
+ "Whether the apropos commands should do more.
Slows them down more or less. Set this non-nil if you have a fast machine."
:group 'apropos
(defcustom apropos-symbol-face 'bold
- "*Face for symbol name in Apropos output, or nil for none."
+ "Face for symbol name in Apropos output, or nil for none."
:group 'apropos
:type 'face)
(defcustom apropos-keybinding-face 'underline
- "*Face for lists of keybinding in Apropos output, or nil for none."
+ "Face for lists of keybinding in Apropos output, or nil for none."
:group 'apropos
:type 'face)
-(defcustom apropos-label-face 'italic
- "*Face for label (`Command', `Variable' ...) in Apropos output.
+(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."
:group 'apropos
:type 'face)
(defcustom apropos-property-face 'bold-italic
- "*Face for property name in apropos output, or nil for none."
+ "Face for property name in apropos output, or nil for none."
:group 'apropos
:type 'face)
(defcustom apropos-match-face 'match
- "*Face for matching text in Apropos documentation/value, or nil for none.
+ "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)
(defcustom apropos-sort-by-scores nil
- "*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 all `apropos' commands except `apropos-documentation'.
If value is `verbose', the computed score is shown for each match."
:group 'apropos
(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
"Keymap used in Apropos mode.")
(defvar apropos-mode-hook nil
- "*Hook run when mode is turned on.")
+ "Hook run when mode is turned on.")
(defvar apropos-pattern nil
"Apropos pattern as entered by user.")
'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"
'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"
'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"
'help-echo "mouse-2, RET: Display more help on this command"
'follow-link t
'action (lambda (button)
;; Likewise for `customize-face-other-window'.
(define-button-type 'apropos-variable
'apropos-label "Variable"
+ 'apropos-short-label "v"
'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"
'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"
'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"
'help-echo "mouse-2, RET: Display more help on this widget"
'follow-link t
'action (lambda (button)
(define-button-type 'apropos-plist
'apropos-label "Plist"
+ 'apropos-short-label "p"
'help-echo "mouse-2, RET: Display more help on this plist"
'follow-link t
'action (lambda (button)
(apropos-describe-plist (button-get button 'apropos-symbol))))
+(define-button-type 'apropos-library
+ 'help-echo "mouse-2, RET: Display more help on this library"
+ 'follow-link t
+ 'action (lambda (button)
+ (apropos-library (button-get button 'apropos-symbol))))
+
(defun apropos-next-label-button (pos)
"Return the next apropos label button after POS, or nil if there's none.
Will also return nil if more than one `apropos-symbol' button is encountered
\\{apropos-mode-map}")
+(defvar apropos-multi-type t
+ "If non-nil, this apropos query concerns multiple types.
+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.
(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
(or var-predicate
- (if do-all 'functionp 'commandp))))
+ ;; We used to use `functionp' here, but this
+ ;; rules out macros. `fboundp' rules in
+ ;; keymaps, but it seems harmless.
+ (if do-all 'fboundp 'commandp))))
(let ((tem apropos-accumulator))
(while tem
(if (or (get (car tem) 'apropos-inhibit)
(setq symbol (car p))
(setq score (apropos-score-symbol symbol))
(unless var-predicate
- (if (functionp symbol)
- (if (setq doc (documentation symbol t))
- (progn
+ (if (fboundp symbol)
+ (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)")))
(string-match "\n" doc)))))))
(setcar (cdr (car p)) score)
(setq p (cdr p))))
- (and (apropos-print t nil nil t)
+ (and (let ((apropos-multi-type do-all))
+ (apropos-print t nil nil t))
message
(message "%s" message))))
(symbol-plist symbol)))))
(or do-all apropos-do-all)))
+(defun apropos-library-button (sym)
+ (if (null sym)
+ "<nothing>"
+ (let ((name (copy-sequence (symbol-name sym))))
+ (make-text-button name nil
+ 'type 'apropos-library
+ 'face apropos-symbol-face
+ 'apropos-symbol name)
+ name)))
+
+;;;###autoload
+(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'."
+ (interactive
+ (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)
+ (provides nil)
+ (requires nil)
+ (lh-entry (assoc file load-history)))
+ (unless lh-entry
+ ;; `file' may be the "shortname".
+ (let ((lh load-history)
+ (re (concat "\\(?:\\`\\|[\\/]\\)" (regexp-quote file)
+ "\\(\\.\\|\\'\\)")))
+ (while (and lh (null lh-entry))
+ (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)))
+ (dolist (x (cdr lh-entry))
+ (case (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))))
+ (let ((apropos-pattern "")) ;Dummy binding for apropos-symbols-internal.
+ (apropos-symbols-internal
+ symbols apropos-do-all
+ (concat
+ (format "Library `%s' provides: %s\nand requires: %s"
+ file
+ (mapconcat 'apropos-library-button
+ (or provides '(nil)) " and ")
+ (mapconcat 'apropos-library-button
+ (or requires '(nil)) " and ")))))))
+
(defun apropos-symbols-internal (symbols keys &optional text)
;; Filter out entries that are marked as apropos-inhibit.
(let ((all nil))
(apropos-documentation-property
symbol 'widget-documentation t))
(when (facep symbol)
- (apropos-documentation-property
- symbol 'face-documentation t))
+ (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-score-str p))
f v p)
apropos-accumulator))))))
- (apropos-print nil "\n----------------\n"))
+ (let ((apropos-multi-type do-all))
+ (apropos-print nil "\n----------------\n")))
;;;###autoload
(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)))
nil
function))
+(defcustom apropos-compact-layout nil
+ "If non-nil, use a single line per binding."
+ :type 'boolean)
(defun apropos-print (do-keys spacing &optional text nosubst)
"Output result of apropos searching into buffer `*Apropos*'.
(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"))
+ "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"))
(if text (insert text "\n\n"))
- (while (consp p)
+ (dolist (apropos-item p)
(when (and spacing (not (bobp)))
(princ spacing))
- (setq apropos-item (car p)
- symbol (car apropos-item)
- p (cdr p))
+ (setq symbol (car apropos-item))
;; Insert dummy score element for backwards compatibility with 21.x
;; apropos-item format.
(if (not (numberp (cadr apropos-item)))
(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!
(cadr apropos-item))
(insert " (" (number-to-string (cadr apropos-item)) ") "))
;; Calculate key-bindings if we want them.
- (and do-keys
- (commandp symbol)
- (not (eq symbol 'self-insert-command))
- (indent-to 30 1)
- (if (let ((keys
- (save-excursion
- (set-buffer old-buffer)
- (where-is-internal symbol)))
- filtered)
- ;; Copy over the list of key sequences,
- ;; omitting any that contain a buffer or a frame.
- (while keys
- (let ((key (car keys))
- (i 0)
- loser)
- (while (< i (length key))
- (if (or (framep (aref key i))
- (bufferp (aref key i)))
- (setq loser t))
- (setq i (1+ i)))
- (or loser
- (setq filtered (cons key filtered))))
- (setq keys (cdr keys)))
- (setq item filtered))
- ;; Convert the remaining keys to a string and insert.
- (insert
- (mapconcat
- (lambda (key)
- (setq key (condition-case ()
- (key-description key)
- (error)))
- (if apropos-keybinding-face
- (put-text-property 0 (length key)
- 'face apropos-keybinding-face
- 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))))
- (terpri)
+ (unless apropos-compact-layout
+ (and do-keys
+ (commandp symbol)
+ (not (eq symbol 'self-insert-command))
+ (indent-to 30 1)
+ (if (let ((keys
+ (with-current-buffer old-buffer
+ (where-is-internal symbol)))
+ filtered)
+ ;; Copy over the list of key sequences,
+ ;; 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
+ ;; this is trying to address? --Stef
+ (dolist (key keys)
+ (let ((i 0)
+ loser)
+ (while (< i (length key))
+ (if (or (framep (aref key i))
+ (bufferp (aref key i)))
+ (setq loser t))
+ (setq i (1+ i)))
+ (or loser
+ (push key filtered))))
+ (setq item filtered))
+ ;; Convert the remaining keys to a string and insert.
+ (insert
+ (mapconcat
+ (lambda (key)
+ (setq key (condition-case ()
+ (key-description key)
+ (error)))
+ (if apropos-keybinding-face
+ (put-text-property 0 (length key)
+ 'face apropos-keybinding-face
+ 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))))
+ (terpri))
(apropos-print-doc 2
(if (commandp symbol)
'apropos-command
(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))))
(prog1 apropos-accumulator
(setq apropos-accumulator ()))) ; permit gc
-
(defun apropos-macrop (symbol)
"Return t if SYMBOL is a Lisp macro."
(and (fboundp symbol)
(defun apropos-print-doc (i type do-keys)
- (if (stringp (setq i (nth i apropos-item)))
- (progn
- (insert " ")
- (insert-text-button (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 ": ")
- (insert (if do-keys (substitute-command-keys i) i))
- (or (bolp) (terpri)))))
-
+ (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
+ " " '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))))
(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
HCoop / bpt / emacs.git / blobdiff