X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/1bad168e59601c1c843a38b2962e77b29f497f11..2b34df4ebc935a834a77b930b35c4a42f7236440:/lisp/apropos.el

diff --git a/lisp/apropos.el b/lisp/apropos.el
index 0ca6248ea5..45463784cb 100644
--- a/lisp/apropos.el
+++ b/lisp/apropos.el
@@ -1,18 +1,18 @@
 ;;; apropos.el --- apropos commands for users and programmers
 
-;; Copyright (C) 1989, 1994, 1995, 2001, 2002, 2003, 2004,
-;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;; Copyright (C) 1989, 1994, 1995, 2001, 2002, 2003, 2004, 2005, 2006,
+;;   2007, 2008, 2009  Free Software Foundation, Inc.
 
 ;; Author: Joe Wells <jbw@bigbird.bu.edu>
-;; Rewritten: Daniel Pfeiffer <occitan@esperanto.org>
+;;	Daniel Pfeiffer <occitan@esperanto.org> (rewrite)
 ;; Keywords: help
 
 ;; This file is part of GNU Emacs.
 
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
 ;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 3, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
 
 ;; GNU Emacs is distributed in the hope that it will be useful,
 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -20,9 +20,7 @@
 ;; GNU General Public License for more details.
 
 ;; 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., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
 
 ;;; Commentary:
 
