# HG changeset patch # User Kim F. Storm # Date 1022185290 0 # Node ID 7d28e8eeee0d9ae3fbc7c9bfc8c739b026c602a9 # Parent 8e25c7fbd1df0921d7686de8aca163656a9640c9 (apropos-true-hit, apropos-false-hit-symbol) (apropos-false-hit-str, apropos-true-hit-doc): New functions. (apropos-command, apropos-value, apropos-documentation-internal) (apropos-documentation-check-doc-file) (apropos-documentation-check-elc-file): Use them to filter out false matches where only one keyword matches, but more than once. diff -r 8e25c7fbd1df -r 7d28e8eeee0d lisp/apropos.el --- a/lisp/apropos.el Thu May 23 20:20:57 2002 +0000 +++ b/lisp/apropos.el Thu May 23 20:21:30 2002 +0000 @@ -324,6 +324,27 @@ (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)) + ;;;###autoload (define-derived-mode apropos-mode fundamental-mode "Apropos" "Major mode for following hyperlinks in output of apropos commands. @@ -378,7 +399,8 @@ (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) @@ -501,6 +523,12 @@ (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 (+ (apropos-score-str f) @@ -576,6 +604,7 @@ (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) @@ -624,25 +653,26 @@ (setq beg (match-beginning 0) end (point)) (goto-char (1+ sepa)) - (or (and (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)) - 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))) - (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) + 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)))) + (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)) + (setcar (nthcdr type apropos-item) doc)))) (setq sepa (goto-char sepb))))) (defun apropos-documentation-check-elc-file (file) @@ -666,34 +696,35 @@ (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 (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))) - (if apropos-match-face - (put-text-property beg end 'face apropos-match-face - doc)) - (setcar (nthcdr (if this-is-a-variable 3 2) - 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))) + (if apropos-match-face + (put-text-property beg end 'face apropos-match-face + doc)) + (setcar (nthcdr (if this-is-a-variable 3 2) + apropos-item) + doc))))))))))