+(require 'button)
+(eval-when-compile (require 'cl))
+
+(defgroup apropos nil
+ "Apropos commands for users and programmers."
+ :group 'help
+ :prefix "apropos")
+
+;; 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."
+ :group 'apropos
+ :type 'boolean)
+
+
+(defcustom apropos-symbol-face 'bold
+ "*Face for symbol name in Apropos output, or nil for none."
+ :group 'apropos
+ :type 'face)
+
+(defcustom apropos-keybinding-face 'underline
+ "*Face for lists of keybinding in Apropos output, or nil for none."
+ :group 'apropos
+ :type 'face)
+
+(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."
+ :group 'apropos
+ :type 'face)
+
+(defcustom apropos-property-face 'bold-italic
+ "*Face for property name in apropos output, or nil for none."
+ :group 'apropos
+ :type 'face)
+
+(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."
+ :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."
+ :group 'apropos
+ :type 'boolean)
+
+(defvar apropos-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map button-buffer-map)
+ ;; Use `apropos-follow' instead of just using the button
+ ;; definition of RET, so that users can use it anywhere in an
+ ;; apropos item, not just on top of a button.
+ (define-key map "\C-m" 'apropos-follow)
+ (define-key map " " 'scroll-up)
+ (define-key map "\177" 'scroll-down)
+ (define-key map "q" 'quit-window)
+ map)
+ "Keymap used in Apropos mode.")
+
+(defvar apropos-mode-hook nil
+ "*Hook run when mode is turned on.")
+
+(defvar apropos-regexp nil
+ "Regexp used in current apropos run.")
+
+(defvar apropos-orig-regexp nil
+ "Regexp as entered by user.")
+
+(defvar apropos-all-regexp nil
+ "Regexp matching apropos-all-words.")
+
+(defvar apropos-files-scanned ()
+ "List of elc files already scanned in current run of `apropos-documentation'.")
+
+(defvar apropos-accumulator ()
+ "Alist of symbols already found in current apropos run.")
+
+(defvar apropos-item ()
+ "Current item in or for `apropos-accumulator'.")
+
+(defvar apropos-synonyms '(
+ ("find" "open" "edit")
+ ("kill" "cut")
+ ("yank" "paste"))
+ "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.")
+
+(defvar apropos-words ()
+ "Current list of words.")
+
+(defvar apropos-all-words ()
+ "Current list of words and synonyms.")
+
+\f
+;;; 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"
+ '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."
+ (button-activate
+ (or (apropos-next-label-button (button-start button))
+ (error "There is nothing to follow for `%s'" (button-label button)))))
+
+(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)
+ "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 t))
+ (already-hit-symbol nil)
+ (label (and button (button-get button 'apropos-label)))
+ (type (and button (button-get button 'type))))
+ (while (and button
+ (not label)
+ (or (not (eq type 'apropos-symbol))
+ (not already-hit-symbol)))
+ (when (eq type 'apropos-symbol)
+ (setq already-hit-symbol t))
+ (setq button (next-button (button-start button)))
+ (when button
+ (setq label (button-get button 'apropos-label))
+ (setq type (button-get button 'type))))
+ (and label button)))
+
+\f
+(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 "\\|")
+ "\\)")
+ "")))
+
+(defun apropos-rewrite-regexp (regexp)
+ "Rewrite a list of words to a regexp matching all permutations.
+If REGEXP is already a regexp, don't modify it."
+ (setq apropos-orig-regexp regexp)
+ (setq apropos-words () apropos-all-words ())
+ (if (string-equal (regexp-quote regexp) regexp)
+ ;; 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]+")))
+ (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-regexp (apropos-words-to-regexp apropos-all-words ".+"))
+ (apropos-words-to-regexp apropos-words ".*?"))
+ (setq apropos-all-regexp regexp)))
+
+(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
+ (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)
+ (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)
+ (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))
+ i)
+ (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}")