X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/5ed99d3685cc8d13f8e4c63ad449a6e4d63c8eb0..37b9743e79bac608a45fade0744248446aaa0a33:/lisp/apropos.el diff --git a/lisp/apropos.el b/lisp/apropos.el index d3d66f2a07..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") -(defcustom apropos-symbol-face 'bold - "Face for symbol name in Apropos output, or nil for none." +(defface apropos-keybinding + '((t (:inherit underline))) + "Face for lists of keybinding in Apropos output." :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-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-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." +(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-property-face 'bold-italic - "Face for property name in apropos output, or nil for none." +(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") + +(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. @@ -183,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) @@ -197,7 +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 '(font-lock-function-name-face button) + 'face 'apropos-function-button 'help-echo "mouse-2, RET: Display more help on this function" 'follow-link t 'action (lambda (button) @@ -206,7 +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 '(font-lock-function-name-face button) + 'face 'apropos-function-button 'help-echo "mouse-2, RET: Display more help on this macro" 'follow-link t 'action (lambda (button) @@ -215,7 +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 '(font-lock-function-name-face button) + 'face 'apropos-function-button 'help-echo "mouse-2, RET: Display more help on this command" 'follow-link t 'action (lambda (button) @@ -229,7 +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 '(font-lock-variable-name-face button) + 'face 'apropos-variable-button 'help-echo "mouse-2, RET: Display more help on this variable" 'follow-link t 'action (lambda (button) @@ -247,7 +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 '(font-lock-builtin-face button) + 'face 'apropos-misc-button 'help-echo "mouse-2, RET: Display more help on this group" 'follow-link t 'action (lambda (button) @@ -257,7 +282,7 @@ term, and the rest of the words are alternative terms.") (define-button-type 'apropos-widget 'apropos-label "Widget" 'apropos-short-label "w" - 'face '(font-lock-builtin-face button) + 'face 'apropos-misc-button 'help-echo "mouse-2, RET: Display more help on this widget" 'follow-link t 'action (lambda (button) @@ -266,7 +291,7 @@ term, and the rest of the words are alternative terms.") (define-button-type 'apropos-plist 'apropos-label "Properties" 'apropos-short-label "p" - 'face '(font-lock-keyword-face button) + 'face 'apropos-misc-button 'help-echo "mouse-2, RET: Display more help on this plist" 'follow-link t 'action (lambda (button) @@ -320,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) @@ -453,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 @@ -574,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))) @@ -582,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 @@ -613,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 @@ -693,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)) @@ -738,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) @@ -817,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 @@ -949,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)) @@ -1011,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)) ") ")) @@ -1032,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) @@ -1052,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) @@ -1088,7 +1114,7 @@ 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)))))) @@ -1108,9 +1134,6 @@ If non-nil TEXT is a string that will be printed as a heading." (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 " " ": "))) @@ -1157,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 ")")))