X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/e517f56d879e28ff75784bff91e52c5a4b799a2b..41f7a85e0d33a63df8c1a4cac61fc3ee8b123d7c:/lisp/apropos.el diff --git a/lisp/apropos.el b/lisp/apropos.el index 9b44c56564..3889655ff9 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 Free Software Foundation, Inc. +;; Copyright (C) 1989, 1994, 1995, 2001, 2002, 2003, 2004, +;; 2005, 2006 Free Software Foundation, Inc. ;; Author: Joe Wells ;; Rewritten: Daniel Pfeiffer @@ -20,8 +21,8 @@ ;; 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., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: @@ -57,8 +58,11 @@ ;;; Code: +(require 'button) +(eval-when-compile (require 'cl)) + (defgroup apropos nil - "Apropos commands for users and programmers" + "Apropos commands for users and programmers." :group 'help :prefix "apropos") @@ -93,13 +97,30 @@ turns off mouse highlighting." :group 'apropos :type 'face) -(defcustom apropos-match-face 'secondary-selection +(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 regexp; the part that matches gets displayed in this font." +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. +This applies to all `apropos' commands except `apropos-documentation'. +If value is `verbose', the computed score is shown for each match." + :group 'apropos + :type '(choice (const :tag "off" nil) + (const :tag "on" t) + (const :tag "show scores" verbose))) + +(defcustom apropos-documentation-sort-by-scores t + "*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 + :type '(choice (const :tag "off" nil) + (const :tag "on" t) + (const :tag "show scores" verbose))) (defvar apropos-mode-map (let ((map (make-sparse-keymap))) @@ -117,9 +138,24 @@ for the regexp; the part that matches gets displayed in this font." (defvar apropos-mode-hook nil "*Hook run when mode is turned on.") +(defvar apropos-pattern nil + "Apropos pattern as entered by user.") + +(defvar apropos-pattern-quoted nil + "Apropos pattern passed through `regexp-quoute'.") + +(defvar apropos-words () + "Current list of apropos words extracted from `apropos-pattern'.") + +(defvar apropos-all-words () + "Current list of words and synonyms.") + (defvar apropos-regexp nil "Regexp used in current apropos run.") +(defvar apropos-all-words-regexp nil + "Regexp matching apropos-all-words.") + (defvar apropos-files-scanned () "List of elc files already scanned in current run of `apropos-documentation'.") @@ -129,17 +165,24 @@ for the regexp; the part that matches gets displayed in this font." (defvar apropos-item () "Current item in or for `apropos-accumulator'.") +(defvar apropos-synonyms '( + ("find" "open" "edit") + ("kill" "cut") + ("yank" "paste") + ("region" "selection")) + "List of synonyms known by apropos. +Each element is a list of words where the first word is the standard emacs +term, and the rest of the words are alternative terms.") + ;;; Button types used by apropos (define-button-type 'apropos-symbol 'face apropos-symbol-face - 'help-echo "mouse-2, RET: Display more help on this symbol." - 'action #'apropos-symbol-button-display-help) - -(define-button-type 'apropos-label - 'help-echo "mouse-2, RET: Display more help on this symbol." - 'action #'apropos-label-button-display-help) + 'help-echo "mouse-2, RET: Display more help on this symbol" + 'follow-link t + 'action #'apropos-symbol-button-display-help + 'skip t) (defun apropos-symbol-button-display-help (button) "Display further help for the `apropos-symbol' button BUTTON." @@ -147,50 +190,235 @@ for the regexp; the part that matches gets displayed in this font." (or (apropos-next-label-button (button-start button)) (error "There is nothing to follow for `%s'" (button-label button))))) -(defun apropos-label-button-display-help (button) - "Display further help for the `apropos-label' button BUTTON." - (funcall (button-get button 'apropos-action) - (button-get button 'apropos-symbol))) +(define-button-type 'apropos-function + 'apropos-label "Function" + 'help-echo "mouse-2, RET: Display more help on this function" + 'follow-link t + 'action (lambda (button) + (describe-function (button-get button 'apropos-symbol)))) + +(define-button-type 'apropos-macro + 'apropos-label "Macro" + 'help-echo "mouse-2, RET: Display more help on this macro" + 'follow-link t + 'action (lambda (button) + (describe-function (button-get button 'apropos-symbol)))) + +(define-button-type 'apropos-command + 'apropos-label "Command" + 'help-echo "mouse-2, RET: Display more help on this command" + 'follow-link t + 'action (lambda (button) + (describe-function (button-get button 'apropos-symbol)))) + +;; We used to use `customize-variable-other-window' instead for a +;; customizable variable, but that is slow. It is better to show an +;; ordinary help buffer and let the user click on the customization +;; button in that buffer, if he wants to. +;; Likewise for `customize-face-other-window'. +(define-button-type 'apropos-variable + 'apropos-label "Variable" + '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-face + 'apropos-label "Face" + 'help-echo "mouse-2, RET: Display more help on this face" + 'follow-link t + 'action (lambda (button) + (describe-face (button-get button 'apropos-symbol)))) + +(define-button-type 'apropos-group + 'apropos-label "Group" + 'help-echo "mouse-2, RET: Display more help on this group" + 'follow-link t + 'action (lambda (button) + (customize-group-other-window + (button-get button 'apropos-symbol)))) + +(define-button-type 'apropos-widget + 'apropos-label "Widget" + '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" + '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)))) (defun apropos-next-label-button (pos) - "Returns the next `apropos-label' button after POS, or nil if there's none. + "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 before finding a label." - (let* ((button (next-button pos 1 nil t)) + (let* ((button (next-button pos t)) (already-hit-symbol nil) - (button-type (and button (button-get button 'type)))) + (label (and button (button-get button 'apropos-label))) + (type (and button (button-get button 'type)))) (while (and button - (not (eq button-type 'apropos-label)) - (or (not (eq button-type 'apropos-symbol)) + (not label) + (or (not (eq type 'apropos-symbol)) (not already-hit-symbol))) - (when (eq button-type 'apropos-symbol) + (when (eq type 'apropos-symbol) (setq already-hit-symbol t)) (setq button (next-button (button-start button))) (when button - (setq button-type (button-get button 'type)))) - (and (eq button-type 'apropos-label) - button))) + (setq label (button-get button 'apropos-label)) + (setq type (button-get button 'type)))) + (and label button))) +(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 "\\|") + "\\)") + ""))) + ;;;###autoload +(defun apropos-read-pattern (subject) + "Read an apropos pattern, either a word list or a regexp. +Returns the user pattern, either a list of words which are matched +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): ")))) + (if (string-equal (regexp-quote pattern) pattern) + ;; Split into words + (split-string pattern "[ \t]+") + pattern))) + +(defun apropos-parse-pattern (pattern) + "Rewrite a list of words to a regexp matching all permutations. +If PATTERN is a string, that means it is already a regexp. +This updates variables `apropos-pattern', `apropos-pattern-quoted', +`apropos-regexp', `apropos-words', and `apropos-all-words-regexp'." + (setq apropos-words nil + apropos-all-words nil) + (if (consp pattern) + ;; We don't actually make a regexp matching all permutations. + ;; Instead, for e.g. "a b c", we make a regexp matching + ;; any combination of two or more words like this: + ;; (a|b|c).*(a|b|c) which may give some false matches, + ;; but as long as it also gives the right ones, that's ok. + (let ((words pattern)) + (setq apropos-pattern (mapconcat 'identity pattern " ") + apropos-pattern-quoted (regexp-quote apropos-pattern)) + (dolist (word words) + (let ((syn apropos-synonyms) (s word) (a word)) + (while syn + (if (member word (car syn)) + (progn + (setq a (mapconcat 'identity (car syn) "\\|")) + (if (member word (cdr (car syn))) + (setq s a)) + (setq syn nil)) + (setq syn (cdr syn)))) + (setq apropos-words (cons s apropos-words) + apropos-all-words (cons a apropos-all-words)))) + (setq apropos-all-words-regexp + (apropos-words-to-regexp apropos-all-words ".+")) + (setq apropos-regexp + (apropos-words-to-regexp apropos-words ".*?"))) + (setq apropos-pattern-quoted (regexp-quote pattern) + apropos-all-words-regexp pattern + 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." + (let (scores i) + (if words + (dolist (word words scores) + (if (setq i (string-match word str)) + (setq scores (cons i scores)))) + ;; Return list of start and end position of regexp + (and (string-match apropos-pattern str) + (list (match-beginning 0) (match-end 0)))))) + +(defun apropos-score-str (str) + "Return apropos score for string STR." + (if str + (let* ((l (length str)) + (score (- (/ l 10)))) + (dolist (s (apropos-calc-scores str apropos-all-words) score) + (setq score (+ score 1000 (/ (* (- l s) 1000) l))))) + 0)) + +(defun apropos-score-doc (doc) + "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)) + (setq score 10000)) + (dolist (s (apropos-calc-scores doc apropos-all-words) score) + (setq score (+ score 50 (/ (* (- l s) 50) l))))) + 0))) + +(defun apropos-score-symbol (symbol &optional weight) + "Return apropos score for SYMBOL." + (setq symbol (symbol-name symbol)) + (let ((score 0) + (l (length symbol))) + (dolist (s (apropos-calc-scores symbol apropos-words) (* score (or weight 3))) + (setq score (+ score (- 60 l) (/ (* (- l s) 60) l)))))) + +(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)." + (or (not str) + (not words) + (not (cdr words)) + (> (length (apropos-calc-scores str words)) 1))) + +(defun apropos-false-hit-symbol (symbol) + "Return t if SYMBOL is not really matched by the current keywords." + (not (apropos-true-hit (symbol-name symbol) apropos-words))) + +(defun apropos-false-hit-str (str) + "Return t if STR is not really matched by the current keywords." + (not (apropos-true-hit str apropos-words))) + +(defun apropos-true-hit-doc (doc) + "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" "Major mode for following hyperlinks in output of apropos commands. \\{apropos-mode-map}") ;;;###autoload -(defun apropos-variable (regexp &optional do-all) - "Show user variables that match REGEXP. -With optional prefix DO-ALL or if `apropos-do-all' is non-nil, also show +(defun apropos-variable (pattern &optional do-all) + "Show user variables 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." - (interactive (list (read-string - (concat "Apropos " - (if (or current-prefix-arg apropos-do-all) - "variable" - "user option") - " (regexp): ")) + (interactive (list (apropos-read-pattern + (if (or current-prefix-arg apropos-do-all) + "variable" "user option")) current-prefix-arg)) - (apropos-command regexp nil + (apropos-command pattern nil (if (or do-all apropos-do-all) #'(lambda (symbol) (and (boundp symbol) @@ -199,22 +427,28 @@ normal variables." ;; For auld lang syne: ;;;###autoload -(fset 'command-apropos 'apropos-command) +(defalias 'command-apropos 'apropos-command) ;;;###autoload -(defun apropos-command (apropos-regexp &optional do-all var-predicate) - "Show commands (interactively callable functions) that match APROPOS-REGEXP. -With optional prefix DO-ALL, or if `apropos-do-all' is non-nil, also show +(defun apropos-command (pattern &optional do-all var-predicate) + "Show commands (interactively callable functions) 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 noninteractive functions. If VAR-PREDICATE is non-nil, show only variables, and only those that -satisfy the predicate VAR-PREDICATE." - (interactive (list (read-string (concat - "Apropos command " - (if (or current-prefix-arg - apropos-do-all) - "or function ") - "(regexp): ")) +satisfy the predicate VAR-PREDICATE. + +When called from a Lisp program, a string PATTERN is used as a regexp, +while a list of strings is used as a word list." + (interactive (list (apropos-read-pattern + (if (or current-prefix-arg apropos-do-all) + "command or function" "command")) current-prefix-arg)) + (apropos-parse-pattern pattern) (let ((message (let ((standard-output (get-buffer-create "*Apropos*"))) (print-help-return-message 'identity)))) @@ -225,135 +459,186 @@ satisfy the predicate VAR-PREDICATE." (if do-all 'functionp 'commandp)))) (let ((tem apropos-accumulator)) (while tem - (if (get (car tem) 'apropos-inhibit) + (if (or (get (car tem) 'apropos-inhibit) + (apropos-false-hit-symbol (car tem))) (setq apropos-accumulator (delq (car tem) apropos-accumulator))) (setq tem (cdr tem)))) (let ((p apropos-accumulator) - doc symbol) + doc symbol score) (while p (setcar p (list (setq symbol (car p)) + (setq score (apropos-score-symbol symbol)) (unless var-predicate (if (functionp symbol) (if (setq doc (documentation symbol t)) - (substring doc 0 (string-match "\n" doc)) + (progn + (setq score (+ score (apropos-score-doc doc))) + (substring doc 0 (string-match "\n" doc))) "(not documented)"))) (and var-predicate (funcall var-predicate symbol) (if (setq doc (documentation-property symbol 'variable-documentation t)) - (substring doc 0 - (string-match "\n" doc)))))) + (progn + (setq score (+ score (apropos-score-doc doc))) + (substring doc 0 + (string-match "\n" doc))))))) + (setcar (cdr (car p)) score) (setq p (cdr p)))) - (and (apropos-print t nil) + (and (apropos-print t nil nil t) message - (message message)))) + (message "%s" message)))) ;;;###autoload -(defun apropos (apropos-regexp &optional do-all) - "Show all bound symbols whose names match APROPOS-REGEXP. -With optional prefix DO-ALL or if `apropos-do-all' is non-nil, also -show unbound symbols and key bindings, which is a little more -time-consuming. Returns list of symbols and documentation found." - (interactive "sApropos symbol (regexp): \nP") - (setq apropos-accumulator - (apropos-internal apropos-regexp - (and (not do-all) - (not apropos-do-all) - (lambda (symbol) - (or (fboundp symbol) - (boundp symbol) - (facep symbol) - (symbol-plist symbol)))))) - (let ((tem apropos-accumulator)) - (while tem - (if (get (car tem) 'apropos-inhibit) - (setq apropos-accumulator (delq (car tem) apropos-accumulator))) - (setq tem (cdr tem)))) - (let ((p apropos-accumulator) - symbol doc properties) - (while p - (setcar p (list - (setq symbol (car p)) - (when (fboundp symbol) - (if (setq doc (condition-case nil - (documentation symbol t) - (void-function - "(alias for undefined function)"))) - (substring doc 0 (string-match "\n" doc)) - "(not documented)")) - (when (boundp symbol) - (if (setq doc (documentation-property - symbol 'variable-documentation t)) - (substring doc 0 (string-match "\n" doc)) - "(not documented)")) +(defun apropos-documentation-property (symbol property raw) + "Like (documentation-property SYMBOL PROPERTY RAW) but handle errors." + (condition-case () + (let ((doc (documentation-property symbol property raw))) + (if doc (substring doc 0 (string-match "\n" doc)) + "(not documented)")) + (error "(error retrieving documentation)"))) + + +;;;###autoload +(defun apropos (pattern &optional do-all) + "Show all meaningful Lisp symbols whose names match PATTERN. +Symbols are shown if they are defined as functions, variables, or +faces, or if they have nonempty property lists. + +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, +consider all symbols (if they match PATTERN). + +Returns list of symbols and documentation found." + (interactive (list (apropos-read-pattern "symbol") + current-prefix-arg)) + (apropos-parse-pattern pattern) + (apropos-symbols-internal + (apropos-internal apropos-regexp + (and (not do-all) + (not apropos-do-all) + (lambda (symbol) + (or (fboundp symbol) + (boundp symbol) + (facep symbol) + (symbol-plist symbol))))) + (or do-all apropos-do-all))) + +(defun apropos-symbols-internal (symbols keys &optional text) + ;; Filter out entries that are marked as apropos-inhibit. + (let ((all nil)) + (dolist (symbol symbols) + (unless (get symbol 'apropos-inhibit) + (push symbol all))) + (setq symbols all)) + (let ((apropos-accumulator + (mapcar + (lambda (symbol) + (let (doc properties) + (list + symbol + (apropos-score-symbol symbol) + (when (fboundp symbol) + (if (setq doc (condition-case nil + (documentation symbol t) + (void-function + "(alias for undefined function)") + (error + "(can't retrieve function documentation)"))) + (substring doc 0 (string-match "\n" doc)) + "(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) - (if (setq doc (documentation-property - symbol 'widget-documentation t)) - (substring doc 0 - (string-match "\n" doc)) - "(not documented)")) - (when (facep symbol) - (if (setq doc (documentation-property - symbol 'face-documentation t)) - (substring doc 0 - (string-match "\n" doc)) - "(not documented)")) - (when (get symbol 'custom-group) - (if (setq doc (documentation-property - symbol 'group-documentation t)) - (substring doc 0 - (string-match "\n" doc)) - "(not documented)")))) - (setq p (cdr p)))) - (apropos-print - (or do-all apropos-do-all) - nil)) + (apropos-documentation-property + symbol 'widget-documentation t)) + (when (facep symbol) + (apropos-documentation-property + symbol 'face-documentation t)) + (when (get symbol 'custom-group) + (apropos-documentation-property + symbol 'group-documentation t))))) + symbols))) + (apropos-print keys nil text))) ;;;###autoload -(defun apropos-value (apropos-regexp &optional do-all) - "Show all symbols whose value's printed image matches APROPOS-REGEXP. -With optional prefix DO-ALL or if `apropos-do-all' is non-nil, also looks +(defun apropos-value (pattern &optional do-all) + "Show all symbols whose value's printed representation matches 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 looks at the function and at the names and values of properties. Returns list of symbols and values found." - (interactive "sApropos value (regexp): \nP") + (interactive (list (apropos-read-pattern "value") + current-prefix-arg)) + (apropos-parse-pattern pattern) (or do-all (setq do-all apropos-do-all)) (setq apropos-accumulator ()) (let (f v p) (mapatoms (lambda (symbol) (setq f nil v nil p nil) - (or (memq symbol '(apropos-regexp do-all apropos-accumulator - symbol f v p)) + (or (memq symbol '(apropos-regexp + apropos-pattern apropos-all-words-regexp + apropos-words apropos-all-words + do-all apropos-accumulator + symbol f v p)) (setq v (apropos-value-internal 'boundp symbol 'symbol-value))) (if do-all (setq f (apropos-value-internal 'fboundp symbol 'symbol-function) p (apropos-format-plist symbol "\n " t))) + (if (apropos-false-hit-str v) + (setq v nil)) + (if (apropos-false-hit-str f) + (setq f nil)) + (if (apropos-false-hit-str p) + (setq p nil)) (if (or f v p) - (setq apropos-accumulator (cons (list symbol f v p) + (setq apropos-accumulator (cons (list symbol + (+ (apropos-score-str f) + (apropos-score-str v) + (apropos-score-str p)) + f v p) apropos-accumulator)))))) - (apropos-print nil t)) + (apropos-print nil "\n----------------\n")) ;;;###autoload -(defun apropos-documentation (apropos-regexp &optional do-all) - "Show symbols whose documentation contain matches for APROPOS-REGEXP. -With optional prefix DO-ALL or if `apropos-do-all' is non-nil, also use +(defun apropos-documentation (pattern &optional do-all) + "Show symbols whose documentation contains matches for 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 use documentation that is not stored in the documentation file and show key bindings. Returns list of symbols and documentation found." - (interactive "sApropos documentation (regexp): \nP") + (interactive (list (apropos-read-pattern "documentation") + current-prefix-arg)) + (apropos-parse-pattern pattern) (or do-all (setq do-all apropos-do-all)) (setq apropos-accumulator () apropos-files-scanned ()) (let ((standard-input (get-buffer-create " apropos-temp")) - f v) + (apropos-sort-by-scores apropos-documentation-sort-by-scores) + f v sf sv) (unwind-protect (save-excursion (set-buffer standard-input) @@ -366,18 +651,26 @@ Returns list of symbols and documentation found." (if (integerp v) (setq v)) (setq f (apropos-documentation-internal f) v (apropos-documentation-internal v)) + (setq sf (apropos-score-doc f) + sv (apropos-score-doc v)) (if (or f v) (if (setq apropos-item (cdr (assq symbol apropos-accumulator))) (progn (if f - (setcar apropos-item f)) + (progn + (setcar (nthcdr 1 apropos-item) f) + (setcar apropos-item (+ (car apropos-item) sf)))) (if v - (setcar (cdr apropos-item) v))) + (progn + (setcar (nthcdr 2 apropos-item) v) + (setcar apropos-item (+ (car apropos-item) sv))))) (setq apropos-accumulator - (cons (list symbol f v) + (cons (list symbol + (+ (apropos-score-symbol symbol 2) sf sv) + f v) apropos-accumulator))))))) - (apropos-print nil t)) + (apropos-print nil "\n----------------\n" nil t)) (kill-buffer standard-input)))) @@ -396,15 +689,17 @@ Returns list of symbols and documentation found." (defun apropos-documentation-internal (doc) (if (consp doc) (apropos-documentation-check-elc-file (car doc)) - (and doc - (string-match apropos-regexp doc) - (progn - (if apropos-match-face - (put-text-property (match-beginning 0) - (match-end 0) - 'face apropos-match-face - (setq doc (copy-sequence doc)))) - doc)))) + (if (and doc + (string-match apropos-all-words-regexp doc) + (apropos-true-hit-doc doc)) + (when apropos-match-face + (setq doc (substitute-command-keys (copy-sequence doc))) + (if (or (string-match apropos-pattern-quoted doc) + (string-match apropos-all-words-regexp doc)) + (put-text-property (match-beginning 0) + (match-end 0) + 'face apropos-match-face doc)) + doc)))) (defun apropos-format-plist (pl sep &optional compare) (setq pl (symbol-plist pl)) @@ -430,7 +725,7 @@ Returns list of symbols and documentation found." ;; Finds all documentation related to APROPOS-REGEXP in internal-doc-file-name. (defun apropos-documentation-check-doc-file () - (let (type symbol (sepa 2) sepb beg end) + (let (type symbol (sepa 2) sepb) (insert ?\^_) (backward-char) (insert-file-contents (concat doc-directory internal-doc-file-name)) @@ -441,25 +736,32 @@ Returns list of symbols and documentation found." (beginning-of-line 2) (if (save-restriction (narrow-to-region (point) (1- sepb)) - (re-search-forward apropos-regexp nil t)) + (re-search-forward apropos-all-words-regexp nil t)) (progn - (setq beg (match-beginning 0) - end (point)) (goto-char (1+ sepa)) - (or (setq type (if (eq ?F (preceding-char)) - 1 ; function documentation - 2) ; variable documentation - symbol (read) - beg (- beg (point) 1) - end (- end (point) 1) - doc (buffer-substring (1+ (point)) (1- sepb)) - apropos-item (assq symbol apropos-accumulator)) - (setq apropos-item (list symbol nil nil) - apropos-accumulator (cons apropos-item - apropos-accumulator))) - (if apropos-match-face - (put-text-property beg end 'face apropos-match-face doc)) - (setcar (nthcdr type apropos-item) doc))) + (setq type (if (eq ?F (preceding-char)) + 2 ; function documentation + 3) ; variable documentation + symbol (read) + doc (buffer-substring (1+ (point)) (1- sepb))) + (when (apropos-true-hit-doc doc) + (or (and (setq apropos-item (assq symbol apropos-accumulator)) + (setcar (cdr apropos-item) + (apropos-score-doc doc))) + (setq apropos-item (list symbol + (+ (apropos-score-symbol symbol 2) + (apropos-score-doc doc)) + nil nil) + apropos-accumulator (cons apropos-item + apropos-accumulator))) + (when apropos-match-face + (setq doc (substitute-command-keys doc)) + (if (or (string-match apropos-pattern-quoted doc) + (string-match apropos-all-words-regexp doc)) + (put-text-property (match-beginning 0) + (match-end 0) + 'face apropos-match-face doc))) + (setcar (nthcdr type apropos-item) doc)))) (setq sepa (goto-char sepb))))) (defun apropos-documentation-check-elc-file (file) @@ -478,34 +780,44 @@ Returns list of symbols and documentation found." (if (save-restriction ;; match ^ and $ relative to doc string (narrow-to-region beg end) - (re-search-forward apropos-regexp nil t)) + (re-search-forward apropos-all-words-regexp nil t)) (progn (goto-char (+ end 2)) (setq doc (buffer-substring beg end) end (- (match-end 0) beg) - beg (- (match-beginning 0) beg) - this-is-a-variable (looking-at "(def\\(var\\|const\\) ") - symbol (progn - (skip-chars-forward "(a-z") - (forward-char) - (read)) - symbol (if (consp symbol) - (nth 1 symbol) - symbol)) - (if (if this-is-a-variable - (get symbol 'variable-documentation) - (and (fboundp symbol) (apropos-safe-documentation symbol))) - (progn - (or (setq apropos-item (assq symbol apropos-accumulator)) - (setq apropos-item (list symbol nil nil) - apropos-accumulator (cons apropos-item - apropos-accumulator))) - (if apropos-match-face - (put-text-property beg end 'face apropos-match-face - doc)) - (setcar (nthcdr (if this-is-a-variable 2 1) - apropos-item) - doc))))))))) + beg (- (match-beginning 0) beg)) + (when (apropos-true-hit-doc doc) + (setq this-is-a-variable (looking-at "(def\\(var\\|const\\) ") + symbol (progn + (skip-chars-forward "(a-z") + (forward-char) + (read)) + symbol (if (consp symbol) + (nth 1 symbol) + symbol)) + (if (if this-is-a-variable + (get symbol 'variable-documentation) + (and (fboundp symbol) (apropos-safe-documentation symbol))) + (progn + (or (and (setq apropos-item (assq symbol apropos-accumulator)) + (setcar (cdr apropos-item) + (+ (cadr apropos-item) (apropos-score-doc doc)))) + (setq apropos-item (list symbol + (+ (apropos-score-symbol symbol 2) + (apropos-score-doc doc)) + nil nil) + apropos-accumulator (cons apropos-item + apropos-accumulator))) + (when apropos-match-face + (setq doc (substitute-command-keys doc)) + (if (or (string-match apropos-pattern-quoted doc) + (string-match apropos-all-words-regexp doc)) + (put-text-property (match-beginning 0) + (match-end 0) + 'face apropos-match-face doc))) + (setcar (nthcdr (if this-is-a-variable 3 2) + apropos-item) + doc)))))))))) @@ -532,23 +844,29 @@ Will return nil instead." function)) - -(defvar apropos-label-properties nil - "List of face properties to use for a label. -Bound by `apropos-print' for use by `apropos-print-doc'.") - -(defun apropos-print (do-keys spacing) +(defun apropos-print (do-keys spacing &optional text nosubst) "Output result of apropos searching into buffer `*Apropos*'. The value of `apropos-accumulator' is the list of items to output. -Each element should have the format (SYMBOL FN-DOC VAR-DOC [PLIST-DOC]). +Each element should have the format + (SYMBOL SCORE FN-DOC VAR-DOC [PLIST-DOC WIDGET-DOC FACE-DOC GROUP-DOC]). The return value is the list that was in `apropos-accumulator', sorted alphabetically by symbol name; but this function also sets -`apropos-accumulator' to nil before returning." +`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 (null apropos-accumulator) - (message "No apropos matches for `%s'" apropos-regexp) + (message "No apropos matches for `%s'" apropos-pattern) (setq apropos-accumulator - (sort apropos-accumulator (lambda (a b) - (string-lessp (car a) (car b))))) + (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)) + (string-lessp (car a) (car b)))) + (string-lessp (car a) (car b)))))) (with-output-to-temp-buffer "*Apropos*" (let ((p apropos-accumulator) (old-buffer (current-buffer)) @@ -556,27 +874,41 @@ alphabetically by symbol name; but this function also sets (set-buffer standard-output) (apropos-mode) (if (display-mouse-p) - (insert "If moving the mouse over text changes the text's color,\n" - (substitute-command-keys - "you can click \\[push-button] on that text to get more information.\n"))) + (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")) + (if text (insert text "\n\n")) (while (consp p) - (or (not spacing) (bobp) (terpri)) + (when (and spacing (not (bobp))) + (princ spacing)) (setq apropos-item (car p) symbol (car apropos-item) p (cdr p)) + ;; Insert dummy score element for backwards compatibility with 21.x + ;; apropos-item format. + (if (not (numberp (cadr apropos-item))) + (setq apropos-item + (cons (car apropos-item) + (cons nil (cdr apropos-item))))) (insert-text-button (symbol-name symbol) 'type 'apropos-symbol ;; Can't use default, since user may have ;; changed the variable! ;; Just say `no' to variables containing faces! 'face apropos-symbol-face) + (if (and (eq apropos-sort-by-scores 'verbose) + (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 @@ -611,40 +943,32 @@ alphabetically by symbol name; but this function also sets key)) key) item ", ")) - (insert "M-x") - (put-text-property (- (point) 3) (point) - 'face apropos-keybinding-face) - (insert " " (symbol-name symbol) " ") - (insert "RET") - (put-text-property (- (point) 3) (point) - 'face apropos-keybinding-face))) + (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 'describe-function 1 + (apropos-print-doc 2 (if (commandp symbol) - "Command" + 'apropos-command (if (apropos-macrop symbol) - "Macro" - "Function")) - t) - ;; We used to use `customize-variable-other-window' instead - ;; for a customizable variable, but that is slow. - ;; It is better to show an ordinary help buffer - ;; and let the user click on the customization button - ;; in that buffer, if he wants to. - ;; Likewise for `customize-face-other-window'. - (apropos-print-doc 'describe-variable 2 "Variable" t) - (apropos-print-doc 'customize-group-other-window 6 "Group" t) - (apropos-print-doc 'describe-face 5 "Face" t) - (apropos-print-doc 'widget-browse-other-window 4 "Widget" t) - (apropos-print-doc 'apropos-describe-plist 3 - "Plist" nil)) + 'apropos-macro + 'apropos-function)) + (not nosubst)) + (apropos-print-doc 3 '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) + (apropos-print-doc 4 'apropos-plist nil)) (setq buffer-read-only t)))) (prog1 apropos-accumulator (setq apropos-accumulator ()))) ; permit gc (defun apropos-macrop (symbol) - "T if SYMBOL is a Lisp macro." + "Return t if SYMBOL is a Lisp macro." (and (fboundp symbol) (consp (setq symbol (symbol-function symbol))) @@ -654,19 +978,17 @@ alphabetically by symbol name; but this function also sets '(macro t)))))) -(defun apropos-print-doc (action i str do-keys) +(defun apropos-print-doc (i type do-keys) (if (stringp (setq i (nth i apropos-item))) (progn (insert " ") - (insert-text-button str - 'type 'apropos-label + (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) - 'apropos-action action - str) + 'apropos-symbol (car apropos-item)) (insert ": ") (insert (if do-keys (substitute-command-keys i) i)) (or (bolp) (terpri))))) @@ -682,13 +1004,15 @@ alphabetically by symbol name; but this function also sets (defun apropos-describe-plist (symbol) "Display a pretty listing of SYMBOL's plist." - (with-output-to-temp-buffer "*Help*" + (help-setup-xref (list 'apropos-describe-plist symbol) (interactive-p)) + (with-output-to-temp-buffer (help-buffer) (set-buffer standard-output) (princ "Symbol ") (prin1 symbol) (princ "'s plist is\n (") (if apropos-symbol-face - (put-text-property 8 (- (point) 14) 'face apropos-symbol-face)) + (put-text-property (+ (point-min) 7) (- (point) 14) + 'face apropos-symbol-face)) (insert (apropos-format-plist symbol "\n ")) (princ ")") (print-help-return-message))) @@ -696,4 +1020,5 @@ alphabetically by symbol name; but this function also sets (provide 'apropos) +;;; arch-tag: d56fa2ac-e56b-4ce3-84ff-852f9c0dc66e ;;; apropos.el ends here