X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/233ba4d924933cb56129bd7511e6137b7c0b8e3e..ac5392dcfda42b26767ae966a8b290142c00bff7:/lisp/apropos.el diff --git a/lisp/apropos.el b/lisp/apropos.el index 70ce860e1d..88d5602a02 100644 --- a/lisp/apropos.el +++ b/lisp/apropos.el @@ -1,6 +1,6 @@ ;;; apropos.el --- apropos commands for users and programmers -;; Copyright (C) 1989, 1994-1995, 2001-2011 Free Software Foundation, Inc. +;; Copyright (C) 1989, 1994-1995, 2001-2012 Free Software Foundation, Inc. ;; Author: Joe Wells ;; Daniel Pfeiffer (rewrite) @@ -36,12 +36,12 @@ ;; 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. @@ -57,7 +57,6 @@ ;;; Code: (require 'button) -(eval-when-compile (require 'cl)) (defgroup apropos nil "Apropos commands for users and programmers." @@ -66,41 +65,67 @@ ;; 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-variable' will search all variables, not just user variables. +`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-misc-button + '((t (:inherit (font-lock-constant-face button)))) + "Button face indicating a miscellaneous object type in Apropos." :group 'apropos - :type 'face) + :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. @@ -155,7 +180,17 @@ If value is `verbose', the computed score is shown for each match." "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'.") @@ -173,7 +208,7 @@ term, and the rest of the words are alternative terms.") ;;; 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) @@ -187,6 +222,7 @@ term, and the rest of the words are alternative terms.") (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) @@ -195,6 +231,7 @@ term, and the rest of the words are alternative terms.") (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) @@ -203,6 +240,7 @@ term, and the rest of the words are alternative terms.") (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) @@ -216,6 +254,7 @@ term, and the rest of the words are alternative terms.") (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) @@ -224,6 +263,7 @@ term, and the rest of the words are alternative terms.") (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) @@ -232,6 +272,7 @@ term, and the rest of the words are alternative terms.") (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) @@ -241,14 +282,16 @@ term, and the rest of the words are alternative terms.") (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) @@ -302,10 +345,10 @@ literally, or a string which is used as a regexp to search for. 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) @@ -371,8 +414,8 @@ Value is a list of offsets of the words into the string." "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))))) @@ -435,7 +478,7 @@ normal variables." #'(lambda (symbol) (and (boundp symbol) (get symbol 'variable-documentation))) - 'user-variable-p))) + 'custom-variable-p))) ;; For auld lang syne: ;;;###autoload @@ -556,7 +599,7 @@ Returns list of symbols and documentation found." (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))) @@ -564,7 +607,8 @@ Returns list of symbols and documentation found." (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 @@ -595,11 +639,11 @@ thus be found in `load-history'." (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 @@ -636,15 +680,15 @@ thus be found in `load-history'." "(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 @@ -660,8 +704,8 @@ thus be found in `load-history'." (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))) @@ -675,7 +719,9 @@ 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 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)) @@ -720,10 +766,14 @@ 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 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) @@ -799,9 +849,8 @@ Returns list of symbols and documentation found." (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 @@ -931,7 +980,7 @@ Will return nil instead." (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)) @@ -972,17 +1021,13 @@ If non-nil TEXT is a string that will be printed as a heading." (with-output-to-temp-buffer "*Apropos*" (let ((p apropos-accumulator) (old-buffer (current-buffer)) + (inhibit-read-only t) symbol item) (set-buffer standard-output) - (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")) + (apropos-mode) + (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))) @@ -997,10 +1042,7 @@ If non-nil TEXT is a string that will be printed as a heading." (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)) ") ")) @@ -1018,7 +1060,7 @@ If non-nil TEXT is a string that will be printed as a heading." ;; 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) @@ -1038,18 +1080,16 @@ If non-nil TEXT is a string that will be printed as a heading." (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) @@ -1064,8 +1104,7 @@ If non-nil TEXT is a string that will be printed as a heading." (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) - (apropos-mode)))) + (set (make-local-variable 'truncate-lines) t)))) (prog1 apropos-accumulator (setq apropos-accumulator ()))) ; permit gc @@ -1075,36 +1114,54 @@ If non-nil TEXT is a string that will be printed as a heading." (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." @@ -1123,9 +1180,8 @@ If non-nil TEXT is a string that will be printed as a heading." (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 ")")))