Initial revision

[gnu-emacs] / lisp / wid-edit.el

diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el
index c84a6894bb96fa87b46231c7d55e8798a52f34e2..583ab54fbc2008dd92989d12cc30689fa0d348e3 100644 (file)
--- a/lisp/wid-edit.el
+++ b/lisp/wid-edit.el
@@ -4,7 +4,7 @@
 ;;
 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
 ;; Keywords: extensions
 ;;
 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
 ;; Keywords: extensions

-;; Version: 1.9944
+;; Version: 1.9951

 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
 
 ;; This file is part of GNU Emacs.
 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
 
 ;; This file is part of GNU Emacs.


@@ -34,34 +34,17 @@
 (eval-when-compile (require 'cl))
 
 ;;; Compatibility.
 (eval-when-compile (require 'cl))
 
 ;;; Compatibility.

+  
+(defun widget-event-point (event)
+  "Character position of the end of event if that exists, or nil."
+  (posn-point (event-end event)))
+
+(defalias 'widget-read-event 'read-event)

 
 (eval-and-compile
   (autoload 'pp-to-string "pp")
   (autoload 'Info-goto-node "info")
 
 (eval-and-compile
   (autoload 'pp-to-string "pp")
   (autoload 'Info-goto-node "info")

-
-  (when (string-match "XEmacs" emacs-version)
-    (condition-case nil
-       (require 'overlay)
-      (error (load-library "x-overlay"))))
-  
-  (if (string-match "XEmacs" emacs-version)
-      (defun widget-event-point (event)
-       "Character position of the end of event if that exists, or nil."
-       (if (mouse-event-p event)
-           (event-point event)
-         nil))
-    (defun widget-event-point (event)
-      "Character position of the end of event if that exists, or nil."
-      (posn-point (event-end event))))
-
-  (defalias 'widget-read-event (if (string-match "XEmacs" emacs-version)
-                                  'next-event
-                                'read-event))
-
-  ;; The following should go away when bundled with Emacs.
-  (condition-case ()
-      (require 'custom)
-    (error nil))
+  (autoload 'finder-commentary "finder" nil t)

 
   (unless (and (featurep 'custom) (fboundp 'custom-declare-variable))
     ;; We have the old custom-library, hack around it!
 
   (unless (and (featurep 'custom) (fboundp 'custom-declare-variable))
     ;; We have the old custom-library, hack around it!


@@ -82,45 +65,7 @@
       (and (eventp event)
           (memq (event-basic-type event) '(mouse-1 mouse-2 mouse-3))
           (or (memq 'click (event-modifiers event))
       (and (eventp event)
           (memq (event-basic-type event) '(mouse-1 mouse-2 mouse-3))
           (or (memq 'click (event-modifiers event))

-              (memq  'drag (event-modifiers event))))))
-
-  (unless (fboundp 'functionp)
-    ;; Missing from Emacs 19.34 and earlier.
-    (defun functionp (object)
-      "Non-nil of OBJECT is a type of object that can be called as a function."
-      (or (subrp object) (byte-code-function-p object)
-         (eq (car-safe object) 'lambda)
-         (and (symbolp object) (fboundp object)))))
-
-  (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)))))
-
-(when (let ((a "foo"))
-       (put-text-property 1 2 'foo 1 a)
-       (put-text-property 1 2 'bar 2 a)
-       (set-text-properties 1 2 nil a)
-       (text-properties-at 1 a))
-  ;; XEmacs 20.2 and earlier had a buggy set-text-properties.
-  (defun set-text-properties (start end props &optional buffer-or-string)
-    "Completely replace properties of text from START to END.
-The third argument PROPS is the new property list.
-The optional fourth argument, BUFFER-OR-STRING,
-is the string or buffer containing the text."
-    (map-extents #'(lambda (extent ignored)
-                    (remove-text-properties
-                     start end
-                     (list (extent-property extent 'text-prop)
-                           nil)
-                     buffer-or-string)
-                    nil)
-                buffer-or-string start end nil nil 'text-prop)
-    (add-text-properties start end props buffer-or-string)))
+              (memq  'drag (event-modifiers event)))))))

 
 ;;; Customization.
 
 
 ;;; Customization.
 


@@ -193,32 +138,22 @@ This exists as a variable so it can be set locally in certain buffers.")
   "Face used for editable fields spanning only a single line."
   :group 'widget-faces)
 
   "Face used for editable fields spanning only a single line."
   :group 'widget-faces)
 

-(defvar widget-single-line-display-table
-  (let ((table (make-display-table)))
-    (aset table 9  "^I")
-    (aset table 10 "^J")
-    table)
-  "Display table used for single-line editable fields.")
+;;; This causes display-table to be loaded, and not usefully.
+;;;(defvar widget-single-line-display-table
+;;;  (let ((table (make-display-table)))
+;;;    (aset table 9  "^I")
+;;;    (aset table 10 "^J")
+;;;    table)
+;;;  "Display table used for single-line editable fields.")

 
 

-(when (fboundp 'set-face-display-table)
-  (set-face-display-table 'widget-single-line-field-face
-                         widget-single-line-display-table))
+;;;(when (fboundp 'set-face-display-table)
+;;;  (set-face-display-table 'widget-single-line-field-face
+;;;                      widget-single-line-display-table))

 
 ;;; Utility functions.
 ;;
 ;; These are not really widget specific.
 
 
 ;;; Utility functions.
 ;;
 ;; These are not really widget specific.
 

-(defsubst widget-plist-member (plist prop)
-  ;; Return non-nil if PLIST has the property PROP.
-  ;; PLIST is a property list, which is a list of the form
-  ;; (PROP1 VALUE1 PROP2 VALUE2 ...).  PROP is a symbol.
-  ;; Unlike `plist-get', this allows you to distinguish between a missing
-  ;; property and a property with the value nil.
-  ;; The value is actually the tail of PLIST whose car is PROP.
-  (while (and plist (not (eq (car plist) prop)))
-    (setq plist (cdr (cdr plist))))
-  plist)
-

 (defun widget-princ-to-string (object)
   ;; Return string representation of OBJECT, any Lisp object.
   ;; No quoting characters are used; no delimiters are printed around
 (defun widget-princ-to-string (object)
   ;; Return string representation of OBJECT, any Lisp object.
   ;; No quoting characters are used; no delimiters are printed around


@@ -267,23 +202,6 @@ minibuffer."
         ;; We are in Emacs-19, pressed by the mouse
         (x-popup-menu event
                       (list title (cons "" items))))
         ;; We are in Emacs-19, pressed by the mouse
         (x-popup-menu event
                       (list title (cons "" items))))

-       ((and (< (length items) widget-menu-max-size)
-             event (fboundp 'popup-menu) window-system)
-        ;; We are in XEmacs, pressed by the mouse
-        (let ((val (get-popup-menu-response
-                    (cons title
-                          (mapcar
-                           (function
-                            (lambda (x)
-                              (if (stringp x)
-                                  (vector x nil nil) 
-                                (vector (car x) (list (car x)) t))))
-                           items)))))
-          (setq val (and val
-                         (listp (event-object val))
-                         (stringp (car-safe (event-object val)))
-                         (car (event-object val))))
-          (cdr (assoc val items))))

        (widget-menu-minibuffer-flag
         ;; Read the choice of name from the minibuffer.
         (setq items (widget-remove-if 'stringp items))
        (widget-menu-minibuffer-flag
         ;; Read the choice of name from the minibuffer.
         (setq items (widget-remove-if 'stringp items))


@@ -300,6 +218,7 @@ minibuffer."
         (let* ((overriding-terminal-local-map
                 (make-sparse-keymap))
                map choice (next-digit ?0)
         (let* ((overriding-terminal-local-map
                 (make-sparse-keymap))
                map choice (next-digit ?0)

+               some-choice-enabled

                value)
           ;; Define SPC as a prefix char to get to this menu.
           (define-key overriding-terminal-local-map " "
                value)
           ;; Define SPC as a prefix char to get to this menu.
           (define-key overriding-terminal-local-map " "


@@ -314,24 +233,45 @@ minibuffer."
                   (let* ((name (car choice))
                         (function (cdr choice)))
                     (insert (format "%c = %s\n" next-digit name))
                   (let* ((name (car choice))
                         (function (cdr choice)))
                     (insert (format "%c = %s\n" next-digit name))

-                    (define-key map (vector next-digit) function)))
+                    (define-key map (vector next-digit) function)
+                    (setq some-choice-enabled t)))

               ;; Allocate digits to disabled alternatives
               ;; so that the digit of a given alternative never varies.
               (setq next-digit (1+ next-digit)))
             (insert "\nC-g = Quit"))
               ;; Allocate digits to disabled alternatives
               ;; so that the digit of a given alternative never varies.
               (setq next-digit (1+ next-digit)))
             (insert "\nC-g = Quit"))

+          (or some-choice-enabled
+              (error "None of the choices is currently meaningful"))

           (define-key map [?\C-g] 'keyboard-quit)
           (define-key map [t] 'keyboard-quit)
           (define-key map [?\C-g] 'keyboard-quit)
           (define-key map [t] 'keyboard-quit)

+          (define-key map [?\M-\C-v] 'scroll-other-window)
+          (define-key map [?\M--] 'negative-argument)

           (setcdr map (nreverse (cdr map)))
           (setcdr map (nreverse (cdr map)))

-          ;; Unread a SPC to lead to our new menu.
-          (setq unread-command-events (cons ?\ unread-command-events))

           ;; Read a char with the menu, and return the result
           ;; that corresponds to it.
           (save-window-excursion
           ;; Read a char with the menu, and return the result
           ;; that corresponds to it.
           (save-window-excursion

-            (display-buffer (get-buffer " widget-choose"))
-            (let ((cursor-in-echo-area t))
-              (setq value
-                    (lookup-key overriding-terminal-local-map
-                                (read-key-sequence title) t))))
+            (let ((buf (get-buffer " widget-choose")))
+              (display-buffer buf)
+              (let ((cursor-in-echo-area t)
+                    keys
+                    (char 0)
+                    (arg 1))
+                (while (not (or (and (>= char ?0) (< char next-digit))
+                                (eq value 'keyboard-quit)))
+                  ;; Unread a SPC to lead to our new menu.
+                  (setq unread-command-events (cons ?\ unread-command-events))
+                  (setq keys (read-key-sequence title))
+                  (setq value (lookup-key overriding-terminal-local-map keys t)
+                        char (string-to-char (substring keys 1)))
+                  (cond ((eq value 'scroll-other-window)
+                         (let ((minibuffer-scroll-window (get-buffer-window buf)))
+                           (if (> 0 arg)
+                               (scroll-other-window-down (window-height minibuffer-scroll-window))
+                             (scroll-other-window))
+                           (setq arg 1)))
+                        ((eq value 'negative-argument)
+                         (setq arg -1))
+                        (t
+                         (setq arg 1)))))))

           (when (eq value 'keyboard-quit)
             (error "Canceled"))
           value))))
           (when (eq value 'keyboard-quit)
             (error "Canceled"))
           value))))


@@ -348,18 +288,6 @@ minibuffer."
 ;; 
 ;; These functions are for specifying text properties. 
 
 ;; 
 ;; These functions are for specifying text properties. 
 

-(defun widget-specify-none (from to)
-  ;; Clear all text properties between FROM and TO.
-  (set-text-properties from to nil))
-
-(defun widget-specify-text (from to)
-  ;; Default properties.
-  (add-text-properties from to (list 'read-only t
-                                    'front-sticky t
-                                    'rear-nonsticky nil
-                                    'start-open nil
-                                    'end-open nil)))
-

 (defcustom widget-field-add-space 
   (or (< emacs-major-version 20)
       (and (eq emacs-major-version 20)
 (defcustom widget-field-add-space 
   (or (< emacs-major-version 20)
       (and (eq emacs-major-version 20)


@@ -374,11 +302,11 @@ size field."
   :group 'widgets)
 
 (defcustom widget-field-use-before-change
   :group 'widgets)
 
 (defcustom widget-field-use-before-change

-  (or (> emacs-minor-version 34)
-      (> emacs-major-version 20)
-      (string-match "XEmacs" emacs-version))
+  (and (or (> emacs-minor-version 34)
+          (> emacs-major-version 19))
+       (not (string-match "XEmacs" emacs-version)))

   "Non-nil means use `before-change-functions' to track editable fields.
   "Non-nil means use `before-change-functions' to track editable fields.

-This enables the use of undo, but doesn'f work on Emacs 19.34 and earlier. 
+This enables the use of undo, but doesn't work on Emacs 19.34 and earlier. 

 Using before hooks also means that the :notify function can't know the
 new value."
   :type 'boolean
 Using before hooks also means that the :notify function can't know the
 new value."
   :type 'boolean


@@ -386,7 +314,6 @@ new value."
 
 (defun widget-specify-field (widget from to)
   "Specify editable button for WIDGET between FROM and TO."
 
 (defun widget-specify-field (widget from to)
   "Specify editable button for WIDGET between FROM and TO."

-  (put-text-property from to 'read-only nil)

   ;; Terminating space is not part of the field, but necessary in
   ;; order for local-map to work.  Remove next sexp if local-map works
   ;; at the end of the overlay.
   ;; Terminating space is not part of the field, but necessary in
   ;; order for local-map to work.  Remove next sexp if local-map works
   ;; at the end of the overlay.


@@ -397,14 +324,6 @@ new value."
          (widget-field-add-space
           (insert-and-inherit " ")))
     (setq to (point)))
          (widget-field-add-space
           (insert-and-inherit " ")))
     (setq to (point)))

-  (if (or widget-field-add-space
-         (null (widget-get widget :size)))
-      (add-text-properties (1- to) to
-                          '(front-sticky nil start-open t read-only to))
-    (add-text-properties to (1+ to) 
-                        '(front-sticky nil start-open t read-only to)))
-  (add-text-properties (1- from) from 
-                      '(rear-nonsticky t end-open t read-only from))

   (let ((map (widget-get widget :keymap))
        (face (or (widget-get widget :value-face) 'widget-field-face))
        (help-echo (widget-get widget :help-echo))
   (let ((map (widget-get widget :keymap))
        (face (or (widget-get widget :value-face) 'widget-field-face))
        (help-echo (widget-get widget :help-echo))


@@ -420,7 +339,26 @@ new value."
     (overlay-put overlay 'keymap map)
     (overlay-put overlay 'face face)
     (overlay-put overlay 'balloon-help help-echo)
     (overlay-put overlay 'keymap map)
     (overlay-put overlay 'face face)
     (overlay-put overlay 'balloon-help help-echo)

-    (overlay-put overlay 'help-echo help-echo)))
+    (overlay-put overlay 'help-echo help-echo))
+  (widget-specify-secret widget))
+
+(defun widget-specify-secret (field)
+  "Replace text in FIELD with value of `:secret', if non-nil."
+  (let ((secret (widget-get field :secret))
+       (size (widget-get field :size)))
+    (when secret
+      (let ((begin (widget-field-start field))
+           (end (widget-field-end field)))
+       (when size 
+         (while (and (> end begin)
+                     (eq (char-after (1- end)) ?\ ))
+           (setq end (1- end))))
+       (while (< begin end)
+         (let ((old (char-after begin)))
+           (unless (eq old secret)
+             (subst-char-in-region begin (1+ begin) old secret)
+             (put-text-property begin (1+ begin) 'secret old))
+           (setq begin (1+ begin))))))))

 
 (defun widget-specify-button (widget from to)
   "Specify button for WIDGET between FROM and TO."
 
 (defun widget-specify-button (widget from to)
   "Specify button for WIDGET between FROM and TO."


@@ -450,15 +388,17 @@ new value."
 
 (defun widget-specify-sample (widget from to)
   ;; Specify sample for WIDGET between FROM and TO.
 
 (defun widget-specify-sample (widget from to)
   ;; Specify sample for WIDGET between FROM and TO.

-  (let ((face (widget-apply widget :sample-face-get)))
-    (when face
-      (add-text-properties from to (list 'start-open t
-                                        'end-open t
-                                        'face face)))))
+  (let ((face (widget-apply widget :sample-face-get))
+       (overlay (make-overlay from to nil t nil)))
+    (overlay-put overlay 'face face)
+    (widget-put widget :sample-overlay overlay)))
+

 (defun widget-specify-doc (widget from to)
   ;; Specify documentation for WIDGET between FROM and TO.
 (defun widget-specify-doc (widget from to)
   ;; Specify documentation for WIDGET between FROM and TO.

-  (add-text-properties from to (list 'widget-doc widget
-                                    'face widget-documentation-face)))
+  (let ((overlay (make-overlay from to nil t nil)))
+    (overlay-put overlay 'widget-doc widget)
+    (overlay-put overlay 'face widget-documentation-face)
+    (widget-put widget :doc-overlay overlay)))

 
 (defmacro widget-specify-insert (&rest form)
   ;; Execute FORM without inheriting any text properties.
 
 (defmacro widget-specify-insert (&rest form)
   ;; Execute FORM without inheriting any text properties.


@@ -470,7 +410,6 @@ new value."
           after-change-functions)
        (insert "<>")
        (narrow-to-region (- (point) 2) (point))
           after-change-functions)
        (insert "<>")
        (narrow-to-region (- (point) 2) (point))

-       (widget-specify-none (point-min) (point-max))

        (goto-char (1+ (point-min)))
        (setq result (progn (,@ form)))
        (delete-region (point-min) (1+ (point-min)))
        (goto-char (1+ (point-min)))
        (setq result (progn (,@ form)))
        (delete-region (point-min) (1+ (point-min)))


@@ -522,27 +461,6 @@ new value."
   "Return the type of WIDGET, a symbol."
   (car widget))
 
   "Return the type of WIDGET, a symbol."
   (car widget))
 

-(defun widget-put (widget property value)
-  "In WIDGET set PROPERTY to VALUE.
-The value can later be retrived with `widget-get'."
-  (setcdr widget (plist-put (cdr widget) property value)))
-
-(defun widget-get (widget property)
-  "In WIDGET, get the value of PROPERTY.
-The value could either be specified when the widget was created, or
-later with `widget-put'."
-  (let ((missing t)
-       value tmp)
-    (while missing
-      (cond ((setq tmp (widget-plist-member (cdr widget) property))
-            (setq value (car (cdr tmp))
-                  missing nil))
-           ((setq tmp (car widget))
-            (setq widget (get tmp 'widget-type)))
-           (t 
-            (setq missing nil))))
-    value))
-

 (defun widget-get-indirect (widget property)
   "In WIDGET, get the value of PROPERTY.
 If the value is a symbol, return its binding.  
 (defun widget-get-indirect (widget property)
   "In WIDGET, get the value of PROPERTY.
 If the value is a symbol, return its binding.  


@@ -560,12 +478,6 @@ Otherwise, just return the value."
         (widget-member (get (car widget) 'widget-type) property))
        (t nil)))
 
         (widget-member (get (car widget) 'widget-type) property))
        (t nil)))
 

-;;;###autoload
-(defun widget-apply (widget property &rest args)
-  "Apply the value of WIDGET's PROPERTY to the widget itself.
-ARGS are passed as extra arguments to the function."
-  (apply (widget-get widget property) widget args))
-

 (defun widget-value (widget)
   "Extract the current value of WIDGET."
   (widget-apply widget
 (defun widget-value (widget)
   "Extract the current value of WIDGET."
   (widget-apply widget


@@ -577,6 +489,11 @@ ARGS are passed as extra arguments to the function."
                :value-set (widget-apply widget
                                         :value-to-internal value)))
 
                :value-set (widget-apply widget
                                         :value-to-internal value)))
 

+(defun widget-default-get (widget)
+  "Extract the default value of WIDGET."
+  (or (widget-get widget :value)
+      (widget-apply widget :default-get)))
+

 (defun widget-match-inline (widget vals)
   ;; In WIDGET, match the start of VALS.
   (cond ((widget-get widget :inline)
 (defun widget-match-inline (widget vals)
   ;; In WIDGET, match the start of VALS.
   (cond ((widget-get widget :inline)


@@ -883,8 +800,7 @@ The optional ARGS are additional keyword arguments."
        before-change-functions
        after-change-functions
        (from (point)))
        before-change-functions
        after-change-functions
        (from (point)))

-    (apply 'insert args)
-    (widget-specify-text from (point))))
+    (apply 'insert args)))

 
 (defun widget-convert-text (type from to
                                 &optional button-from button-to
 
 (defun widget-convert-text (type from to
                                 &optional button-from button-to


@@ -898,7 +814,6 @@ Optional ARGS are extra keyword arguments for TYPE."
   (let ((widget (apply 'widget-convert type :delete 'widget-leave-text args))
        (from (copy-marker from))
        (to (copy-marker to)))
   (let ((widget (apply 'widget-convert type :delete 'widget-leave-text args))
        (from (copy-marker from))
        (to (copy-marker to)))

-    (widget-specify-text from to)

     (set-marker-insertion-type from t)
     (set-marker-insertion-type to nil)
     (widget-put widget :from from)
     (set-marker-insertion-type from t)
     (set-marker-insertion-type to nil)
     (widget-put widget :from from)


@@ -920,12 +835,18 @@ button end points."
   (let ((from (widget-get widget :from))
        (to (widget-get widget :to))
        (button (widget-get widget :button-overlay))
   (let ((from (widget-get widget :from))
        (to (widget-get widget :to))
        (button (widget-get widget :button-overlay))

+       (sample (widget-get widget :sample-overlay))
+       (doc (widget-get widget :doc-overlay))

        (field (widget-get widget :field-overlay))
        (children (widget-get widget :children)))
     (set-marker from nil)
     (set-marker to nil)
     (when button
       (delete-overlay button))
        (field (widget-get widget :field-overlay))
        (children (widget-get widget :children)))
     (set-marker from nil)
     (set-marker to nil)
     (when button
       (delete-overlay button))

+    (when sample
+      (delete-overlay sample))
+    (when doc
+      (delete-overlay doc))

     (when field
       (delete-overlay field))
     (mapcar 'widget-leave-text children)))
     (when field
       (delete-overlay field))
     (mapcar 'widget-leave-text children)))


@@ -996,8 +917,9 @@ Recommended as a parent keymap for modes using widgets.")
   :group 'widget-faces)
 
 (defun widget-button-click (event)
   :group 'widget-faces)
 
 (defun widget-button-click (event)

-  "Invoke button below mouse pointer."
+  "Invoke the button that the mouse is pointing at, and move there."

   (interactive "@e")
   (interactive "@e")

+  (mouse-set-point event)

   (cond ((and (fboundp 'event-glyph)
              (event-glyph event))
         (widget-glyph-click event))
   (cond ((and (fboundp 'event-glyph)
              (event-glyph event))
         (widget-glyph-click event))


@@ -1079,7 +1001,7 @@ Recommended as a parent keymap for modes using widgets.")
       (if (eq extent (event-glyph-extent last))
          (set-extent-property extent 'end-glyph down-glyph)
        (set-extent-property extent 'end-glyph up-glyph))
       (if (eq extent (event-glyph-extent last))
          (set-extent-property extent 'end-glyph down-glyph)
        (set-extent-property extent 'end-glyph up-glyph))

-      (setq last (next-event event)))
+      (setq last (read-event event)))

     ;; Release glyph.
     (when down-glyph
       (set-extent-property extent 'end-glyph up-glyph))
     ;; Release glyph.
     (when down-glyph
       (set-extent-property extent 'end-glyph up-glyph))


@@ -1119,6 +1041,12 @@ POS defaults to the value of (point)."
            widget))
       nil)))
 
            widget))
       nil)))
 

+(defcustom widget-use-overlay-change (string-match "XEmacs" emacs-version)
+  "If non-nil, use overlay change functions to tab around in the buffer.
+This is much faster, but doesn't work reliably on Emacs 19.34."
+  :type 'boolean
+  :group 'widgets)
+

 (defun widget-move (arg)
   "Move point to the ARG next field or button.
 ARG may be negative to move backward."
 (defun widget-move (arg)
   "Move point to the ARG next field or button.
 ARG may be negative to move backward."


@@ -1129,9 +1057,12 @@ ARG may be negative to move backward."
        new)
     ;; Forward.
     (while (> arg 0)
        new)
     ;; Forward.
     (while (> arg 0)

-      (if (eobp)
-         (goto-char (point-min))
-       (forward-char 1))
+      (cond ((eobp)
+            (goto-char (point-min)))
+           (widget-use-overlay-change
+            (goto-char (next-overlay-change (point))))
+           (t
+            (forward-char 1)))

       (and (eq pos (point))
           (eq arg number)
           (error "No buttons or fields found"))
       (and (eq pos (point))
           (eq arg number)
           (error "No buttons or fields found"))


@@ -1142,9 +1073,12 @@ ARG may be negative to move backward."
            (setq old new)))))
     ;; Backward.
     (while (< arg 0)
            (setq old new)))))
     ;; Backward.
     (while (< arg 0)

-      (if (bobp)
-         (goto-char (point-max))
-       (backward-char 1))
+      (cond ((bobp)
+            (goto-char (point-max)))
+           (widget-use-overlay-change
+            (goto-char (previous-overlay-change (point))))
+           (t
+            (backward-char 1)))

       (and (eq pos (point))
           (eq arg number)
           (error "No buttons or fields found"))
       (and (eq pos (point))
           (eq arg number)
           (error "No buttons or fields found"))


@@ -1177,19 +1111,25 @@ With optional ARG, move across that many fields."
   "Go to beginning of field or beginning of line, whichever is first."
   (interactive)
   (let* ((field (widget-field-find (point)))
   "Go to beginning of field or beginning of line, whichever is first."
   (interactive)
   (let* ((field (widget-field-find (point)))

-        (start (and field (widget-field-start field))))
-    (if (and start (not (eq start (point))))
-       (goto-char start)
-      (call-interactively 'beginning-of-line))))
+        (start (and field (widget-field-start field)))
+         (bol (save-excursion
+                (beginning-of-line)
+                (point))))
+    (goto-char (if start
+                   (max start bol)
+                 bol))))

 
 (defun widget-end-of-line ()
   "Go to end of field or end of line, whichever is first."
   (interactive)
   (let* ((field (widget-field-find (point)))
 
 (defun widget-end-of-line ()
   "Go to end of field or end of line, whichever is first."
   (interactive)
   (let* ((field (widget-field-find (point)))

-        (end (and field (widget-field-end field))))
-    (if (and end (not (eq end (point))))
-       (goto-char end)
-      (call-interactively 'end-of-line))))
+        (end (and field (widget-field-end field)))
+         (eol (save-excursion
+                (end-of-line)
+                (point))))
+    (goto-char (if end
+                   (min end eol)
+                 eol))))

 
 (defun widget-kill-line ()
   "Kill to end of field or end of line, whichever is first."
 
 (defun widget-kill-line ()
   "Kill to end of field or end of line, whichever is first."


@@ -1243,14 +1183,7 @@ When not inside a field, move to the previous button or field."
        (set-marker from nil)
        (set-marker to nil))))
   (widget-clear-undo)
        (set-marker from nil)
        (set-marker to nil))))
   (widget-clear-undo)

-  ;; We need to maintain text properties and size of the editing fields.
-  (make-local-variable 'after-change-functions)
-  (setq after-change-functions
-       (if widget-field-list '(widget-after-change) nil))
-  (when widget-field-use-before-change
-    (make-local-variable 'before-change-functions)
-    (setq before-change-functions
-         (if widget-field-list '(widget-before-change) nil))))
+  (widget-add-change))

 
 (defvar widget-field-last nil)
 ;; Last field containing point.
 
 (defvar widget-field-last nil)
 ;; Last field containing point.


@@ -1295,13 +1228,30 @@ Unlike (get-char-property POS 'field) this, works with empty fields too."
          (setq found field))))
     found))
 
          (setq found field))))
     found))
 

-(defun widget-before-change (from &rest ignore)
+(defun widget-before-change (from to)

   ;; This is how, for example, a variable changes its state to `modified'.
   ;; when it is being edited.
   ;; This is how, for example, a variable changes its state to `modified'.
   ;; when it is being edited.

-  (condition-case nil
-      (let ((field (widget-field-find from)))
-       (widget-apply field :notify field))
-    (error (debug "Before Change"))))
+  (unless inhibit-read-only
+    (let ((from-field (widget-field-find from))
+         (to-field (widget-field-find to)))
+      (cond ((not (eq from-field to-field))
+            (add-hook 'post-command-hook 'widget-add-change nil t)
+            (error "Change should be restricted to a single field"))
+           ((null from-field)
+            (add-hook 'post-command-hook 'widget-add-change nil t)
+            (error "Attempt to change text outside editable field"))
+           (widget-field-use-before-change
+            (condition-case nil
+                (widget-apply from-field :notify from-field)
+              (error (debug "Before Change"))))))))
+
+(defun widget-add-change ()
+  (make-local-hook 'post-command-hook)
+  (remove-hook 'post-command-hook 'widget-add-change t)
+  (make-local-hook 'before-change-functions)
+  (add-hook 'before-change-functions 'widget-before-change nil t)
+  (make-local-hook 'after-change-functions)
+  (add-hook 'after-change-functions 'widget-after-change nil t))

 
 (defun widget-after-change (from to old)
   ;; Adjust field size and text properties.
 
 (defun widget-after-change (from to old)
   ;; Adjust field size and text properties.


@@ -1311,8 +1261,7 @@ Unlike (get-char-property POS 'field) this, works with empty fields too."
        (when field
          (unless (eq field other)
            (debug "Change in different fields"))
        (when field
          (unless (eq field other)
            (debug "Change in different fields"))

-         (let ((size (widget-get field :size))
-               (secret (widget-get field :secret)))
+         (let ((size (widget-get field :size)))

            (when size 
              (let ((begin (widget-field-start field))
                    (end (widget-field-end field)))
            (when size 
              (let ((begin (widget-field-start field))
                    (end (widget-field-end field)))


@@ -1334,19 +1283,7 @@ Unlike (get-char-property POS 'field) this, works with empty fields too."
                         (while (and (eq (preceding-char) ?\ )
                                     (> (point) begin))
                           (delete-backward-char 1)))))))
                         (while (and (eq (preceding-char) ?\ )
                                     (> (point) begin))
                           (delete-backward-char 1)))))))

-           (when secret
-             (let ((begin (widget-field-start field))
-                   (end (widget-field-end field)))
-               (when size 
-                 (while (and (> end begin)
-                             (eq (char-after (1- end)) ?\ ))
-                   (setq end (1- end))))
-               (while (< begin end)
-                 (let ((old (char-after begin)))
-                   (unless (eq old secret)
-                     (subst-char-in-region begin (1+ begin) old secret)
-                     (put-text-property begin (1+ begin) 'secret old))
-                   (setq begin (1+ begin)))))))
+           (widget-specify-secret field))

          (widget-apply field :notify field)))
     (error (debug "After Change"))))
 
          (widget-apply field :notify field)))
     (error (debug "After Change"))))
 


@@ -1414,6 +1351,7 @@ Optional EVENT is the event that triggered the action."
   :delete 'widget-default-delete
   :value-set 'widget-default-value-set
   :value-inline 'widget-default-value-inline
   :delete 'widget-default-delete
   :value-set 'widget-default-value-set
   :value-inline 'widget-default-value-inline

+  :default-get 'widget-default-default-get

   :menu-tag-get 'widget-default-menu-tag-get
   :validate (lambda (widget) nil)
   :active 'widget-default-active
   :menu-tag-get 'widget-default-menu-tag-get
   :validate (lambda (widget) nil)
   :active 'widget-default-active


@@ -1497,7 +1435,6 @@ If that does not exists, call the value of `widget-complete-field'."
        (widget-apply widget :value-create)))
    (let ((from (copy-marker (point-min)))
         (to (copy-marker (point-max))))
        (widget-apply widget :value-create)))
    (let ((from (copy-marker (point-min)))
         (to (copy-marker (point-max))))

-     (widget-specify-text from to)

      (set-marker-insertion-type from t)
      (set-marker-insertion-type to nil)
      (widget-put widget :from from)
      (set-marker-insertion-type from t)
      (set-marker-insertion-type to nil)
      (widget-put widget :from from)


@@ -1562,6 +1499,8 @@ If that does not exists, call the value of `widget-complete-field'."
        (to (widget-get widget :to))
        (inactive-overlay (widget-get widget :inactive))
        (button-overlay (widget-get widget :button-overlay))
        (to (widget-get widget :to))
        (inactive-overlay (widget-get widget :inactive))
        (button-overlay (widget-get widget :button-overlay))

+       (sample-overlay (widget-get widget :sample-overlay))
+       (doc-overlay (widget-get widget :doc-overlay))

        before-change-functions
        after-change-functions
        (inhibit-read-only t))
        before-change-functions
        after-change-functions
        (inhibit-read-only t))


@@ -1570,6 +1509,10 @@ If that does not exists, call the value of `widget-complete-field'."
       (delete-overlay inactive-overlay))
     (when button-overlay
       (delete-overlay button-overlay))
       (delete-overlay inactive-overlay))
     (when button-overlay
       (delete-overlay button-overlay))

+    (when sample-overlay
+      (delete-overlay sample-overlay))
+    (when doc-overlay
+      (delete-overlay doc-overlay))

     (when (< from to)
       ;; Kludge: this doesn't need to be true for empty formats.
       (delete-region from to))
     (when (< from to)
       ;; Kludge: this doesn't need to be true for empty formats.
       (delete-region from to))


@@ -1605,6 +1548,10 @@ If that does not exists, call the value of `widget-complete-field'."
       (widget-value widget)
     (list (widget-value widget))))
 
       (widget-value widget)
     (list (widget-value widget))))
 

+(defun widget-default-default-get (widget)
+  ;; Get `:value'.
+  (widget-get widget :value))
+

 (defun widget-default-menu-tag-get (widget)
   ;; Use tag or value for menus.
   (or (widget-get widget :menu-tag)
 (defun widget-default-menu-tag-get (widget)
   ;; Use tag or value for menus.
   (or (widget-get widget :menu-tag)


@@ -1789,8 +1736,27 @@ If END is omitted, it defaults to the length of LIST."
 
 (defun widget-url-link-action (widget &optional event)
   "Open the url specified by WIDGET."
 
 (defun widget-url-link-action (widget &optional event)
   "Open the url specified by WIDGET."

-  (require 'browse-url)
-  (funcall browse-url-browser-function (widget-value widget)))
+  (browse-url (widget-value widget)))
+
+;;; The `function-link' Widget.
+
+(define-widget 'function-link 'link
+  "A link to an Emacs function."
+  :action 'widget-function-link-action)
+
+(defun widget-function-link-action (widget &optional event)
+  "Show the function specified by WIDGET."
+  (describe-function (widget-value widget)))
+
+;;; The `variable-link' Widget.
+
+(define-widget 'variable-link 'link
+  "A link to an Emacs variable."
+  :action 'widget-variable-link-action)
+
+(defun widget-variable-link-action (widget &optional event)
+  "Show the variable specified by WIDGET."
+  (describe-variable (widget-value widget)))

 
 ;;; The `file-link' Widget.
 
 
 ;;; The `file-link' Widget.
 


@@ -1812,6 +1778,16 @@ If END is omitted, it defaults to the length of LIST."
   "Find the Emacs Library file specified by WIDGET."
   (find-file (locate-library (widget-value widget))))
 
   "Find the Emacs Library file specified by WIDGET."
   (find-file (locate-library (widget-value widget))))
 

+;;; The `emacs-commentary-link' Widget.
+    
+(define-widget 'emacs-commentary-link 'link
+  "A link to Commentary in an Emacs Lisp library file."
+  :action 'widget-emacs-commentary-link-action)
+    
+(defun widget-emacs-commentary-link-action (widget &optional event)
+  "Find the Commentary section of the Emacs file specified by WIDGET."
+  (finder-commentary (widget-value widget)))
+

 ;;; The `editable-field' Widget.
 
 (define-widget 'editable-field 'default
 ;;; The `editable-field' Widget.
 
 (define-widget 'editable-field 'default


@@ -1949,6 +1925,7 @@ If END is omitted, it defaults to the length of LIST."
   :value-delete 'widget-children-value-delete
   :value-get 'widget-choice-value-get
   :value-inline 'widget-choice-value-inline
   :value-delete 'widget-children-value-delete
   :value-get 'widget-choice-value-get
   :value-inline 'widget-choice-value-inline

+  :default-get 'widget-choice-default-get

   :mouse-down-action 'widget-choice-mouse-down-action
   :action 'widget-choice-action
   :error "Make a choice"
   :mouse-down-action 'widget-choice-mouse-down-action
   :action 'widget-choice-action
   :error "Make a choice"


@@ -1960,21 +1937,30 @@ If END is omitted, it defaults to the length of LIST."
   ;; Insert the first choice that matches the value.
   (let ((value (widget-get widget :value))
        (args (widget-get widget :args))
   ;; Insert the first choice that matches the value.
   (let ((value (widget-get widget :value))
        (args (widget-get widget :args))

+       (explicit (widget-get widget :explicit-choice))
+       (explicit-value (widget-get widget :explicit-choice-value))

        current)
        current)

-    (while args
-      (setq current (car args)
-           args (cdr args))
-      (when (widget-apply current :match value)
-       (widget-put widget :children (list (widget-create-child-value
-                                           widget current value)))
-       (widget-put widget :choice current)
-       (setq args nil
-             current nil)))
-    (when current
-      (let ((void (widget-get widget :void)))
-       (widget-put widget :children (list (widget-create-child-and-convert
-                                           widget void :value value)))
-       (widget-put widget :choice void)))))
+    (if (and explicit (eq value explicit-value))
+       (progn
+         ;; If the user specified the choice for this value,
+         ;; respect that choice as long as the value is the same.
+         (widget-put widget :children (list (widget-create-child-value
+                                             widget explicit value)))
+         (widget-put widget :choice explicit))
+      (while args
+       (setq current (car args)
+             args (cdr args))
+       (when (widget-apply current :match value)
+         (widget-put widget :children (list (widget-create-child-value
+                                             widget current value)))
+         (widget-put widget :choice current)
+         (setq args nil
+               current nil)))
+      (when current
+       (let ((void (widget-get widget :void)))
+         (widget-put widget :children (list (widget-create-child-and-convert
+                                             widget void :value value)))
+         (widget-put widget :choice void))))))

 
 (defun widget-choice-value-get (widget)
   ;; Get value of the child widget.
 
 (defun widget-choice-value-get (widget)
   ;; Get value of the child widget.


@@ -1984,6 +1970,10 @@ If END is omitted, it defaults to the length of LIST."
   ;; Get value of the child widget.
   (widget-apply (car (widget-get widget :children)) :value-inline))
 
   ;; Get value of the child widget.
   (widget-apply (car (widget-get widget :children)) :value-inline))
 

+(defun widget-choice-default-get (widget)
+  ;; Get default for the first choice.
+  (widget-default-get (car (widget-get widget :args))))
+

 (defcustom widget-choice-toggle nil
   "If non-nil, a binary choice will just toggle between the values.
 Otherwise, the user will explicitly have to choose between the values
 (defcustom widget-choice-toggle nil
   "If non-nil, a binary choice will just toggle between the values.
 Otherwise, the user will explicitly have to choose between the values


@@ -2023,6 +2013,7 @@ when he invoked the menu."
        (old (widget-get widget :choice))
        (tag (widget-apply widget :menu-tag-get))
        (completion-ignore-case (widget-get widget :case-fold))
        (old (widget-get widget :choice))
        (tag (widget-apply widget :menu-tag-get))
        (completion-ignore-case (widget-get widget :case-fold))

+       this-explicit

        current choices)
     ;; Remember old value.
     (if (and old (not (widget-apply widget :validate)))
        current choices)
     ;; Remember old value.
     (if (and old (not (widget-apply widget :validate)))


@@ -2049,11 +2040,19 @@ when he invoked the menu."
                         (cons (cons (widget-apply current :menu-tag-get)
                                     current)
                               choices)))
                         (cons (cons (widget-apply current :menu-tag-get)
                                     current)
                               choices)))

+                (setq this-explicit t)

                 (widget-choose tag (reverse choices) event))))
     (when current
                 (widget-choose tag (reverse choices) event))))
     (when current

-      (widget-value-set widget 
-                       (widget-apply current :value-to-external
-                                     (widget-get current :value)))
+      ;; If this was an explicit user choice,
+      ;; record the choice, and the record the value it was made for.
+      ;; widget-choice-value-create will respect this choice,
+      ;; as long as the value is the same.
+      (when this-explicit
+       (widget-put widget :explicit-choice current)
+       (widget-put widget :explicit-choice-value (widget-get widget :value)))
+      (let ((value (widget-default-get current)))
+       (widget-value-set widget 
+                         (widget-apply current :value-to-external value)))

       (widget-setup)
       (widget-apply widget :notify widget event)))
   (run-hook-with-args 'widget-edit-functions widget))
       (widget-setup)
       (widget-apply widget :notify widget event)))
   (run-hook-with-args 'widget-edit-functions widget))


@@ -2599,8 +2598,6 @@ when he invoked the menu."
        (when (< (widget-get child :entry-from) (widget-get widget :from))
          (set-marker (widget-get widget :from)
                      (widget-get child :entry-from)))
        (when (< (widget-get child :entry-from) (widget-get widget :from))
          (set-marker (widget-get widget :from)
                      (widget-get child :entry-from)))

-       (widget-specify-text (widget-get child :entry-from)
-                            (widget-get child :entry-to))

        (if (eq (car children) before)
            (widget-put widget :children (cons child children))
          (while (not (eq (car (cdr children)) before))
        (if (eq (car children) before)
            (widget-put widget :children (cons child children))
          (while (not (eq (car (cdr children)) before))


@@ -2665,7 +2662,10 @@ when he invoked the menu."
                (if conv
                    (setq child (widget-create-child-value 
                                 widget type value))
                (if conv
                    (setq child (widget-create-child-value 
                                 widget type value))

-                 (setq child (widget-create-child widget type))))
+                 (setq child (widget-create-child-value 
+                              widget type
+                              (widget-apply type :value-to-external
+                                            (widget-default-get type))))))

               (t 
                (error "Unknown escape `%c'" escape)))))
      (widget-put widget 
               (t 
                (error "Unknown escape `%c'" escape)))))
      (widget-put widget 


@@ -2674,7 +2674,6 @@ when he invoked the menu."
                                      (widget-get widget :buttons))))
      (let ((entry-from (copy-marker (point-min)))
           (entry-to (copy-marker (point-max))))
                                      (widget-get widget :buttons))))
      (let ((entry-from (copy-marker (point-min)))
           (entry-to (copy-marker (point-max))))

-       (widget-specify-text entry-from entry-to)

        (set-marker-insertion-type entry-from t)
        (set-marker-insertion-type entry-to nil)
        (widget-put child :entry-from entry-from)
        (set-marker-insertion-type entry-from t)
        (set-marker-insertion-type entry-to nil)
        (widget-put child :entry-from entry-from)


@@ -2692,6 +2691,7 @@ when he invoked the menu."
   :value-create 'widget-group-value-create
   :value-delete 'widget-children-value-delete
   :value-get 'widget-editable-list-value-get
   :value-create 'widget-group-value-create
   :value-delete 'widget-children-value-delete
   :value-get 'widget-editable-list-value-get

+  :default-get 'widget-group-default-get

   :validate 'widget-children-validate
   :match 'widget-group-match
   :match-inline 'widget-group-match-inline)
   :validate 'widget-children-validate
   :match 'widget-group-match
   :match-inline 'widget-group-match-inline)


@@ -2718,6 +2718,10 @@ when he invoked the menu."
            children))
     (widget-put widget :children (nreverse children))))
 
            children))
     (widget-put widget :children (nreverse children))))
 

+(defun widget-group-default-get (widget)
+  ;; Get the default of the components.
+  (mapcar 'widget-default-get (widget-get widget :args)))
+

 (defun widget-group-match (widget values)
   ;; Match if the components match.
   (and (listp values)
 (defun widget-group-match (widget values)
   ;; Match if the components match.
   (and (listp values)


@@ -2919,6 +2923,17 @@ link for that string."
   :format "%v\n%h"
   :documentation-property 'variable-documentation)
 
   :format "%v\n%h"
   :documentation-property 'variable-documentation)
 

+(define-widget 'other 'sexp
+  "Matches any value, but doesn't let the user edit the value.
+This is useful as last item in a `choice' widget.
+You should use this widget type with a default value,
+as in (other DEFAULT) or (other :tag \"NAME\" DEFAULT).
+If the user selects this alternative, that specifies DEFAULT
+as the value."
+  :tag "Other"
+  :format "%t%n"
+  :value 'other)
+

 (defvar widget-string-prompt-value-history nil
   "History of input to `widget-string-prompt-value'.")
 
 (defvar widget-string-prompt-value-history nil
   "History of input to `widget-string-prompt-value'.")
 


@@ -2933,7 +2948,8 @@ link for that string."
   "A regular expression."
   :match 'widget-regexp-match
   :validate 'widget-regexp-validate
   "A regular expression."
   :match 'widget-regexp-match
   :validate 'widget-regexp-validate

-  :value-face 'widget-single-line-field-face
+  ;; Doesn't work well with terminating newline.
+  ;; :value-face 'widget-single-line-field-face

   :tag "Regexp")
 
 (defun widget-regexp-match (widget value)
   :tag "Regexp")
 
 (defun widget-regexp-match (widget value)


@@ -2959,7 +2975,8 @@ It will read a file name from the minibuffer when invoked."
   :complete-function 'widget-file-complete
   :prompt-value 'widget-file-prompt-value
   :format "%{%t%}: %v"
   :complete-function 'widget-file-complete
   :prompt-value 'widget-file-prompt-value
   :format "%{%t%}: %v"

-  :value-face 'widget-single-line-field-face
+  ;; Doesn't work well with terminating newline.
+  ;; :value-face 'widget-single-line-field-face

   :tag "File")
 
 (defun widget-file-complete ()
   :tag "File")
 
 (defun widget-file-complete ()


@@ -3021,7 +3038,7 @@ It will read a directory name from the minibuffer when invoked."
   "History of input to `widget-symbol-prompt-value'.")
 
 (define-widget 'symbol 'editable-field
   "History of input to `widget-symbol-prompt-value'.")
 
 (define-widget 'symbol 'editable-field

-  "A lisp symbol."
+  "A Lisp symbol."

   :value nil
   :tag "Symbol"
   :format "%{%t%}: %v"
   :value nil
   :tag "Symbol"
   :format "%{%t%}: %v"


@@ -3053,7 +3070,7 @@ It will read a directory name from the minibuffer when invoked."
   "History of input to `widget-function-prompt-value'.")
 
 (define-widget 'function 'sexp
   "History of input to `widget-function-prompt-value'.")
 
 (define-widget 'function 'sexp

-  "A lisp function."
+  "A Lisp function."

   :complete-function 'lisp-complete-symbol
   :prompt-value 'widget-field-prompt-value
   :prompt-internal 'widget-symbol-prompt-internal
   :complete-function 'lisp-complete-symbol
   :prompt-value 'widget-field-prompt-value
   :prompt-internal 'widget-symbol-prompt-internal


@@ -3067,7 +3084,7 @@ It will read a directory name from the minibuffer when invoked."
 
 (define-widget 'variable 'symbol
   ;; Should complete on variables.
 
 (define-widget 'variable 'symbol
   ;; Should complete on variables.

-  "A lisp variable."
+  "A Lisp variable."

   :prompt-match 'boundp
   :prompt-history 'widget-variable-prompt-value-history
   :tag "Variable")
   :prompt-match 'boundp
   :prompt-history 'widget-variable-prompt-value-history
   :tag "Variable")


@@ -3108,7 +3125,7 @@ It will read a directory name from the minibuffer when invoked."
   )
 
 (define-widget 'sexp 'editable-field
   )
 
 (define-widget 'sexp 'editable-field

-  "An arbitrary lisp expression."
+  "An arbitrary Lisp expression."

   :tag "Lisp expression"
   :format "%{%t%}: %v"
   :value nil
   :tag "Lisp expression"
   :format "%{%t%}: %v"
   :value nil


@@ -3231,12 +3248,12 @@ To use this type, you must define :match or :match-alternatives."
             (integerp value))))
 
 (define-widget 'list 'group
             (integerp value))))
 
 (define-widget 'list 'group

-  "A lisp list."
+  "A Lisp list."

   :tag "List"
   :format "%{%t%}:\n%v")
 
 (define-widget 'vector 'group
   :tag "List"
   :format "%{%t%}:\n%v")
 
 (define-widget 'vector 'group

-  "A lisp vector."
+  "A Lisp vector."

   :tag "Vector"
   :format "%{%t%}:\n%v"
   :match 'widget-vector-match
   :tag "Vector"
   :format "%{%t%}:\n%v"
   :match 'widget-vector-match


@@ -3345,33 +3362,44 @@ To use this type, you must define :match or :match-alternatives."
 
 ;;; The `color' Widget.
 
 
 ;;; The `color' Widget.
 

-(define-widget 'color-item 'choice-item
-  "A color name (with sample)."
-  :format "%v (%{sample%})\n"
-  :sample-face-get 'widget-color-item-button-face-get)
-
-(defun widget-color-item-button-face-get (widget)
-  (let ((symbol (intern (concat "fg:" (widget-value widget)))))
-    (if (string-match "XEmacs" emacs-version)
-       (prog1 symbol
-         (or (find-face symbol)
-             (set-face-foreground (make-face symbol) (widget-value widget))))
-      (condition-case nil
-         (facemenu-get-face symbol)
-       (error 'default)))))
-
-(define-widget 'color 'push-button
+(define-widget 'color 'editable-field 

   "Choose a color name (with sample)."
   "Choose a color name (with sample)."

-  :format "%[%t%]: %v"
+  :format "%t: %v (%{sample%})\n"
+  :size 10

   :tag "Color"
   :value "black"
   :tag "Color"
   :value "black"

-  :value-create 'widget-color-value-create
-  :value-delete 'widget-children-value-delete
-  :value-get 'widget-color-value-get
-  :value-set 'widget-color-value-set
-  :action 'widget-color-action
-  :match 'widget-field-match
-  :tag "Color")
+  :complete 'widget-color-complete
+  :sample-face-get 'widget-color-sample-face-get
+  :notify 'widget-color-notify
+  :action 'widget-color-action)
+
+(defun widget-color-complete (widget)
+  "Complete the color in WIDGET."
+  (let* ((prefix (buffer-substring-no-properties (widget-field-start widget)
+                                                (point)))
+        (list (widget-color-choice-list))
+        (completion (try-completion prefix list)))
+    (cond ((eq completion t)
+          (message "Exact match."))
+         ((null completion)
+          (error "Can't find completion for \"%s\"" prefix))
+         ((not (string-equal prefix completion))
+          (insert-and-inherit (substring completion (length prefix))))
+         (t
+          (message "Making completion list...")
+          (let ((list (all-completions prefix list nil)))
+            (with-output-to-temp-buffer "*Completions*"
+              (display-completion-list list)))
+          (message "Making completion list...done")))))
+
+(defun widget-color-sample-face-get (widget)
+  (let* ((value (condition-case nil
+                   (widget-value widget)
+                 (error (widget-get widget :value))))
+        (symbol (intern (concat "fg:" value))))
+    (condition-case nil
+       (facemenu-get-face symbol)
+      (error 'default))))

 
 (defvar widget-color-choice-list nil)
 ;; Variable holding the possible colors.
 
 (defvar widget-color-choice-list nil)
 ;; Variable holding the possible colors.


@@ -3383,19 +3411,6 @@ To use this type, you must define :match or :match-alternatives."
                  (x-defined-colors))))
   widget-color-choice-list)
 
                  (x-defined-colors))))
   widget-color-choice-list)
 

-(defun widget-color-value-create (widget)
-  (let ((child (widget-create-child-and-convert
-               widget 'color-item (widget-get widget :value))))
-    (widget-put widget :children (list child))))
-
-(defun widget-color-value-get (widget)
-  ;; Pass command to first child.
-  (widget-apply (car (widget-get widget :children)) :value-get))
-
-(defun widget-color-value-set (widget value)
-  ;; Pass command to first child.
-  (widget-apply (car (widget-get widget :children)) :value-set value))
-

 (defvar widget-color-history nil
   "History of entered colors")
 
 (defvar widget-color-history nil
   "History of entered colors")
 


@@ -3403,42 +3418,31 @@ To use this type, you must define :match or :match-alternatives."
   ;; Prompt for a color.
   (let* ((tag (widget-apply widget :menu-tag-get))
         (prompt (concat tag ": "))
   ;; Prompt for a color.
   (let* ((tag (widget-apply widget :menu-tag-get))
         (prompt (concat tag ": "))

-        (answer (cond ((string-match "XEmacs" emacs-version)
-                       (read-color prompt))
-                      ((fboundp 'x-defined-colors)
-                       (completing-read (concat tag ": ")
-                                        (widget-color-choice-list) 
-                                        nil nil nil 'widget-color-history))
-                      (t
-                       (read-string prompt (widget-value widget))))))
+        (value (widget-value widget))
+        (start (widget-field-start widget))
+        (pos (cond ((< (point) start)
+                    0)
+                   ((> (point) (+ start (length value)))
+                    (length value))
+                   (t
+                    (- (point) start))))
+        (answer (if (commandp 'read-color)
+                    (read-color prompt)
+                  (completing-read (concat tag ": ")
+                                   (widget-color-choice-list) 
+                                   nil nil 
+                                   (cons value pos)
+                                   'widget-color-history))))

     (unless (zerop (length answer))
       (widget-value-set widget answer)
       (widget-setup)
       (widget-apply widget :notify widget event))))
 
     (unless (zerop (length answer))
       (widget-value-set widget answer)
       (widget-setup)
       (widget-apply widget :notify widget event))))
 

-;;; The alternative `editable-color' widget and its subroutine.
-
-(define-widget 'color-sample 'choice-item
-  "A color name (with sample)."
-  :format "(%{sample%})"
-  :sample-face-get 'widget-color-item-button-face-get)
-
-(define-widget 'editable-color 'editable-field
-  "A color name, editable"
-  :tag "Color"
-  :format "%{%t%}: %v"
-  :complete-function 'widget-color-complete
-  :value-create 'widget-editable-color-value-create
-  :prompt-match '(lambda (color) (member color widget-color-choice-list))
-  :prompt-history 'widget-string-prompt-value-history)
-
-(defun widget-editable-color-value-create (widget)
-  (widget-field-value-create widget)
-  (forward-line -1)
-  (end-of-line)
-  (let ((child (widget-create-child-and-convert
-               widget 'color-sample (widget-get widget :value))))
-    (widget-put widget :children (list child))))
+(defun widget-color-notify (widget child &optional event)
+  "Update the sample, and notofy the parent."
+  (overlay-put (widget-get widget :sample-overlay) 
+              'face (widget-apply widget :sample-face-get))
+  (widget-default-notify widget child event))

 
 ;;; The Help Echo
 
 
 ;;; The Help Echo
 


@@ -3457,7 +3461,7 @@ Enable with (run-with-idle-timer 1 t 'widget-echo-help-mouse)"
          (select-window win)
          (let* ((result (compute-motion (window-start win)
                                         '(0 . 0)
          (select-window win)
          (let* ((result (compute-motion (window-start win)
                                         '(0 . 0)

-                                        (window-end win)
+                                        (point-max)

                                         where
                                         (window-width win)
                                         (cons (window-hscroll) 0)
                                         where
                                         (window-width win)
                                         (cons (window-hscroll) 0)