Mercurial > emacs
changeset 66821:8139e472d52b
(apropos-match-face): Doc fix.
(apropos-sort-by-scores): Add new choice `verbose'.
(apropos-documentation-sort-by-scores): New defcustom.
(apropos-pattern): Now contains the pattern entered by the user.
(apropos-pattern-quoted): New defvar.
(apropos-regexp): New defvar, containing the regexp corresponding
to apropos-pattern.
(apropos-all-words-regexp): Renamed from apropos-all-regexp.
(apropos-read-pattern): New defun. Use it to read pattern arg in
interactive calls; returns list of words for a word list, and
string for a regexp.
(apropos-parse-pattern): Renamed from apropos-rewrite-regexp. Now
parses a list of words or regexp as returned by apropos-read-pattern.
(apropos-calc-scores): Return nil if apropos-regexp doesn't match.
(apropos-score-doc): Return a very high score if the string
entered by the user matches literally.
(apropos-variable): Doc fix. Use apropos-read-pattern.
(apropos-command): Doc fix. Use apropos-read-pattern and
apropos-parse-pattern. Call apropos-print with nosubst=t.
(apropos, apropos-value): Doc fix. Use apropos-read-pattern and
apropos-parse-pattern.
(apropos-documentation): Doc fix. Use apropos-read-pattern and
apropos-parse-pattern. Locally bind apropos-sort-by-scores to
apropos-documentation-sort-by-scores. Call apropos-print with
nosubst=t.
(apropos-documentation-internal): Pass doc string through
substitute-key-definition before adding text properties.
Highlight substring matching literal user input if possible.
(apropos-documentation-check-doc-file): Remove locals beg and end.
Fix calculation of score (as added twice). Pass doc string through
substitute-key-definition before adding text properties.
(apropos-documentation-check-elc-file): Pass doc string through
substitute-key-definition before adding text properties.
Highlight substring matching literal user input if possible.
(apropos-print): Add new arg NOSUBST; if set, command and variable
doc strings have already been passed through substitute-key-definition.
Add code to handle apropos-accumulator items without score element
for backwards compatibility (e.g. with woman package).
Only show scores if apropos-sort-by-scores is `verbose'.
author | Kim F. Storm <storm@cua.dk> |
---|---|
date | Sat, 12 Nov 2005 00:08:50 +0000 |
parents | bd3b98af64fe |
children | 669bbd470d8f |
files | lisp/apropos.el |
diffstat | 1 files changed, 162 insertions(+), 112 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/apropos.el Sat Nov 12 00:08:35 2005 +0000 +++ b/lisp/apropos.el Sat Nov 12 00:08:50 2005 +0000 @@ -100,15 +100,27 @@ (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. -The computed score is shown for each match." +This applies to all `apropos' commands except `apropos-documentation'. +If value is `verbose', the computed score is shown for each match." :group 'apropos - :type 'boolean) + :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))) @@ -127,12 +139,21 @@ "*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-orig-pattern nil - "Regexp as entered by user.") - -(defvar apropos-all-regexp nil +(defvar apropos-all-words-regexp nil "Regexp matching apropos-all-words.") (defvar apropos-files-scanned () @@ -152,12 +173,6 @@ 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.") -(defvar apropos-words () - "Current list of words.") - -(defvar apropos-all-words () - "Current list of words and synonyms.") - ;;; Button types used by apropos @@ -269,19 +284,35 @@ "\\)") ""))) -(defun apropos-rewrite-regexp (regexp) - "Rewrite a space-separated words list to a regexp matching all permutations. -If REGEXP contains any special regexp characters, that means it -is already a regexp, so return it unchanged." - (setq apropos-orig-pattern regexp) - (setq apropos-words () apropos-all-words ()) - (if (string-equal (regexp-quote regexp) regexp) +;;;###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." + (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 (split-string regexp "[ \t]+"))) + (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 @@ -294,30 +325,30 @@ (setq syn (cdr syn)))) (setq apropos-words (cons s apropos-words) apropos-all-words (cons a apropos-all-words)))) - (setq apropos-all-regexp (apropos-words-to-regexp apropos-all-words ".+")) + (setq apropos-all-words-regexp (apropos-words-to-regexp apropos-all-words ".+")) (apropos-words-to-regexp apropos-words ".*?")) - (setq apropos-all-regexp regexp))) + (setq apropos-pattern-quoted (regexp-quote pattern) + apropos-all-words-regexp pattern + apropos-pattern 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) + (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 - (string-match apropos-pattern str) - (list (match-beginning 0) (match-end 0))))) + (and (string-match apropos-regexp 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))) - i) + (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)) @@ -326,8 +357,9 @@ "Return apropos score for documentation string DOC." (let ((l (length doc))) (if (> l 0) - (let ((score 0) - i) + (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))) @@ -336,8 +368,7 @@ "Return apropos score for SYMBOL." (setq symbol (symbol-name symbol)) (let ((score 0) - (l (length symbol)) - i) + (l (length symbol))) (dolist (s (apropos-calc-scores symbol apropos-words) (* score (or weight 3))) (setq score (+ score (- 60 l) (/ (* (- l s) 60) l)))))) @@ -368,18 +399,20 @@ \\{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") - " (word list or 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) @@ -390,32 +423,32 @@ ;;;###autoload (defalias 'command-apropos 'apropos-command) ;;;###autoload -(defun apropos-command (apropos-pattern &optional do-all var-predicate) - "Show commands (interactively callable functions) that match APROPOS-PATTERN. -APROPOS-PATTERN can be a word, a list of words (separated by spaces), +(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 optional prefix DO-ALL, or if `apropos-do-all' is non-nil, also show +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 ") - "(word list or 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)) - (setq apropos-pattern (apropos-rewrite-regexp apropos-pattern)) + (setq apropos-regexp (apropos-parse-pattern pattern)) (let ((message (let ((standard-output (get-buffer-create "*Apropos*"))) (print-help-return-message 'identity)))) (or do-all (setq do-all apropos-do-all)) (setq apropos-accumulator - (apropos-internal apropos-pattern + (apropos-internal apropos-regexp (or var-predicate (if do-all 'functionp 'commandp)))) (let ((tem apropos-accumulator)) @@ -447,7 +480,7 @@ (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 "%s" message)))) @@ -463,20 +496,21 @@ ;;;###autoload -(defun apropos (apropos-pattern &optional do-all) - "Show all bound symbols whose names match APROPOS-PATTERN. -APROPOS-PATTERN can be a word, a list of words (separated by spaces), +(defun apropos (pattern &optional do-all) + "Show all bound symbols whose names 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 optional prefix DO-ALL or if `apropos-do-all' is non-nil, also +With \\[universal-argument] prefix, 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 (word list or regexp): \nP") - (setq apropos-pattern (apropos-rewrite-regexp apropos-pattern)) + (interactive (list (apropos-read-pattern "symbol") + current-prefix-arg)) + (setq apropos-regexp (apropos-parse-pattern pattern)) (apropos-symbols-internal - (apropos-internal apropos-pattern + (apropos-internal apropos-regexp (and (not do-all) (not apropos-do-all) (lambda (symbol) @@ -531,26 +565,27 @@ ;;;###autoload -(defun apropos-value (apropos-pattern &optional do-all) - "Show all symbols whose value's printed image matches APROPOS-PATTERN. -APROPOS-PATTERN can be a word, a list of words (separated by spaces), +(defun apropos-value (pattern &optional do-all) + "Show all symbols whose value's printed image 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 optional prefix DO-ALL or if `apropos-do-all' is non-nil, also looks +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 (word list or regexp): \nP") - (setq apropos-pattern (apropos-rewrite-regexp apropos-pattern)) + (interactive (list (apropos-read-pattern "value") + current-prefix-arg)) + (setq apropos-regexp (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-pattern - apropos-orig-pattern apropos-all-regexp + (or (memq symbol '(apropos-regexp + apropos-pattern apropos-all-words-regexp apropos-words apropos-all-words do-all apropos-accumulator symbol f v p)) @@ -575,22 +610,24 @@ ;;;###autoload -(defun apropos-documentation (apropos-pattern &optional do-all) - "Show symbols whose documentation contain matches for APROPOS-PATTERN. -APROPOS-PATTERN can be a word, a list of words (separated by spaces), +(defun apropos-documentation (pattern &optional do-all) + "Show symbols whose documentation contain 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 optional prefix DO-ALL or if `apropos-do-all' is non-nil, also use +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 (word list or regexp): \nP") - (setq apropos-pattern (apropos-rewrite-regexp apropos-pattern)) + (interactive (list (apropos-read-pattern "documentation") + current-prefix-arg)) + (setq apropos-regexp (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")) + (apropos-sort-by-scores apropos-documentation-sort-by-scores) f v sf sv) (unwind-protect (save-excursion @@ -623,7 +660,7 @@ (+ (apropos-score-symbol symbol 2) sf sv) f v) apropos-accumulator))))))) - (apropos-print nil "\n----------------\n")) + (apropos-print nil "\n----------------\n" nil t)) (kill-buffer standard-input)))) @@ -631,7 +668,7 @@ (if (funcall predicate symbol) (progn (setq symbol (prin1-to-string (funcall function symbol))) - (if (string-match apropos-pattern symbol) + (if (string-match apropos-regexp symbol) (progn (if apropos-match-face (put-text-property (match-beginning 0) (match-end 0) @@ -642,23 +679,24 @@ (defun apropos-documentation-internal (doc) (if (consp doc) (apropos-documentation-check-elc-file (car doc)) - (and doc - (string-match apropos-all-regexp doc) - (save-match-data (apropos-true-hit-doc 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)) (let (p p-out) (while pl (setq p (format "%s %S" (car pl) (nth 1 pl))) - (if (or (not compare) (string-match apropos-pattern p)) + (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)) @@ -674,10 +712,10 @@ p-out)) -;; Finds all documentation related to APROPOS-PATTERN in internal-doc-file-name. +;; 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)) @@ -688,30 +726,31 @@ (beginning-of-line 2) (if (save-restriction (narrow-to-region (point) (1- sepb)) - (re-search-forward apropos-all-regexp nil t)) + (re-search-forward apropos-all-words-regexp nil t)) (progn - (setq beg (match-beginning 0) - end (point)) (goto-char (1+ sepa)) (setq type (if (eq ?F (preceding-char)) 2 ; function documentation 3) ; variable documentation symbol (read) - beg (- beg (point) 1) - end (- end (point) 1) 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) - (+ (cadr apropos-item) (apropos-score-doc doc)))) + (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))) - (if apropos-match-face - (put-text-property beg end 'face apropos-match-face doc)) + (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))))) @@ -731,7 +770,7 @@ (if (save-restriction ;; match ^ and $ relative to doc string (narrow-to-region beg end) - (re-search-forward apropos-all-regexp nil t)) + (re-search-forward apropos-all-words-regexp nil t)) (progn (goto-char (+ end 2)) (setq doc (buffer-substring beg end) @@ -759,9 +798,13 @@ nil nil) apropos-accumulator (cons apropos-item apropos-accumulator))) - (if apropos-match-face - (put-text-property beg end 'face apropos-match-face - doc)) + (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)))))))))) @@ -791,7 +834,7 @@ function)) -(defun apropos-print (do-keys spacing &optional text) +(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 @@ -803,7 +846,7 @@ 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-orig-pattern) + (message "No apropos matches for `%s'" apropos-pattern) (setq apropos-accumulator (sort apropos-accumulator (lambda (a b) @@ -837,13 +880,20 @@ (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 apropos-sort-by-scores + (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 @@ -895,8 +945,8 @@ (if (apropos-macrop symbol) 'apropos-macro 'apropos-function)) - t) - (apropos-print-doc 3 'apropos-variable t) + (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)