@@ -68,7 +66,7 @@
 
 ;; I see a degradation of maybe 10-20% only.
 (defcustom apropos-do-all nil
-  "*Whether the apropos commands should do more.
+  "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
@@ -76,36 +74,36 @@ Slows them down more or less.  Set this non-nil if you have a fast machine."
 
 
 (defcustom apropos-symbol-face 'bold
-  "*Face for symbol name in Apropos output, or nil for none."
+  "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."
+  "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.
+(defcustom apropos-label-face '(italic variable-pitch)
+  "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."
+  "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.
+  "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 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.
+  "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
@@ -114,7 +112,7 @@ If value is `verbose', the computed score is shown for each match."
 		 (const :tag "show scores" verbose)))
 
 (defcustom apropos-documentation-sort-by-scores t
-  "*Non-nil means sort matches by scores; best match is shown first.
+  "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
@@ -136,7 +134,7 @@ If value is `verbose', the computed score is shown for each match."
   "Keymap used in Apropos mode.")
 
 (defvar apropos-mode-hook nil
-  "*Hook run when mode is turned on.")
+  "Hook run when mode is turned on.")
 
 (defvar apropos-pattern nil
   "Apropos pattern as entered by user.")
@@ -181,8 +179,7 @@ term, and the rest of the words are alternative terms.")
   '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)
+  'action #'apropos-symbol-button-display-help)
 
 (defun apropos-symbol-button-display-help (button)
   "Display further help for the `apropos-symbol' button BUTTON."
@@ -192,6 +189,7 @@ term, and the rest of the words are alternative terms.")
 
 (define-button-type 'apropos-function
   'apropos-label "Function"
+  'apropos-short-label "f"
   'help-echo "mouse-2, RET: Display more help on this function"
   'follow-link t
   'action (lambda (button)
@@ -199,6 +197,7 @@ term, and the rest of the words are alternative terms.")
 
 (define-button-type 'apropos-macro
   'apropos-label "Macro"
+  'apropos-short-label "m"
   'help-echo "mouse-2, RET: Display more help on this macro"
   'follow-link t
   'action (lambda (button)
@@ -206,6 +205,7 @@ term, and the rest of the words are alternative terms.")
 
 (define-button-type 'apropos-command
   'apropos-label "Command"
+  'apropos-short-label "c"
   'help-echo "mouse-2, RET: Display more help on this command"
   'follow-link t
   'action (lambda (button)
@@ -218,6 +218,7 @@ term, and the rest of the words are alternative terms.")
 ;; Likewise for `customize-face-other-window'.
 (define-button-type 'apropos-variable
   'apropos-label "Variable"
+  'apropos-short-label "v"
   'help-echo "mouse-2, RET: Display more help on this variable"
   'follow-link t
   'action (lambda (button)
@@ -225,6 +226,7 @@ term, and the rest of the words are alternative terms.")
 
 (define-button-type 'apropos-face
   'apropos-label "Face"
+  'apropos-short-label "F"
   'help-echo "mouse-2, RET: Display more help on this face"
   'follow-link t
   'action (lambda (button)
@@ -232,6 +234,7 @@ term, and the rest of the words are alternative terms.")
 
 (define-button-type 'apropos-group
   'apropos-label "Group"
+  'apropos-short-label "g"
   'help-echo "mouse-2, RET: Display more help on this group"
   'follow-link t
   'action (lambda (button)
@@ -240,6 +243,7 @@ term, and the rest of the words are alternative terms.")
 
 (define-button-type 'apropos-widget
   'apropos-label "Widget"
+  'apropos-short-label "w"
   'help-echo "mouse-2, RET: Display more help on this widget"
   'follow-link t
   'action (lambda (button)
@@ -247,11 +251,18 @@ term, and the rest of the words are alternative terms.")
 
 (define-button-type 'apropos-plist
   'apropos-label "Plist"
+  'apropos-short-label "p"
   '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))))
 
+(define-button-type 'apropos-library
+  'help-echo "mouse-2, RET: Display more help on this library"
+  'follow-link t
+  'action (lambda (button)
+	    (apropos-library (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
@@ -404,6 +415,10 @@ This requires that at least 2 keywords (unless only one was given)."
 
 \\{apropos-mode-map}")
 
+(defvar apropos-multi-type t
+  "If non-nil, this apropos query concerns multiple types.
+This is used to decide whether to print the result's type or not.")
+
 ;;;###autoload
 (defun apropos-variable (pattern &optional do-all)
   "Show user variables that match PATTERN.
@@ -451,12 +466,15 @@ while a list of strings is used as a word list."
   (apropos-parse-pattern pattern)
   (let ((message
 	 (let ((standard-output (get-buffer-create "*Apropos*")))
-	   (print-help-return-message 'identity))))
+	   (help-print-return-message 'identity))))
     (or do-all (setq do-all apropos-do-all))
     (setq apropos-accumulator
 	  (apropos-internal apropos-regexp
 			    (or var-predicate
-				(if do-all 'functionp 'commandp))))
+                                ;; We used to use `functionp' here, but this
+                                ;; rules out macros.  `fboundp' rules in
+                                ;; keymaps, but it seems harmless.
+				(if do-all 'fboundp 'commandp))))
     (let ((tem apropos-accumulator))
       (while tem
 	(if (or (get (car tem) 'apropos-inhibit)
@@ -470,9 +488,13 @@ while a list of strings is used as a word list."
 		   (setq symbol (car p))
 		   (setq score (apropos-score-symbol symbol))
 		   (unless var-predicate
-		     (if (functionp symbol)
-			 (if (setq doc (documentation symbol t))
-			     (progn
+		     (if (fboundp symbol)
+			 (if (setq doc (condition-case nil
+                                           (documentation symbol t)
+                                         (error 'error)))
+                             ;; Eg alias to undefined function.
+                             (if (eq doc 'error)
+                                 "(documentation error)"
 			       (setq score (+ score (apropos-score-doc doc)))
 			       (substring doc 0 (string-match "\n" doc)))
 			   "(not documented)")))
@@ -486,7 +508,8 @@ while a list of strings is used as a word list."
 					  (string-match "\n" doc)))))))
 	(setcar (cdr (car p)) score)
 	(setq p (cdr p))))
-    (and (apropos-print t nil nil t)
+    (and (let ((apropos-multi-type do-all))
+           (apropos-print t nil nil t))
 	 message
 	 (message "%s" message))))
 
@@ -530,6 +553,67 @@ Returns list of symbols and documentation found."
 				(symbol-plist symbol)))))
    (or do-all apropos-do-all)))
 
+(defun apropos-library-button (sym)
+  (if (null sym)
+      "<nothing>"
+    (let ((name (copy-sequence (symbol-name sym))))
+      (make-text-button name nil
+                        'type 'apropos-library
+                        'face apropos-symbol-face
+                        'apropos-symbol name)
+      name)))
+
+;;;###autoload
+(defun apropos-library (file)
+  "List the variables and functions defined by library FILE.
+FILE should be one of the libraries currently loaded and should
+thus be found in `load-history'."
+  (interactive
+   (let* ((libs (delq nil (mapcar 'car load-history)))
+          (libs
+           (nconc (delq nil
+                        (mapcar
+                         (lambda (l)
+                           (setq l (file-name-nondirectory l))
+                           (while
+                               (not (equal (setq l (file-name-sans-extension l))
+                                           l)))
+                           l)
+                         libs))
+                  libs)))
+     (list (completing-read "Describe library: " libs nil t))))
+  (let ((symbols nil)
+	;; (autoloads nil)
+	(provides nil)
+	(requires nil)
+        (lh-entry (assoc file load-history)))
+    (unless lh-entry
+      ;; `file' may be the "shortname".
+      (let ((lh load-history)
+            (re (concat "\\(?:\\`\\|[\\/]\\)" (regexp-quote file)
+                        "\\(\\.\\|\\'\\)")))
+        (while (and lh (null lh-entry))
+          (if (and (caar lh) (string-match re (caar lh)))
+              (setq lh-entry (car lh))
+            (setq lh (cdr lh)))))
+      (unless lh-entry (error "Unknown library `%s'" file)))
+    (dolist (x (cdr lh-entry))
+      (case (car-safe x)
+	;; (autoload (push (cdr x) autoloads))
+	(require (push (cdr x) requires))
+	(provide (push (cdr x) provides))
+	(t (push (or (cdr-safe x) x) symbols))))
+    (let ((apropos-pattern "")) ;Dummy binding for apropos-symbols-internal.
+      (apropos-symbols-internal
+       symbols apropos-do-all
+       (concat
+        (format "Library `%s' provides: %s\nand requires: %s"
+                file
+                (mapconcat 'apropos-library-button
+                           (or provides '(nil)) " and ")
+                (mapconcat 'apropos-library-button
+                           (or requires '(nil)) " and ")))))))
+
 (defun apropos-symbols-internal (symbols keys &optional text)
   ;; Filter out entries that are marked as apropos-inhibit.
   (let ((all nil))
@@ -565,8 +649,19 @@ Returns list of symbols and documentation found."
 		   (apropos-documentation-property
 		    symbol 'widget-documentation t))
 	       (when (facep symbol)
-		 (apropos-documentation-property
-		  symbol 'face-documentation t))
+		 (let ((alias (get symbol 'face-alias)))
+		   (if alias
+		       (if (facep alias)
+			   (format "%slias for the face `%s'."
+				   (if (get symbol 'obsolete-face)
+				       "Obsolete a"
+				     "A")
+				   alias)
+			 ;; Never happens in practice because fails
+			 ;; (facep symbol) test.
+			 "(alias for undefined face)")
+		     (apropos-documentation-property
+		      symbol 'face-documentation t))))
 	       (when (get symbol 'custom-group)
 		   (apropos-documentation-property
 		    symbol 'group-documentation t)))))
@@ -616,7 +711,8 @@ Returns list of symbols and values found."
 						     (apropos-score-str p))
 						  f v p)
 					    apropos-accumulator))))))
-  (apropos-print nil "\n----------------\n"))
+   (let ((apropos-multi-type do-all))
+     (apropos-print nil "\n----------------\n")))
 
 
 ;;;###autoload
@@ -725,7 +821,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)
+  (let (type symbol (sepa 2) sepb doc)
     (insert ?\^_)
     (backward-char)
     (insert-file-contents (concat doc-directory internal-doc-file-name))
@@ -744,7 +840,14 @@ Returns list of symbols and documentation found."
 			 3)		; variable documentation
 		  symbol (read)
 		  doc (buffer-substring (1+ (point)) (1- sepb)))
-	    (when (apropos-true-hit-doc doc)
+	    (when (and (apropos-true-hit-doc doc)
+                       ;; The DOC file lists all built-in funcs and vars.
+                       ;; If any are not currently bound, they can
+                       ;; only be platform-specific stuff (eg NS) not
+                       ;; in use on the current platform.
+                       ;; So we exclude them.
+                       (cond ((= 3 type) (boundp symbol))
+                             ((= 2 type) (fboundp symbol))))
 	      (or (and (setq apropos-item (assq symbol apropos-accumulator))
 		       (setcar (cdr apropos-item)
 			       (apropos-score-doc doc)))
@@ -843,6 +946,9 @@ Will return nil instead."
       nil
     function))
 
+(defcustom apropos-compact-layout nil
+  "If non-nil, use a single line per binding."
+  :type 'boolean)
 
 (defun apropos-print (do-keys spacing &optional text nosubst)
   "Output result of apropos searching into buffer `*Apropos*'.
@@ -877,19 +983,16 @@ If non-nil TEXT is a string that will be printed as a heading."
 	    (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"))
+	     "or press return 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)
+	(dolist (apropos-item p)
 	  (when (and spacing (not (bobp)))
 	    (princ spacing))
-	  (setq apropos-item (car p)
-		symbol (car apropos-item)
-		p (cdr p))
+	  (setq symbol (car apropos-item))
 	  ;; Insert dummy score element for backwards compatibility with 21.x
 	  ;; apropos-item format.
 	  (if (not (numberp (cadr apropos-item)))
@@ -898,6 +1001,7 @@ If non-nil TEXT is a string that will be printed as a heading."
 			  (cons nil (cdr apropos-item)))))
 	  (insert-text-button (symbol-name symbol)
 			      'type 'apropos-symbol
+			      'skip apropos-multi-type
 			      ;; Can't use default, since user may have
 			      ;; changed the variable!
 			      ;; Just say `no' to variables containing faces!
@@ -906,50 +1010,52 @@ If non-nil TEXT is a string that will be printed as a heading."
 		   (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
-			    (set-buffer old-buffer)
-			    (where-is-internal symbol)))
-			 filtered)
-		     ;; Copy over the list of key sequences,
-		     ;; omitting any that contain a buffer or a frame.
-		     (while keys
-		       (let ((key (car keys))
-			     (i 0)
-			     loser)
-			 (while (< i (length key))
-			   (if (or (framep (aref key i))
-				   (bufferp (aref key i)))
-			       (setq loser t))
-			   (setq i (1+ i)))
-			 (or loser
-			     (setq filtered (cons key filtered))))
-		       (setq keys (cdr keys)))
-		     (setq item filtered))
-		   ;; Convert the remaining keys to a string and insert.
-		   (insert
-		    (mapconcat
-		     (lambda (key)
-		       (setq key (condition-case ()
-				     (key-description key)
-				   (error)))
-		       (if apropos-keybinding-face
-			   (put-text-property 0 (length key)
-					      'face apropos-keybinding-face
-					      key))
-		       key)
-		     item ", "))
-		 (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)
+          (unless apropos-compact-layout
+            (and do-keys
+                 (commandp symbol)
+                 (not (eq symbol 'self-insert-command))
+                 (indent-to 30 1)
+                 (if (let ((keys
+                            (with-current-buffer old-buffer
+                              (where-is-internal symbol)))
+                           filtered)
+                       ;; Copy over the list of key sequences,
+                       ;; omitting any that contain a buffer or a frame.
+                       ;; FIXME: Why omit keys that contain buffers and
+                       ;; frames?  This looks like a bad workaround rather
+                       ;; than a proper fix.  Does anybod know what problem
+                       ;; this is trying to address?  --Stef
+                       (dolist (key keys)
+                         (let ((i 0)
+                               loser)
+                           (while (< i (length key))
+                             (if (or (framep (aref key i))
+                                     (bufferp (aref key i)))
+                                 (setq loser t))
+                             (setq i (1+ i)))
+                           (or loser
+                               (push key filtered))))
+                       (setq item filtered))
+                     ;; Convert the remaining keys to a string and insert.
+                     (insert
+                      (mapconcat
+                       (lambda (key)
+                         (setq key (condition-case ()
+                                       (key-description key)
+                                     (error)))
+                         (if apropos-keybinding-face
+                             (put-text-property 0 (length key)
+                                                'face apropos-keybinding-face
+                                                key))
+                         key)
+                       item ", "))
+                   (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)
 				 'apropos-command
@@ -962,11 +1068,12 @@ If non-nil TEXT is a string that will be printed as a heading."
 	  (apropos-print-doc 6 'apropos-face t)
 	  (apropos-print-doc 5 'apropos-widget t)
 	  (apropos-print-doc 4 'apropos-plist nil))
+        (set (make-local-variable 'truncate-partial-width-windows) t)
+        (set (make-local-variable 'truncate-lines) t)
 	(setq buffer-read-only t))))
   (prog1 apropos-accumulator
     (setq apropos-accumulator ())))	; permit gc
 
-
 (defun apropos-macrop (symbol)
   "Return t if SYMBOL is a Lisp macro."
   (and (fboundp symbol)
@@ -979,20 +1086,30 @@ If non-nil TEXT is a string that will be printed as a heading."
 
 
 (defun apropos-print-doc (i type do-keys)
-  (if (stringp (setq i (nth i apropos-item)))
-      (progn
-	(insert "  ")
-	(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))
-	(insert ": ")
-	(insert (if do-keys (substitute-command-keys i) i))
-	(or (bolp) (terpri)))))
-
+  (when (stringp (setq i (nth i apropos-item)))
+    (if apropos-compact-layout
+        (insert (propertize "\t" 'display '(space :align-to 32)) " ")
+      (insert "  "))
+    (if (null apropos-multi-type)
+    	;; If the query is only for a single type, there's no point
+    	;; writing it over and over again.  Insert a blank button, and
+    	;; put the 'apropos-label property there (needed by
+    	;; apropos-symbol-button-display-help).
+    	(insert-text-button
+	 " " 'type type 'skip t
+	 'face 'default 'apropos-symbol (car apropos-item))
+      (insert-text-button
+       (if apropos-compact-layout
+           (format "<%s>" (button-type-get type 'apropos-short-label))
+         (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))
+      (insert (if apropos-compact-layout " " ": ")))
+    (insert (if do-keys (substitute-command-keys i) i))
+    (or (bolp) (terpri))))
 
 (defun apropos-follow ()
   "Invokes any button at point, otherwise invokes the nearest label button."
@@ -1004,7 +1121,8 @@ If non-nil TEXT is a string that will be printed as a heading."
 
 (defun apropos-describe-plist (symbol)
   "Display a pretty listing of SYMBOL's plist."
-  (help-setup-xref (list 'apropos-describe-plist symbol) (interactive-p))
+  (help-setup-xref (list 'apropos-describe-plist symbol)
+		   (called-interactively-p 'interactive))
   (with-help-window (help-buffer)
     (set-buffer standard-output)
     (princ "Symbol ")
@@ -1019,5 +1137,5 @@ If non-nil TEXT is a string that will be printed as a heading."
 
 (provide 'apropos)
 
-;;; arch-tag: d56fa2ac-e56b-4ce3-84ff-852f9c0dc66e
+;; arch-tag: d56fa2ac-e56b-4ce3-84ff-852f9c0dc66e
 ;;; apropos.el ends here