X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/30aab7419ba8a9a51a3a20d51cf1a2f314f650c7..4342e957a2521bbe9b574871e3bbd60d63c93461:/lisp/apropos.el

diff --git a/lisp/apropos.el b/lisp/apropos.el
index 3bcaeafdca..b9d7e3ff41 100644
--- a/lisp/apropos.el
+++ b/lisp/apropos.el
@@ -1,6 +1,6 @@
 ;;; apropos.el --- apropos commands for users and programmers
 
-;; Copyright (C) 1989, 1994, 1995, 2001, 2002 Free Software Foundation, Inc.
+;; Copyright (C) 1989,94,1995,2001,02,03,04,2005  Free Software Foundation, Inc.
 
 ;; Author: Joe Wells <jbw@bigbird.bu.edu>
 ;; Rewritten: Daniel Pfeiffer <occitan@esperanto.org>
@@ -58,6 +58,7 @@
 ;;; Code:
 
 (require 'button)
+(eval-when-compile (require 'cl))
 
 (defgroup apropos nil
   "Apropos commands for users and programmers"
@@ -95,15 +96,16 @@ 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."
   :group 'apropos
   :type 'face)
 
-(defcustom apropos-show-scores nil
-  "*Non-nil means show score for each match, and sort matches by scores."
+(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)
 
@@ -161,6 +163,7 @@ term, and the rest of the words are alternative terms.")
 (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)
 
@@ -172,19 +175,24 @@ term, and the rest of the words are alternative terms.")
 
 (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)))
-  'help-echo "mouse-2, RET: Display more help on this function")
+	    (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)))
-  'help-echo "mouse-2, RET: Display more help on this macro")
+	    (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)))
-  'help-echo "mouse-2, RET: Display more help on this command")
+	    (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
@@ -194,18 +202,21 @@ term, and the rest of the words are alternative terms.")
 (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))))
@@ -213,12 +224,14 @@ term, and the rest of the words are alternative terms.")
 (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))))
 
@@ -247,9 +260,10 @@ before finding a label."
   "Make regexp matching any two of the words in WORDS."
   (concat "\\("
 	  (mapconcat 'identity words "\\|")
-	  "\\)" wild
+	  "\\)"
 	  (if (cdr words)
-	      (concat "\\("
+	      (concat wild
+		      "\\("
 		      (mapconcat 'identity words "\\|")
 		      "\\)")
 	    "")))
@@ -308,13 +322,13 @@ Value is a list of offsets of the words into the string."
 
 (defun apropos-score-doc (doc)
   "Return apropos score for documentation string DOC."
-  (if doc
-      (let ((score 0)
-	    (l (length doc))
-	    i)
-	(dolist (s (apropos-calc-scores doc apropos-all-words) score)
-	  (setq score (+ score 50 (/ (* (- l s) 50) l)))))
-      0))
+  (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."
@@ -346,7 +360,6 @@ This requires that at least 2 keywords (unless only one was given)."
   "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.
 
@@ -450,37 +463,42 @@ show unbound symbols and key bindings, which is a little more
 time-consuming.  Returns list of symbols and documentation found."
   (interactive "sApropos symbol (regexp or words): \nP")
   (setq apropos-regexp (apropos-rewrite-regexp apropos-regexp))
-  (setq apropos-accumulator
-	(apropos-internal apropos-regexp
+  (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))))))
-  (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))
-		 (apropos-score-symbol symbol)
-		 (when (fboundp symbol)
-		   (if (setq doc (condition-case nil
-				     (documentation symbol t)
-				   (void-function
-				    "(alias for undefined function)")
-				   (error
-				    "(error retrieving function documentation)")))
-		       (substring doc 0 (string-match "\n" doc))
-		     "(not documented)"))
-		 (when (boundp symbol)
-		   (apropos-documentation-property
+				     (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)))
@@ -490,16 +508,14 @@ time-consuming.  Returns list of symbols and documentation found."
 		 (when (get symbol 'widget-type)
 		   (apropos-documentation-property
 		    symbol 'widget-documentation t))
-		 (when (facep symbol)
-		   (apropos-documentation-property
-		    symbol 'face-documentation t))
-		 (when (get symbol 'custom-group)
+	       (when (facep symbol)
+		 (apropos-documentation-property
+		  symbol 'face-documentation t))
+	       (when (get symbol 'custom-group)
 		   (apropos-documentation-property
-		    symbol 'group-documentation t))))
-      (setq p (cdr p))))
-  (apropos-print
-   (or do-all apropos-do-all)
-   nil))
+		    symbol 'group-documentation t)))))
+	  symbols)))
+    (apropos-print keys nil text)))
 
 
 ;;;###autoload
@@ -753,7 +769,7 @@ Will return nil instead."
     function))
 
 
-(defun apropos-print (do-keys spacing)
+(defun apropos-print (do-keys spacing &optional text)
   "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
@@ -762,8 +778,8 @@ 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.
 
-If SPACING is non-nil, it should be a string;
-separate items with that string."
+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-regexp)
     (setq apropos-accumulator
@@ -771,7 +787,7 @@ separate items with that string."
 		(lambda (a b)
 		  ;; Don't sort by score if user can't see the score.
 		  ;; It would be confusing.  -- rms.
-		  (if apropos-show-scores
+		  (if apropos-sort-by-scores
 		      (or (> (cadr a) (cadr b))
 			  (and (= (cadr a) (cadr b))
 			       (string-lessp (car a) (car b))))
@@ -792,6 +808,7 @@ separate items with that string."
 		" 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)
 	  (when (and spacing (not (bobp)))
 	    (princ spacing))
@@ -804,7 +821,7 @@ separate items with that string."
 			      ;; changed the variable!
 			      ;; Just say `no' to variables containing faces!
 			      'face apropos-symbol-face)
-	  (if apropos-show-scores
+	  (if apropos-sort-by-scores
 	      (insert " (" (number-to-string (cadr apropos-item)) ") "))
 	  ;; Calculate key-bindings if we want them.
 	  (and do-keys
@@ -843,13 +860,12 @@ separate items with that string."
 					      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 2
 			     (if (commandp symbol)
@@ -869,7 +885,7 @@ separate items with that string."
 
 
 (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)))
@@ -905,13 +921,15 @@ separate items with that string."
 
 (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)))
@@ -919,4 +937,5 @@ separate items with that string."
 
 (provide 'apropos)
 
+;;; arch-tag: d56fa2ac-e56b-4ce3-84ff-852f9c0dc66e
 ;;; apropos.el ends here