X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/c07a4c0b599e0debfb10acdf02ac6559b998a88a..4ab03a1a7520fbe750355d760bca8831e3e3af08:/lisp/apropos.el diff --git a/lisp/apropos.el b/lisp/apropos.el index 56b27e9b9b..2cba65e955 100644 --- a/lisp/apropos.el +++ b/lisp/apropos.el @@ -1,6 +1,7 @@ ;;; apropos.el --- apropos commands for users and programmers -;; Copyright (C) 1989, 1994-1995, 2001-2012 Free Software Foundation, Inc. +;; Copyright (C) 1989, 1994-1995, 2001-2014 Free Software Foundation, +;; Inc. ;; Author: Joe Wells ;; Daniel Pfeiffer (rewrite) @@ -36,12 +37,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 +58,6 @@ ;;; Code: (require 'button) -(eval-when-compile (require 'cl)) (defgroup apropos nil "Apropos commands for users and programmers." @@ -69,7 +69,7 @@ "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-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. @@ -85,35 +85,55 @@ 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") + +(defface apropos-property + '((t (:inherit font-lock-builtin-face))) + "Face for property name in Apropos output, or nil for none." + :group 'apropos + :version "24.3") -(defcustom apropos-symbol-face 'bold - "Face for symbol name 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-keybinding-face 'underline - "Face for lists of keybinding 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") -(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-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") -(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." + :type '(choice (const nil) face) :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. @@ -162,7 +182,7 @@ If value is `verbose', the computed score is shown for each match." "Regexp used in current apropos run.") (defvar apropos-all-words-regexp nil - "Regexp matching apropos-all-words.") + "Regexp matching `apropos-all-words'.") (defvar apropos-files-scanned () "List of elc files already scanned in current run of `apropos-documentation'.") @@ -196,7 +216,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) @@ -210,7 +230,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) @@ -219,7 +239,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) @@ -228,7 +248,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) @@ -242,12 +262,21 @@ 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) (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" @@ -260,7 +289,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) @@ -270,7 +299,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) @@ -279,7 +308,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) @@ -313,16 +342,21 @@ before finding a label." (defun apropos-words-to-regexp (words wild) - "Make regexp matching any two of the words in WORDS." - (concat "\\(" - (mapconcat 'identity words "\\|") - "\\)" - (if (cdr words) - (concat wild - "\\(" - (mapconcat 'identity words "\\|") - "\\)") - ""))) + "Make regexp matching any two of the words in WORDS. +WILD should be a subexpression matching wildcards between matches." + (setq words (delete-dups (copy-sequence words))) + (if (null (cdr words)) + (car words) + (mapconcat + (lambda (w) + (concat "\\(?:" w "\\)" ;; parens for synonyms + wild "\\(?:" + (mapconcat 'identity + (delq w (copy-sequence words)) + "\\|") + "\\)")) + words + "\\|"))) ;;;###autoload (defun apropos-read-pattern (subject) @@ -333,10 +367,11 @@ 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]+") + (or (split-string pattern "[ \t]+" t) + (user-error "No word list given")) pattern))) (defun apropos-parse-pattern (pattern) @@ -376,7 +411,6 @@ This updates variables `apropos-pattern', `apropos-pattern-quoted', apropos-pattern pattern apropos-regexp pattern))) - (defun apropos-calc-scores (str words) "Return apropos scores for string STR matching WORDS. Value is a list of offsets of the words into the string." @@ -420,7 +454,7 @@ Value is a list of offsets of the words into the string." (defun apropos-true-hit (str words) "Return t if STR is a genuine hit. This may fail if only one of the keywords is matched more than once. -This requires that at least 2 keywords (unless only one was given)." +This requires at least two keywords (unless only one was given)." (or (not str) (not words) (not (cdr words)) @@ -448,15 +482,15 @@ This requires that at least 2 keywords (unless only one was given)." 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")) @@ -468,6 +502,17 @@ normal variables." (get symbol 'variable-documentation))) 'custom-variable-p))) +;;;###autoload +(defun apropos-variable (pattern &optional do-not-all) + "Show variables that match PATTERN. +When DO-NOT-ALL is non-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 (defalias 'command-apropos 'apropos-command) @@ -587,7 +632,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))) @@ -627,11 +672,11 @@ the output includes key-bindings of commands." (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 @@ -837,9 +882,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 @@ -962,14 +1006,13 @@ Returns list of symbols and documentation found." "Like `documentation', except it avoids calling `get_doc_string'. Will return nil instead." (while (and function (symbolp function)) - (setq function (if (fboundp function) - (symbol-function function)))) + (setq function (symbol-function function))) (if (eq (car-safe function) 'macro) (setq function (cdr function))) (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)) @@ -994,14 +1037,12 @@ alphabetically by symbol name; but this function also sets `apropos-accumulator' to nil before returning. If SPACING is non-nil, it should be a string; separate items with that string. -If non-nil TEXT is a string that will be printed as a heading." +If non-nil, TEXT is a string that will be printed as a heading." (if (null apropos-accumulator) (message "No apropos matches for `%s'" apropos-pattern) (setq apropos-accumulator (sort apropos-accumulator (lambda (a b) - ;; Don't sort by score if user can't see the score. - ;; It would be confusing. -- rms. (if apropos-sort-by-scores (or (> (cadr a) (cadr b)) (and (= (cadr a) (cadr b)) @@ -1011,6 +1052,7 @@ If non-nil TEXT is a string that will be printed as a heading." (let ((p apropos-accumulator) (old-buffer (current-buffer)) (inhibit-read-only t) + (button-end 0) symbol item) (set-buffer standard-output) (apropos-mode) @@ -1028,13 +1070,12 @@ If non-nil TEXT is a string that will be printed as a heading." (setq apropos-item (cons (car apropos-item) (cons nil (cdr apropos-item))))) + (when (= (point) button-end) (terpri)) (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) + (setq button-end (point)) (if (and (eq apropos-sort-by-scores 'verbose) (cadr apropos-item)) (insert " (" (number-to-string (cadr apropos-item)) ") ")) @@ -1072,27 +1113,29 @@ 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) 'apropos-command - (if (apropos-macrop symbol) + (if (macrop 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) @@ -1102,17 +1145,6 @@ If non-nil TEXT is a string that will be printed as a heading." (prog1 apropos-accumulator (setq apropos-accumulator ()))) ; permit gc -(defun apropos-macrop (symbol) - "Return t if SYMBOL is a Lisp macro." - (and (fboundp symbol) - (consp (setq symbol - (symbol-function symbol))) - (or (eq (car symbol) 'macro) - (if (eq (car symbol) 'autoload) - (memq (nth 4 symbol) - '(macro t)))))) - - (defun apropos-print-doc (i type do-keys) (let ((doc (nth i apropos-item))) (when (stringp doc) @@ -1128,9 +1160,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 " " ": "))) @@ -1177,9 +1206,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 ")")))