--- a/lisp/custom/wid-edit.el	Mon Aug 13 08:51:58 2007 +0200
+++ b/lisp/custom/wid-edit.el	Mon Aug 13 08:52:29 2007 +0200
@@ -4,7 +4,7 @@
 ;;
 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
 ;; Keywords: extensions
-;; Version: 1.50
+;; Version: 1.59
 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
 
 ;;; Commentary:
@@ -14,32 +14,37 @@
 ;;; Code:
 
 (require 'widget)
-(require 'cl)
-(autoload 'pp-to-string "pp")
-(autoload 'Info-goto-node "info")
+
+(eval-and-compile
+  (require 'cl))
+
+;;; Compatibility.
 
-(if (string-match "XEmacs" emacs-version)
-    ;; XEmacs spell `intangible' as `atomic'.
-    (defun widget-make-intangible (from to side)
-      "Make text between FROM and TO atomic with regard to movement.
+(eval-and-compile
+  (autoload 'pp-to-string "pp")
+  (autoload 'Info-goto-node "info")
+
+  (if (string-match "XEmacs" emacs-version)
+      ;; XEmacs spell `intangible' as `atomic'.
+      (defun widget-make-intangible (from to side)
+	"Make text between FROM and TO atomic with regard to movement.
 Third argument should be `start-open' if it should be sticky to the rear,
 and `end-open' if it should sticky to the front."
-      (require 'atomic-extents)
-      (let ((ext (make-extent from to)))
-	 ;; XEmacs doesn't understant different kinds of read-only, so
-	 ;; we have to use extents instead.  
-	(put-text-property from to 'read-only nil)
-	(set-extent-property ext 'read-only t)
-	(set-extent-property ext 'start-open nil)
-	(set-extent-property ext 'end-open nil)
-	(set-extent-property ext side t)
-	(set-extent-property ext 'atomic t)))
-  (defun widget-make-intangible (from to size)
-    "Make text between FROM and TO intangible."
-    (put-text-property from to 'intangible 'front)))
+	(require 'atomic-extents)
+	(let ((ext (make-extent from to)))
+	   ;; XEmacs doesn't understant different kinds of read-only, so
+	   ;; we have to use extents instead.  
+	  (put-text-property from to 'read-only nil)
+	  (set-extent-property ext 'read-only t)
+	  (set-extent-property ext 'start-open nil)
+	  (set-extent-property ext 'end-open nil)
+	  (set-extent-property ext side t)
+	  (set-extent-property ext 'atomic t)))
+    (defun widget-make-intangible (from to size)
+      "Make text between FROM and TO intangible."
+      (put-text-property from to 'intangible 'front)))
 	  
 ;; The following should go away when bundled with Emacs.
-(eval-and-compile
   (condition-case ()
       (require 'custom)
     (error nil))
@@ -54,27 +59,25 @@
     (when (fboundp 'copy-face)
       (copy-face 'default 'widget-documentation-face)
       (copy-face 'bold 'widget-button-face)
-      (copy-face 'italic 'widget-field-face))))
-
-;;; Compatibility.
+      (copy-face 'italic 'widget-field-face)))
 
-(unless (fboundp 'event-point)
-  ;; XEmacs function missing in Emacs.
-  (defun event-point (event)
-    "Return the character position of the given mouse-motion, button-press,
+  (unless (fboundp 'event-point)
+    ;; XEmacs function missing in Emacs.
+    (defun event-point (event)
+      "Return the character position of the given mouse-motion, button-press,
 or button-release event.  If the event did not occur over a window, or did
 not occur over text, then this returns nil.  Otherwise, it returns an index
 into the buffer visible in the event's window."
-    (posn-point (event-start event))))
+      (posn-point (event-start event))))
 
-(unless (fboundp 'error-message-string)
-  ;; Emacs function missing in XEmacs.
-  (defun error-message-string (obj)
-    "Convert an error value to an error message."
-    (let ((buf (get-buffer-create " *error-message*")))
-      (erase-buffer buf)
-      (display-error obj buf)
-      (buffer-string buf))))
+  (unless (fboundp 'error-message-string)
+    ;; Emacs function missing in XEmacs.
+    (defun error-message-string (obj)
+      "Convert an error value to an error message."
+      (let ((buf (get-buffer-create " *error-message*")))
+	(erase-buffer buf)
+	(display-error obj buf)
+	(buffer-string buf)))))
 
 ;;; Customization.
 
@@ -188,9 +191,13 @@
 			  (car (event-object val))))
 	   (cdr (assoc val items))))
 	(t
-	 (cdr (assoc (completing-read (concat title ": ")
-				      items nil t)
-		     items)))))
+	 (let ((val (completing-read (concat title ": ") items nil t)))
+	   (if (stringp val)
+	       (let ((try (try-completion val items)))
+		 (when (stringp try)
+		   (setq val try))
+		 (cdr (assoc val items)))
+	     nil)))))
 
 (defun widget-get-sibling (widget)
   "Get the item WIDGET is assumed to toggle.
@@ -228,8 +235,8 @@
 
   ;; Make it possible to edit the front end of the field.
   (add-text-properties (1- from) from (list 'rear-nonsticky t
-					    'end-open t
-					    'invisible t))
+					      'end-open t
+					      'invisible t))
   (when (or (string-match "\\(.\\|\n\\)%v" (widget-get widget :format))
 	    (widget-get widget :hide-front-space))
     ;; WARNING: This is going to lose horrible if the character just
@@ -270,7 +277,13 @@
 	(secret-to to)
 	(size (widget-get widget :size))
 	(face (or (widget-get widget :value-face)
-		  'widget-field-face)))
+		  'widget-field-face))
+	(help-echo (widget-get widget :help-echo))
+	(help-property (if (featurep 'balloon-help)
+			   'balloon-help
+			 'help-echo)))
+    (unless (or (stringp help-echo) (null help-echo))
+      (setq help-echo 'widget-mouse-help))
 
     (when secret 
       (while (and size
@@ -291,8 +304,9 @@
 				       'read-only nil
 				       'keymap map
 				       'local-map map
+				       help-property help-echo
 				       'face face))
-
+    
     (when secret 
       (save-excursion
 	(goto-char from)
@@ -304,19 +318,39 @@
 
     (unless (widget-get widget :size)
       (add-text-properties to (1+ to) (list 'field widget
+					    help-property help-echo
 					    'face face)))
     (add-text-properties to (1+ to) (list 'local-map map
 					  'keymap map))))
 
 (defun widget-specify-button (widget from to)
   ;; Specify button for WIDGET between FROM and TO.
-  (let ((face (widget-apply widget :button-face-get)))
+  (let ((face (widget-apply widget :button-face-get))
+	(help-echo (widget-get widget :help-echo))
+	(help-property (if (featurep 'balloon-help)
+			   'balloon-help
+			 'help-echo)))
+    (unless (or (null help-echo) (stringp help-echo))
+      (setq help-echo 'widget-mouse-help))
     (add-text-properties from to (list 'button widget
 				       'mouse-face widget-mouse-face
 				       'start-open t
 				       'end-open t
+				       help-property help-echo
 				       'face face))))
 
+(defun widget-mouse-help (extent)
+  "Find mouse help string for button in extent."
+  (let* ((widget (widget-at (extent-start-position extent)))
+	 (help-echo (and widget (widget-get widget :help-echo))))
+    (cond ((stringp help-echo)
+	   help-echo)
+	  ((and (symbolp help-echo) (fboundp help-echo)
+		(stringp (setq help-echo (funcall help-echo widget))))
+	   help-echo)
+	  (t
+	   (format "(widget %S :help-echo %S)" widget help-echo)))))
+
 (defun widget-specify-sample (widget from to)
   ;; Specify sample for WIDGET between FROM and TO.
   (let ((face (widget-apply widget :sample-face-get)))
@@ -383,7 +417,7 @@
 
 (defun widget-apply (widget property &rest args)
   "Apply the value of WIDGET's PROPERTY to the widget itself.
-ARGS are passed as extra argments to the function."
+ARGS are passed as extra arguments to the function."
   (apply (widget-get widget property) widget args))
 
 (defun widget-value (widget)
@@ -422,24 +456,34 @@
 
 (defun widget-glyph-insert (widget tag image)
   "In WIDGET, insert the text TAG or, if supported, IMAGE.
-IMAGE should be a name sans extension of an xpm or xbm file located in 
-`widget-glyph-directory'"
-  (if (and (string-match "XEmacs" emacs-version)
-	   widget-glyph-enable
-	   (fboundp 'make-glyph)
-	   image)
-      (let ((file (concat widget-glyph-directory 
-			(if (string-match "/\\'" widget-glyph-directory)
-			    ""
-			  "/")
-			image
-			(if (featurep 'xpm) ".xpm" ".xbm"))))
-	(if (file-readable-p file)
-	    (widget-glyph-insert-glyph widget tag (make-glyph file))
-	  ;; File not readable, give up.
-	  (insert tag)))
-    ;; We don't want or can't use glyphs.
-    (insert tag)))
+IMAGE should either be a glyph, or a name sans extension of an xpm or
+xbm file located in `widget-glyph-directory'.
+
+WARNING: If you call this with a glyph, and you want theuser to be
+able to activate the glyph, make sure it is unique.  If you use the
+same glyph for multiple widgets, "
+  (cond ((not (and (string-match "XEmacs" emacs-version)
+		   widget-glyph-enable
+		   (fboundp 'make-glyph)
+		   image))
+	 ;; We don't want or can't use glyphs.
+	 (insert tag))
+	((and (fboundp 'glyphp)
+	      (glyphp image))
+	 ;; Already a glyph.  Insert it.
+	 (widget-glyph-insert-glyph widget tag image))
+	(t
+	 ;; A string.  Look it up in.
+	 (let ((file (concat widget-glyph-directory 
+			    (if (string-match "/\\'" widget-glyph-directory)
+				""
+			      "/")
+			    image
+			    (if (featurep 'xpm) ".xpm" ".xbm"))))
+	   (if (file-readable-p file)
+	       (widget-glyph-insert-glyph widget tag (make-glyph file))
+	     ;; File not readable, give up.
+	     (insert tag))))))
 
 (defun widget-glyph-insert-glyph (widget tag glyph)
   "In WIDGET, with alternative text TAG, insert GLYPH."
@@ -448,7 +492,16 @@
   (insert "*")
   (add-text-properties (1- (point)) (point) 
 		       (list 'invisible t
-			     'end-glyph glyph)))
+			     'end-glyph glyph))
+  (let ((help-echo (widget-get widget :help-echo)))
+    (when help-echo
+      (let ((extent (extent-at (1- (point)) nil 'end-glyph))
+	    (help-property (if (featurep 'balloon-help)
+			       'balloon-help
+			     'help-echo)))
+	(set-extent-property extent help-property (if (stringp help-echo)
+						      help-echo
+						    'widget-mouse-help))))))
 
 ;;; Creating Widgets.
 
@@ -553,7 +606,7 @@
     (apply 'insert args)
     (widget-specify-text from (point))))
 
-;;; Keymap and Comands.
+;;; Keymap and Commands.
 
 (defvar widget-keymap nil
   "Keymap containing useful binding for buffers containing widgets.
@@ -1141,7 +1194,7 @@
 
 (define-widget 'link 'item
   "An embedded link."
-  :help-echo "Push me to follow the link."
+  :help-echo "Follow the link."
   :format "%[_%t_%]")
 
 ;;; The `info-link' Widget.
@@ -1468,6 +1521,8 @@
   (widget-specify-insert 
    (let* ((children (widget-get widget :children))
 	  (buttons (widget-get widget :buttons))
+	  (button-args (or (widget-get type :sibling-args)
+			   (widget-get widget :button-args)))
 	  (from (point))
 	  child button)
      (insert (widget-get widget :entry-format))
@@ -1479,8 +1534,10 @@
 	 (cond ((eq escape ?%)
 		(insert "%"))
 	       ((eq escape ?b)
-		(setq button (widget-create-child-and-convert
-			      widget 'checkbox :value (not (null chosen)))))
+		(setq button (apply 'widget-create-child-and-convert
+				    widget 'checkbox
+				    :value (not (null chosen))
+				    button-args)))
 	       ((eq escape ?v)
 		(setq child
 		      (cond ((not chosen)
@@ -1647,6 +1704,8 @@
    (let* ((value (widget-get widget :value))
 	  (children (widget-get widget :children))
 	  (buttons (widget-get widget :buttons))
+	  (button-args (or (widget-get type :sibling-args)
+			   (widget-get widget :button-args)))
 	  (from (point))
 	  (chosen (and (null (widget-get widget :choice))
 		       (widget-apply type :match value)))
@@ -1660,9 +1719,10 @@
 	 (cond ((eq escape ?%)
 		(insert "%"))
 	       ((eq escape ?b)
-		(setq button (widget-create-child-and-convert
-			      widget 'radio-button 
-			      :value (not (null chosen)))))
+		(setq button (apply 'widget-create-child-and-convert
+				    widget 'radio-button 
+				    :value (not (null chosen))
+				    button-args)))
 	       ((eq escape ?v)
 		(setq child (if chosen
 				(widget-create-child-value
@@ -1765,6 +1825,7 @@
 (define-widget 'insert-button 'push-button
   "An insert button for the `editable-list' widget."
   :tag "INS"
+  :help-echo "Insert a new item into the list at this position."
   :action 'widget-insert-button-action)
 
 (defun widget-insert-button-action (widget &optional event)
@@ -1777,6 +1838,7 @@
 (define-widget 'delete-button 'push-button
   "A delete button for the `editable-list' widget."
   :tag "DEL"
+  :help-echo "Delete this item from the list."
   :action 'widget-delete-button-action)
 
 (defun widget-delete-button-action (widget &optional event)
@@ -1814,7 +1876,9 @@
     (cond ((eq escape ?i)
 	   (and (widget-get widget :indent)
 		(insert-char ?  (widget-get widget :indent)))
-	   (widget-create-child-and-convert widget 'insert-button))
+	   (apply 'widget-create-child-and-convert 
+		  widget 'insert-button
+		  (widget-get widget :append-button-args)))
 	  (t 
 	   (widget-default-format-handler widget escape)))))
 
@@ -1940,11 +2004,13 @@
 	 (cond ((eq escape ?%)
 		(insert "%"))
 	       ((eq escape ?i)
-		(setq insert (widget-create-child-and-convert
-			      widget 'insert-button)))
+		(setq insert (apply 'widget-create-child-and-convert
+				    widget 'insert-button
+				    (widget-get widget :insert-button-args))))
 	       ((eq escape ?d)
-		(setq delete (widget-create-child-and-convert
-			      widget 'delete-button)))
+		(setq delete (apply 'widget-create-child-and-convert
+				    widget 'delete-button
+				    (widget-get widget :delete-button-args))))
 	       ((eq escape ?v)
 		(if conv
 		    (setq child (widget-create-child-value 
@@ -2030,7 +2096,7 @@
 (define-widget 'widget-help 'push-button
   "The widget documentation button."
   :format "%[[%t]%] %d"
-  :help-echo "Push me to toggle the documentation."
+  :help-echo "Toggle display of documentation."
   :action 'widget-help-action)
 
 (defun widget-help-action (widget &optional event)
@@ -2261,7 +2327,7 @@
 
 (define-widget 'color-item 'choice-item
   "A color name (with sample)."
-  :format "%v (%[sample%])\n"
+  :format "%v (%{sample%})\n"
   :button-face-get 'widget-color-item-button-face-get)
 
 (defun widget-color-item-button-face-get (widget)