changeset 39649:7edeec63e660

(apropos-symbol, apropos-label): New button types. (apropos-symbol-button-display-help) (apropos-label-button-display-help, apropos-next-label-button): New functions. (apropos-mode-map): Make button-buffer-map our parent. Don't bind mouse events. (apropos-print, apropos-print-doc): Create buttons instead of text properties. (apropos-mouse-follow): Function removed. (apropos-follow): Use buttons.

--- a/lisp/apropos.el	Sun Oct 07 11:29:44 2001 +0000
+++ b/lisp/apropos.el	Sun Oct 07 11:35:09 2001 +0000
@@ -1,6 +1,6 @@
 ;;; apropos.el --- apropos commands for users and programmers
 
-;; Copyright (C) 1989, 1994, 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1989, 1994, 1995, 2001 Free Software Foundation, Inc.
 
 ;; Author: Joe Wells <[e-mail]>
 ;; Rewritten: Daniel Pfeiffer <[e-mail]>
@@ -103,12 +103,14 @@
 
 (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)
-    (define-key map [mouse-2] 'apropos-mouse-follow)
-    (define-key map [down-mouse-2] nil)
     map)
   "Keymap used in Apropos mode.")
 
@@ -126,6 +128,49 @@
 
 (defvar apropos-item ()
   "Current item in or for `apropos-accumulator'.")
+
+
+;;; 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."
+  'action #'apropos-symbol-button-display-help)
+
+(define-button-type 'apropos-label
+  'help-echo "mouse-2, RET: Display more help on this symbol."
+  'action #'apropos-label-button-display-help)
+
+(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)))))
+
+(defun apropos-label-button-display-help (button)
+  "Display further help for the `apropos-label' button BUTTON."
+  (funcall (button-get button 'apropos-action)
+	   (button-get button 'apropos-symbol)))
+
+(defun apropos-next-label-button (pos)
+  "Returns 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 1 nil t))
+	 (already-hit-symbol nil)
+	 (button-type (and button (button-get button 'type))))
+    (while (and button
+		(not (eq button-type 'apropos-label))
+		(or (not (eq button-type 'apropos-symbol))
+		    (not already-hit-symbol)))
+      (when (eq button-type 'apropos-symbol)
+	(setq already-hit-symbol t))
+      (setq button (next-button (button-start button)))
+      (when button
+	(setq button-type (button-get button 'type))))
+    (and (eq button-type 'apropos-label)
+	 button)))
+
 
 ;;;###autoload
 (define-derived-mode apropos-mode fundamental-mode "Apropos"
@@ -504,22 +549,16 @@
     (setq apropos-accumulator
 	  (sort apropos-accumulator (lambda (a b)
 				      (string-lessp (car a) (car b)))))
-    (setq apropos-label-properties
-	  (if (and apropos-label-face
-		   (symbolp apropos-label-face))
-	      `(face ,apropos-label-face
-		     mouse-face highlight
-		     help-echo "mouse-2: display help on this item")))
     (with-output-to-temp-buffer "*Apropos*"
       (let ((p apropos-accumulator)
 	    (old-buffer (current-buffer))
-	    symbol item point1 point2)
+	    symbol item)
 	(set-buffer standard-output)
 	(apropos-mode)
 	(if (display-mouse-p)
 	    (insert "If moving the mouse over text changes the text's color,\n"
 		    (substitute-command-keys
-		     "you can click \\[apropos-mouse-follow] on that text to get more information.\n")))
+		     "you can click \\[push-button] 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
@@ -528,10 +567,13 @@
 	  (or (not spacing) (bobp) (terpri))
 	  (setq apropos-item (car p)
 		symbol (car apropos-item)
-		p (cdr p)
-		point1 (point))
-	  (princ symbol)		        ; print symbol name
-	  (setq point2 (point))
+		p (cdr p))
+	  (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)
 	  ;; Calculate key-bindings if we want them.
 	  (and do-keys
 	       (commandp symbol)
@@ -577,13 +619,6 @@
 		 (put-text-property (- (point) 3) (point)
 				    'face apropos-keybinding-face)))
 	  (terpri)
-	  ;; only now so we don't propagate text attributes all over
-	  (put-text-property point1 point2 'item
-			     (if (eval `(or ,@(cdr apropos-item)))
-				 (car apropos-item)
-			       apropos-item))
-	  (if apropos-symbol-face
-	      (put-text-property point1 point2 'face apropos-symbol-face))
 	  (apropos-print-doc 'describe-function 1
 			     (if (commandp symbol)
 				 "Command"
@@ -623,51 +658,26 @@
   (if (stringp (setq i (nth i apropos-item)))
       (progn
 	(insert "  ")
-	(put-text-property (- (point) 2) (1- (point))
-			   'action action)
-	(insert str ": ")
-	(if apropos-label-properties
-	    (add-text-properties (- (point) (length str) 2)
-				 (1- (point))
-				 apropos-label-properties))
+	(insert-text-button str
+			    'type 'apropos-label
+			    ;; 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)
+			    'apropos-action action
+			    str)
+	(insert ": ")
 	(insert (if do-keys (substitute-command-keys i) i))
 	(or (bolp) (terpri)))))
 
 
-(defun apropos-mouse-follow (event)
-  (interactive "e")
-  (let ((other (if (eq (current-buffer) (get-buffer "*Apropos*"))
-		   ()
-		 (current-buffer))))
-    (save-excursion
-      (set-buffer (window-buffer (posn-window (event-start event))))
-      (goto-char (posn-point (event-start event)))
-      (or (and (not (eobp)) (get-text-property (point) 'mouse-face))
-	  (and (not (bobp)) (get-text-property (1- (point)) 'mouse-face))
-	  (error "There is nothing to follow here"))
-      (apropos-follow other))))
-
-
-(defun apropos-follow (&optional other)
+(defun apropos-follow ()
+  "Invokes any button at point, otherwise invokes the nearest label button."
   (interactive)
-  (let* (;; Properties are always found at the beginning of the line.
-	 (bol (save-excursion (beginning-of-line) (point)))
-	 ;; If there is no `item' property here, look behind us.
-	 (item (get-text-property bol 'item))
-	 (item-at (if item nil (previous-single-property-change bol 'item)))
-	 ;; Likewise, if there is no `action' property here, look in front.
-	 (action (get-text-property bol 'action))
-	 (action-at (if action nil (next-single-property-change bol 'action))))
-    (and (null item) item-at
-	 (setq item (get-text-property (1- item-at) 'item)))
-    (and (null action) action-at
-	 (setq action (get-text-property action-at 'action)))
-    (if (not (and item action))
-	(error "There is nothing to follow here"))
-    (if (consp item) (error "There is nothing to follow in `%s'" (car item)))
-    (if other (set-buffer other))
-    (funcall action item)))
-
+  (button-activate
+   (or (apropos-next-label-button (line-beginning-position))
+       (error "There is nothing to follow here"))))
 
 
 (defun apropos-describe-plist (symbol)
@@ -683,6 +693,7 @@
     (princ ")")
     (print-help-return-message)))
 
+
 (provide 'apropos)
 
 ;;; apropos.el ends here