Add a provide statement.

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

diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el
index 555ab181f1a49f564194f2640a35062f8de211e0..f659518ee0298d4700086f0a74d410039987ff5d 100644 (file)
--- a/lisp/wid-edit.el
+++ b/lisp/wid-edit.el
@@ -1,11 +1,10 @@
-;;; wid-edit.el --- Functions for creating and using widgets.
+;;; wid-edit.el --- Functions for creating and using widgets -*-byte-compile-dynamic: t;-*-

 ;;
 ;;

-;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
+;; Copyright (C) 1996,97,1999,2000,01,02,2003, 2004  Free Software Foundation, Inc.

 ;;
 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
 ;;
 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>

+;; Maintainer: FSF

 ;; Keywords: extensions
 ;; Keywords: extensions

-;; Version: 1.90
-;; X-URL: http://www.dina.kvl.dk/~abraham/custom/

 
 ;; This file is part of GNU Emacs.
 
 
 ;; This file is part of GNU Emacs.
 


@@ -24,94 +23,76 @@
 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 ;; Boston, MA 02111-1307, USA.
 
 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 ;; Boston, MA 02111-1307, USA.
 

+;;; Wishlist items (from widget.texi):
+
+;; * The `menu-choice' tag should be prettier, something like the
+;;   abbreviated menus in Open Look.
+
+;; * Finish `:tab-order'.
+
+;; * Make indentation work with glyphs and proportional fonts.
+
+;; * Add commands to show overview of object and class hierarchies to
+;;   the browser.
+
+;; * Find a way to disable mouse highlight for inactive widgets.
+
+;; * Find a way to make glyphs look inactive.
+
+;; * Add `key-binding' widget.
+
+;; * Add `widget' widget for editing widget specifications.
+
+;; * Find clean way to implement variable length list.  See
+;;   `TeX-printer-list' for an explanation.
+
+;; * `C-h' in `widget-prompt-value' should give type specific help.
+
+;; * A mailto widget. [This should work OK as a url-link if with
+;;   browse-url-browser-function' set up appropriately.]
+

 ;;; Commentary:
 ;;
 ;; See `widget.el'.
 
 ;;; Code:
 
 ;;; Commentary:
 ;;
 ;; See `widget.el'.
 
 ;;; Code:
 

-(require 'widget)
-
-(eval-when-compile (require 'cl))
-

 ;;; Compatibility.
 
 ;;; Compatibility.
 

-(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)
-      ;; 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)))
-         
-;; The following should go away when bundled with Emacs.
-  (condition-case ()
-      (require 'custom)
-    (error nil))
-
-  (unless (and (featurep 'custom) (fboundp 'custom-declare-variable))
-    ;; We have the old custom-library, hack around it!
-    (defmacro defgroup (&rest args) nil)
-    (defmacro defcustom (var value doc &rest args) 
-      (` (defvar (, var) (, value) (, doc))))
-    (defmacro defface (&rest args) nil)
-    (define-widget-keywords :prefix :tag :load :link :options :type :group)
-    (when (fboundp 'copy-face)
-      (copy-face 'default 'widget-documentation-face)
-      (copy-face 'bold 'widget-button-face)
-      (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,
-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))))
-
-  (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)))))
+(defun widget-event-point (event)
+  "Character position of the end of event if that exists, or nil."
+  (posn-point (event-end event)))
+
+(defun widget-button-release-event-p (event)
+  "Non-nil if EVENT is a mouse-button-release event object."
+  (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)))))

 
 ;;; Customization.
 
 (defgroup widgets nil
   "Customization support for the Widget Library."
   :link '(custom-manual "(widget)Top")
 
 ;;; Customization.
 
 (defgroup widgets nil
   "Customization support for the Widget Library."
   :link '(custom-manual "(widget)Top")

-  :link '(url-link :tag "Development Page" 
-                  "http://www.dina.kvl.dk/~abraham/custom/")
+  :link '(emacs-library-link :tag "Lisp File" "widget.el")

   :prefix "widget-"
   :group 'extensions
   :prefix "widget-"
   :group 'extensions

-  :group 'faces

   :group 'hypermedia)
 
   :group 'hypermedia)
 

+(defgroup widget-documentation nil
+  "Options controling the display of documentation strings."
+  :group 'widgets)
+
+(defgroup widget-faces nil
+  "Faces used by the widget library."
+  :group 'widgets
+  :group 'faces)
+
+(defvar widget-documentation-face 'widget-documentation-face
+  "Face used for documentation strings in widgets.
+This exists as a variable so it can be set locally in certain buffers.")
+

 (defface widget-documentation-face '((((class color)
                                       (background dark))
                                      (:foreground "lime green"))
 (defface widget-documentation-face '((((class color)
                                       (background dark))
                                      (:foreground "lime green"))


@@ -120,70 +101,105 @@ into the buffer visible in the event's window."
                                      (:foreground "dark green"))
                                     (t nil))
   "Face used for documentation text."
                                      (:foreground "dark green"))
                                     (t nil))
   "Face used for documentation text."

-  :group 'widgets)
+  :group 'widget-documentation
+  :group 'widget-faces)

 
 

-(defface widget-button-face '((t (:bold t)))
+(defvar widget-button-face 'widget-button-face
+  "Face used for buttons in widgets.
+This exists as a variable so it can be set locally in certain buffers.")
+
+(defface widget-button-face '((t (:weight bold)))

   "Face used for widget buttons."
   "Face used for widget buttons."

-  :group 'widgets)
+  :group 'widget-faces)

 
 (defcustom widget-mouse-face 'highlight
   "Face used for widget buttons when the mouse is above them."
   :type 'face
 
 (defcustom widget-mouse-face 'highlight
   "Face used for widget buttons when the mouse is above them."
   :type 'face

-  :group 'widgets)
-
-(defface widget-field-face '((((class grayscale color)
+  :group 'widget-faces)
+
+;; TTY gets special definitions here and in the next defface, because
+;; the gray colors defined for other displays cause black text on a black
+;; background, at least on light-background TTYs.
+(defface widget-field-face '((((type tty))
+                             :background "yellow3"
+                             :foreground "black")
+                            (((class grayscale color)

                               (background light))
                               (background light))

-                             (:background "gray85"))
+                             :background "gray85")

                             (((class grayscale color)
                               (background dark))
                             (((class grayscale color)
                               (background dark))

-                             (:background "dark gray"))
-                            (t 
-                             (:italic t)))
+                             :background "dim gray")
+                            (t
+                             :slant italic))

   "Face used for editable fields."
   "Face used for editable fields."

-  :group 'widgets)
-
-(defcustom widget-menu-max-size 40
-  "Largest number of items allowed in a popup-menu.
-Larger menus are read through the minibuffer."
-  :group 'widgets
-  :type 'integer)
+  :group 'widget-faces)
+
+(defface widget-single-line-field-face '((((type tty))
+                                         :background "green3"
+                                         :foreground "black")
+                                        (((class grayscale color)
+                                          (background light))
+                                         :background "gray85")
+                                        (((class grayscale color)
+                                          (background dark))
+                                         :background "dim gray")
+                                        (t
+                                         :slant italic))
+  "Face used for editable fields spanning only a single line."
+  :group 'widget-faces)
+
+;;; 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))

 
 ;;; 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)
 (defun widget-princ-to-string (object)

-  ;; Return string representation of OBJECT, any Lisp object.
-  ;; No quoting characters are used; no delimiters are printed around
-  ;; the contents of strings.
-  (save-excursion
-    (set-buffer (get-buffer-create " *widget-tmp*"))
-    (erase-buffer)
-    (let ((standard-output (current-buffer)))
-      (princ object))
-    (buffer-string)))
+  "Return string representation of OBJECT, any Lisp object.
+No quoting characters are used; no delimiters are printed around
+the contents of strings."
+  (with-output-to-string
+      (princ object)))

 
 (defun widget-clear-undo ()
   "Clear all undo information."
   (buffer-disable-undo (current-buffer))
   (buffer-enable-undo))
 
 
 (defun widget-clear-undo ()
   "Clear all undo information."
   (buffer-disable-undo (current-buffer))
   (buffer-enable-undo))
 

+(defcustom widget-menu-max-size 40
+  "Largest number of items allowed in a popup-menu.
+Larger menus are read through the minibuffer."
+  :group 'widgets
+  :type 'integer)
+
+(defcustom widget-menu-max-shortcuts 40
+  "Largest number of items for which it works to choose one with a character.
+For a larger number of items, the minibuffer is used."
+  :group 'widgets
+  :type 'integer)
+
+(defcustom widget-menu-minibuffer-flag nil
+  "*Control how to ask for a choice from the keyboard.
+Non-nil means use the minibuffer;
+nil means read a single character."
+  :group 'widgets
+  :type 'boolean)
+

 (defun widget-choose (title items &optional event)
   "Choose an item from a list.
 
 First argument TITLE is the name of the list.
 (defun widget-choose (title items &optional event)
   "Choose an item from a list.
 
 First argument TITLE is the name of the list.

-Second argument ITEMS is an list whose members are either
+Second argument ITEMS is a list whose members are either

  (NAME . VALUE), to indicate selectable items, or just strings to
  indicate unselectable items.
 Optional third argument EVENT is an input event.
  (NAME . VALUE), to indicate selectable items, or just strings to
  indicate unselectable items.
 Optional third argument EVENT is an input event.


@@ -194,262 +210,245 @@ mouse event, and the number of elements in items is less than
 `widget-menu-max-size', a popup menu will be used, otherwise the
 minibuffer."
   (cond ((and (< (length items) widget-menu-max-size)
 `widget-menu-max-size', a popup menu will be used, otherwise the
 minibuffer."
   (cond ((and (< (length items) widget-menu-max-size)

-             event (fboundp 'x-popup-menu) window-system)
-        ;; We are in Emacs-19, pressed by the mouse
+             event (display-popup-menus-p))
+        ;; Mouse click.

         (x-popup-menu event
                       (list title (cons "" items))))
         (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))))
-       (t
-        (setq items (remove-if 'stringp items))
+       ((or widget-menu-minibuffer-flag
+            (> (length items) widget-menu-max-shortcuts))
+        ;; Read the choice of name from the minibuffer.
+        (setq items (widget-remove-if 'stringp 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))
         (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.
-This is only meaningful for radio buttons or checkboxes in a list."
-  (let* ((parent (widget-get widget :parent))
-        (children (widget-get parent :children))
-        child)
-    (catch 'child
-      (while children
-       (setq child (car children)
-             children (cdr children))
-       (when (eq (widget-get child :button) widget)
-         (throw 'child child)))
-      nil)))
-
-;;; Helper functions.
-;;
-;; These are widget specific.
-
-;;;###autoload
-(defun widget-prompt-value (widget prompt &optional value unbound)
-  "Prompt for a value matching WIDGET, using PROMPT.
-The current value is assumed to be VALUE, unless UNBOUND is non-nil."
-  (unless (listp widget)
-    (setq widget (list widget)))
-  (setq widget (widget-convert widget))
-  (let ((answer (widget-apply widget :prompt-value prompt value unbound)))
-    (unless (widget-apply widget :match answer)
-      (error "Value does not match %S type." (car widget)))
-    answer))
+                (cdr (assoc val items))))))
+       (t
+        ;; Construct a menu of the choices
+        ;; and then use it for prompting for a single character.
+        (let* ((overriding-terminal-local-map (make-sparse-keymap))
+               (next-digit ?0)
+               map choice some-choice-enabled value)
+          ;; Define SPC as a prefix char to get to this menu.
+          (define-key overriding-terminal-local-map " "
+            (setq map (make-sparse-keymap title)))
+          (with-current-buffer (get-buffer-create " widget-choose")
+            (erase-buffer)
+            (insert "Available choices:\n\n")
+            (while items
+              (setq choice (car items) items (cdr items))
+              (if (consp choice)
+                  (let* ((name (car choice))
+                        (function (cdr choice)))
+                    (insert (format "%c = %s\n" next-digit name))
+                    (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"))
+          (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 [?\M-\C-v] 'scroll-other-window)
+          (define-key map [?\M--] 'negative-argument)
+          (setcdr map (nreverse (cdr map)))
+          ;; Read a char with the menu, and return the result
+          ;; that corresponds to it.
+          (save-window-excursion
+            (let ((buf (get-buffer " widget-choose")))
+              (fit-window-to-buffer (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))))
+
+(defun widget-remove-if (predictate list)
+  (let (result (tail list))
+    (while tail
+      (or (funcall predictate (car tail))
+         (setq result (cons (car tail) result)))
+      (setq tail (cdr tail)))
+    (nreverse result)))

 
 ;;; Widget text specifications.
 
 ;;; Widget text specifications.

-;; 
-;; 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))
+;; We can set it to nil now that get_local_map uses get_pos_property.
+(defconst widget-field-add-space nil
+  "Non-nil means add extra space at the end of editable text fields.
+If you don't add the space, it will become impossible to edit a zero
+size field.")

 
 

-(defun widget-specify-text (from to)
-  ;; Default properties.
-  (add-text-properties from to (list 'read-only t
-                                    'front-sticky t
-                                    'start-open t
-                                    'end-open t
-                                    'rear-nonsticky nil)))
+(defvar widget-field-use-before-change t
+  "Non-nil means use `before-change-functions' to track editable fields.
+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.")

 
 (defun widget-specify-field (widget from to)
 
 (defun widget-specify-field (widget from to)

-  ;; Specify editable button for WIDGET between FROM and TO.
-  (widget-specify-field-update widget from to)
-
-  ;; 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))
-  (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
-    ;; before the field can be modified (e.g. if it belongs to a
-    ;; choice widget).  We try to compensate by checking the format
-    ;; string, and hope the user hasn't changed the :create method.
-    (widget-make-intangible (- from 2) from 'end-open))
-  
-  ;; Make it possible to edit back end of the field.
-  (add-text-properties to (1+ to) (list 'front-sticky nil
-                                       'read-only t
-                                       'start-open t))
-
-  (cond ((widget-get widget :size)
-        (put-text-property to (1+ to) 'invisible t)
-        (when (or (string-match "%v\\(.\\|\n\\)" (widget-get widget :format))
-                  (widget-get widget :hide-rear-space))
-          ;; WARNING: This is going to lose horrible if the character just
-          ;; after the field can be modified (e.g. if it belongs to a
-          ;; choice widget).  We try to compensate by checking the format
-          ;; string, and hope the user hasn't changed the :create method.
-          (widget-make-intangible to (+ to 2) 'start-open)))
-       ((string-match "XEmacs" emacs-version)
-        ;; XEmacs does not allow you to insert before a read-only
-        ;; character, even if it is start.open.
-        ;; XEmacs does allow you to delete an read-only extent, so
-        ;; making the terminating newline read only doesn't help.
-        ;; I tried putting an invisible intangible read-only space
-        ;; before the newline, which gave really weird effects.
-        ;; So for now, we just have trust the user not to delete the
-        ;; newline.  
-        (put-text-property to (1+ to) 'read-only nil))))
-
-(defun widget-specify-field-update (widget from to)
-  ;; Specify editable button for WIDGET between FROM and TO.
-  (let ((map (widget-get widget :keymap))
-       (secret (widget-get widget :secret))
-       (secret-to to)
-       (size (widget-get widget :size))
-       (face (or (widget-get widget :value-face)
-                 'widget-field-face))
+  "Specify editable button for WIDGET between FROM and TO."
+  ;; 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.
+  (save-excursion
+    (goto-char to)
+    (cond ((null (widget-get widget :size))
+          (forward-char 1))
+         (widget-field-add-space
+          (insert-and-inherit " ")))
+    (setq to (point)))
+  (let ((keymap (widget-get widget :keymap))
+       (face (or (widget-get widget :value-face) 'widget-field-face))

        (help-echo (widget-get widget :help-echo))
        (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))
+       (rear-sticky
+        (or (not widget-field-add-space) (widget-get widget :size))))
+    (if (functionp help-echo)

       (setq help-echo 'widget-mouse-help))
       (setq help-echo 'widget-mouse-help))

-
-    (when secret 
-      (while (and size
-                 (not (zerop size))
-                 (> secret-to from)
-                 (eq (char-after (1- secret-to)) ?\ ))
-       (setq secret-to (1- secret-to)))
-
-      (save-excursion
-       (goto-char from)
-       (while (< (point) secret-to)
-         (let ((old (get-text-property (point) 'secret)))
-           (when old
-             (subst-char-in-region (point) (1+ (point)) secret old)))
-         (forward-char))))
-
-    (set-text-properties from to (list 'field widget
-                                      'read-only nil
-                                      'keymap map
-                                      'local-map map
-                                      help-property help-echo
-                                      'face face))
-    
-    (when secret 
-      (save-excursion
-       (goto-char from)
-       (while (< (point) secret-to)
-         (let ((old (following-char)))
-           (subst-char-in-region (point) (1+ (point)) old secret)
-           (put-text-property (point) (1+ (point)) 'secret old))
-         (forward-char))))
-
-    (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))))
+    (when (= (char-before to) ?\n)
+      ;; When the last character in the field is a newline, we want to
+      ;; give it a `field' char-property of `boundary', which helps the
+      ;; C-n/C-p act more naturally when entering/leaving the field.  We
+     ;; do this by making a small secondary overlay to contain just that
+      ;; one character.
+      (let ((overlay (make-overlay (1- to) to nil t nil)))
+       (overlay-put overlay 'field 'boundary)
+       ;; Use `local-map' here, not `keymap', so that normal editing
+       ;; works in the field when, say, Custom uses `suppress-keymap'.
+       (overlay-put overlay 'local-map keymap)
+       (overlay-put overlay 'face face)
+       (overlay-put overlay 'help-echo help-echo))
+      (setq to (1- to))
+      (setq rear-sticky t))
+    (let ((overlay (make-overlay from to nil nil rear-sticky)))
+      (widget-put widget :field-overlay overlay)
+      ;;(overlay-put overlay 'detachable nil)
+      (overlay-put overlay 'field widget)
+      (overlay-put overlay 'local-map keymap)
+      (overlay-put overlay 'face face)
+      (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)
 
 (defun widget-specify-button (widget from to)

-  ;; Specify button for WIDGET between FROM and TO.
-  (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))
+  "Specify button for WIDGET between FROM and TO."
+  (let ((overlay (make-overlay from to nil t nil))
+       (help-echo (widget-get widget :help-echo)))
+    (widget-put widget :button-overlay overlay)
+    (if (functionp help-echo)

       (setq help-echo 'widget-mouse-help))
       (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)))))
+    (overlay-put overlay 'button widget)
+    (overlay-put overlay 'keymap (widget-get widget :keymap))
+    (overlay-put overlay 'evaporate t)
+    ;; We want to avoid the face with image buttons.
+    (unless (widget-get widget :suppress-face)
+      (overlay-put overlay 'face (widget-apply widget :button-face-get)))
+    (overlay-put overlay 'pointer 'hand)
+    (overlay-put overlay 'help-echo help-echo)))
+
+(defun widget-mouse-help (window overlay point)
+  "Help-echo callback for widgets whose :help-echo is a function."
+  (with-current-buffer (overlay-buffer overlay)
+    (let* ((widget (widget-at (overlay-start overlay)))
+          (help-echo (if widget (widget-get widget :help-echo))))
+      (if (functionp help-echo)
+         (funcall help-echo widget)
+       help-echo))))

 
 (defun widget-specify-sample (widget from 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)))))
+  "Specify sample for WIDGET between FROM and TO."
+  (let ((overlay (make-overlay from to nil t nil)))
+    (overlay-put overlay 'face (widget-apply widget :sample-face-get))
+    (overlay-put overlay 'evaporate t)
+    (widget-put widget :sample-overlay overlay)))

 
 (defun widget-specify-doc (widget from 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)))
+  "Specify documentation for WIDGET between FROM and TO."
+  (let ((overlay (make-overlay from to nil t nil)))
+    (overlay-put overlay 'widget-doc widget)
+    (overlay-put overlay 'face widget-documentation-face)
+    (overlay-put overlay 'evaporate t)
+    (widget-put widget :doc-overlay overlay)))

 
 (defmacro widget-specify-insert (&rest form)
 
 (defmacro widget-specify-insert (&rest form)

-  ;; Execute FORM without inheriting any text properties.
-  (`
-   (save-restriction
-     (let ((inhibit-read-only t)
-          result
-          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)))
-       (delete-region (1- (point-max)) (point-max))
-       (goto-char (point-max))
-       result))))
+  "Execute FORM without inheriting any text properties."
+  `(save-restriction
+    (let ((inhibit-read-only t)
+         (inhibit-modification-hooks t))
+      (narrow-to-region (point) (point))
+      (prog1 (progn ,@form)
+       (goto-char (point-max))))))

 
 (defface widget-inactive-face '((((class grayscale color)
                                  (background dark))
                                 (:foreground "light gray"))
                                (((class grayscale color)
                                  (background light))
 
 (defface widget-inactive-face '((((class grayscale color)
                                  (background dark))
                                 (:foreground "light gray"))
                                (((class grayscale color)
                                  (background light))

-                                (:foreground "dark gray"))
-                               (t 
-                                (:italic t)))
+                                (:foreground "dim gray"))
+                               (t
+                                (:slant italic)))

   "Face used for inactive widgets."
   "Face used for inactive widgets."

-  :group 'widgets)
+  :group 'widget-faces)

 
 (defun widget-specify-inactive (widget from to)
   "Make WIDGET inactive for user modifications."
   (unless (widget-get widget :inactive)
     (let ((overlay (make-overlay from to nil t nil)))
       (overlay-put overlay 'face 'widget-inactive-face)
 
 (defun widget-specify-inactive (widget from to)
   "Make WIDGET inactive for user modifications."
   (unless (widget-get widget :inactive)
     (let ((overlay (make-overlay from to nil t nil)))
       (overlay-put overlay 'face 'widget-inactive-face)

+      ;; This is disabled, as it makes the mouse cursor change shape.
+      ;; (overlay-put overlay 'mouse-face 'widget-inactive-face)

       (overlay-put overlay 'evaporate t)
       (overlay-put overlay 'priority 100)
       (overlay-put overlay 'evaporate t)
       (overlay-put overlay 'priority 100)

-      (overlay-put overlay (if (string-match "XEmacs" emacs-version)
-                              'read-only
-                            'modification-hooks) '(widget-overlay-inactive))
+      (overlay-put overlay 'modification-hooks '(widget-overlay-inactive))

       (widget-put widget :inactive overlay))))
 
 (defun widget-overlay-inactive (&rest junk)
   "Ignoring the arguments, signal an error."
   (unless inhibit-read-only
       (widget-put widget :inactive overlay))))
 
 (defun widget-overlay-inactive (&rest junk)
   "Ignoring the arguments, signal an error."
   (unless inhibit-read-only

-    (error "Attempt to modify inactive widget")))
+    (error "The widget here is not active")))

 
 
 (defun widget-specify-active (widget)
 
 
 (defun widget-specify-active (widget)


@@ -465,41 +464,32 @@ The current value is assumed to be VALUE, unless UNBOUND is non-nil."
   "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)
+;;;###autoload
+(defun widgetp (widget)
+  "Return non-nil iff WIDGET is a widget."
+  (if (symbolp widget)
+      (get widget 'widget-type)
+    (and (consp widget)
+        (symbolp (car widget))
+        (get (car widget) 'widget-type))))
+
+(defun widget-get-indirect (widget property)

   "In WIDGET, get the value of 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))
+If the value is a symbol, return its binding.
+Otherwise, just return the value."
+  (let ((value (widget-get widget property)))
+    (if (symbolp value)
+       (symbol-value value)
+      value)))

 
 (defun widget-member (widget property)
   "Non-nil iff there is a definition in WIDGET for PROPERTY."
 
 (defun widget-member (widget property)
   "Non-nil iff there is a definition in WIDGET for PROPERTY."

-  (cond ((widget-plist-member (cdr widget) property)
+  (cond ((plist-member (cdr widget) property)

         t)
        ((car widget)
         (widget-member (get (car widget) 'widget-type) property))
        (t nil)))
 
         t)
        ((car widget)
         (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


@@ -511,11 +501,17 @@ 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 external value of WIDGET."
+  (widget-apply widget :value-to-external
+               (or (widget-get widget :value)
+                   (widget-apply widget :default-get))))
+

 (defun widget-match-inline (widget vals)
 (defun widget-match-inline (widget vals)

-  ;; In WIDGET, match the start of VALS.
+  "In WIDGET, match the start of VALS."

   (cond ((widget-get widget :inline)
         (widget-apply widget :match-inline vals))
   (cond ((widget-get widget :inline)
         (widget-apply widget :match-inline vals))

-       ((and vals
+       ((and (listp vals)

              (widget-apply widget :match (car vals)))
         (cons (list (car vals)) (cdr vals)))
        (t nil)))
              (widget-apply widget :match (car vals)))
         (cons (list (car vals)) (cdr vals)))
        (t nil)))


@@ -526,75 +522,147 @@ ARGS are passed as extra arguments to the function."
       (widget-apply widget :action event)
     (error "Attempt to perform action on inactive widget")))
 
       (widget-apply widget :action event)
     (error "Attempt to perform action on inactive widget")))
 

-;;; Glyphs.
+;;; Helper functions.
+;;
+;; These are widget specific.
+
+;;;###autoload
+(defun widget-prompt-value (widget prompt &optional value unbound)
+  "Prompt for a value matching WIDGET, using PROMPT.
+The current value is assumed to be VALUE, unless UNBOUND is non-nil."
+  (unless (listp widget)
+    (setq widget (list widget)))
+  (setq prompt (format "[%s] %s" (widget-type widget) prompt))
+  (setq widget (widget-convert widget))
+  (let ((answer (widget-apply widget :prompt-value prompt value unbound)))
+    (unless (widget-apply widget :match answer)
+      (error "Value does not match %S type" (car widget)))
+    answer))
+
+(defun widget-get-sibling (widget)
+  "Get the item WIDGET is assumed to toggle.
+This is only meaningful for radio buttons or checkboxes in a list."
+  (let* ((children (widget-get (widget-get widget :parent) :children))
+        child)
+    (catch 'child
+      (while children
+       (setq child (car children)
+             children (cdr children))
+       (when (eq (widget-get child :button) widget)
+         (throw 'child child)))
+      nil)))

 
 

-(defcustom widget-glyph-directory (concat data-directory "custom/")
-  "Where widget glyphs are located.
+(defun widget-map-buttons (function &optional buffer maparg)
+  "Map FUNCTION over the buttons in BUFFER.
+FUNCTION is called with the arguments WIDGET and MAPARG.
+
+If FUNCTION returns non-nil, the walk is cancelled.
+
+The arguments MAPARG, and BUFFER default to nil and (current-buffer),
+respectively."
+  (let ((cur (point-min))
+       (widget nil)
+       (overlays (if buffer
+                     (with-current-buffer buffer (overlay-lists))
+                   (overlay-lists))))
+    (setq overlays (append (car overlays) (cdr overlays)))
+    (while (setq cur (pop overlays))
+      (setq widget (overlay-get cur 'button))
+      (if (and widget (funcall function widget maparg))
+         (setq overlays nil)))))
+
+;;; Images.
+
+(defcustom widget-image-directory (file-name-as-directory
+                                  (expand-file-name "custom" data-directory))
+  "Where widget button images are located.

 If this variable is nil, widget will try to locate the directory
 If this variable is nil, widget will try to locate the directory

-automatically. This does not work yet."
+automatically."

   :group 'widgets
   :type 'directory)
 
   :group 'widgets
   :type 'directory)
 

-(defcustom widget-glyph-enable t
-  "If non nil, use glyphs in images when available."
+(defcustom widget-image-enable t
+  "If non nil, use image buttons in widgets when available."
+  :version "21.1"

   :group 'widgets
   :type 'boolean)
 
   :group 'widgets
   :type 'boolean)
 

-(defun widget-glyph-insert (widget tag image)
-  "In WIDGET, insert the text TAG or, if supported, IMAGE.
-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 the user to be
-able to activate the glyph, make sure it is unique.  If you use the
-same glyph for multiple widgets, activating any of the glyphs will
-cause the last created widget to be activated."
-  (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))
+(defcustom widget-image-conversion
+  '((xpm ".xpm") (gif ".gif") (png ".png") (jpeg ".jpg" ".jpeg")
+    (xbm ".xbm"))
+  "Conversion alist from image formats to file name suffixes."
+  :group 'widgets
+  :type '(repeat (cons :format "%v"
+                      (symbol :tag "Image Format" unknown)
+                      (repeat :tag "Suffixes"
+                              (string :format "%v")))))
+
+(defun widget-image-find (image)
+  "Create a graphical button from IMAGE.
+IMAGE should either already be an image, or be a file name sans
+extension (xpm, xbm, gif, jpg, or png) located in
+`widget-image-directory' or otherwise where `find-image' will find it."
+  (cond ((not (and image widget-image-enable (display-graphic-p)))
+        ;; We don't want or can't use images.
+        nil)
+       ((and (consp image)
+             (eq 'image (car image)))
+        ;; Already an image spec.  Use it.
+        image)
+       ((stringp image)
+        ;; A string.  Look it up in relevant directories.
+        (let* ((load-path (cons widget-image-directory load-path))
+               specs)
+          (dolist (elt widget-image-conversion)
+            (dolist (ext (cdr elt))
+              (push (list :type (car elt) :file (concat image ext)) specs)))
+          (setq specs (nreverse specs))
+          (find-image specs)))

        (t
        (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."
-  (set-glyph-image glyph (cons 'tty tag))
-  (set-glyph-property glyph 'widget widget)
-  (insert "*")
-  (add-text-properties (1- (point)) (point) 
-                      (list 'invisible t
-                            '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))))))
+        ;; Oh well.
+        nil)))
+
+(defvar widget-button-pressed-face 'widget-button-pressed-face
+  "Face used for pressed buttons in widgets.
+This exists as a variable so it can be set locally in certain
+buffers.")
+
+(defun widget-image-insert (widget tag image &optional down inactive)
+  "In WIDGET, insert the text TAG or, if supported, IMAGE.
+IMAGE should either be an image or an image file name sans extension
+\(xpm, xbm, gif, jpg, or png) located in `widget-image-directory'.
+
+Optional arguments DOWN and INACTIVE are used instead of IMAGE when the
+button is pressed or inactive, respectively.  These are currently ignored."
+  (if (and (display-graphic-p)
+          (setq image (widget-image-find image)))
+      (progn (widget-put widget :suppress-face t)
+            (insert-image image
+                          (propertize
+                           tag 'mouse-face widget-button-pressed-face)))
+    (insert tag)))
+
+;;; Buttons.
+
+(defgroup widget-button nil
+  "The look of various kinds of buttons."
+  :group 'widgets)
+
+(defcustom widget-button-prefix ""
+  "String used as prefix for buttons."
+  :type 'string
+  :group 'widget-button)
+
+(defcustom widget-button-suffix ""
+  "String used as suffix for buttons."
+  :type 'string
+  :group 'widget-button)

 
 ;;; Creating Widgets.
 
 ;;;###autoload
 (defun widget-create (type &rest args)
 
 ;;; Creating Widgets.
 
 ;;;###autoload
 (defun widget-create (type &rest args)

-  "Create widget of TYPE.  
+  "Create widget of TYPE.

 The optional ARGS are additional keyword arguments."
   (let ((widget (apply 'widget-convert type args)))
     (widget-apply widget :create)
 The optional ARGS are additional keyword arguments."
   (let ((widget (apply 'widget-convert type args)))
     (widget-apply widget :create)


@@ -614,7 +682,7 @@ The child is converted, using the keyword arguments ARGS."
 
 (defun widget-create-child (parent type)
   "Create widget of TYPE."
 
 (defun widget-create-child (parent type)
   "Create widget of TYPE."

-  (let ((widget (copy-sequence type)))
+  (let ((widget (widget-copy type)))

     (widget-put widget :parent parent)
     (unless (widget-get widget :indent)
       (widget-put widget :indent (+ (or (widget-get parent :indent) 0)
     (widget-put widget :parent parent)
     (unless (widget-get widget :indent)
       (widget-put widget :indent (+ (or (widget-get parent :indent) 0)


@@ -625,7 +693,7 @@ The child is converted, using the keyword arguments ARGS."
 
 (defun widget-create-child-value (parent type value)
   "Create widget of TYPE with value VALUE."
 
 (defun widget-create-child-value (parent type value)
   "Create widget of TYPE with value VALUE."

-  (let ((widget (copy-sequence type)))
+  (let ((widget (widget-copy type)))

     (widget-put widget :value (widget-apply widget :value-to-internal value))
     (widget-put widget :parent parent)
     (unless (widget-get widget :indent)
     (widget-put widget :value (widget-apply widget :value-to-internal value))
     (widget-put widget :parent parent)
     (unless (widget-get widget :indent)


@@ -640,28 +708,44 @@ The child is converted, using the keyword arguments ARGS."
   "Delete WIDGET."
   (widget-apply widget :delete))
 
   "Delete WIDGET."
   (widget-apply widget :delete))
 

+(defun widget-copy (widget)
+  "Make a deep copy of WIDGET."
+  (widget-apply (copy-sequence widget) :copy))
+

 (defun widget-convert (type &rest args)
 (defun widget-convert (type &rest args)

-  "Convert TYPE to a widget without inserting it in the buffer. 
+  "Convert TYPE to a widget without inserting it in the buffer.

 The optional ARGS are additional keyword arguments."
   ;; Don't touch the type.
 The optional ARGS are additional keyword arguments."
   ;; Don't touch the type.

-  (let* ((widget (if (symbolp type) 
+  (let* ((widget (if (symbolp type)

                     (list type)
                   (copy-sequence type)))
         (current widget)
                     (list type)
                   (copy-sequence type)))
         (current widget)

+        done

         (keys args))
     ;; First set the :args keyword.
     (while (cdr current)               ;Look in the type.
         (keys args))
     ;; First set the :args keyword.
     (while (cdr current)               ;Look in the type.

-      (let ((next (car (cdr current))))
-       (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:))
-           (setq current (cdr (cdr current)))
-         (setcdr current (list :args (cdr current)))
-         (setq current nil))))
-    (while args                                ;Look in the args.
-      (let ((next (nth 0 args)))
-       (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:))
-           (setq args (nthcdr 2 args))
-         (widget-put widget :args args)
-         (setq args nil))))
+      (if (and (keywordp (cadr current))
+              ;; If the last element is a keyword,
+              ;; it is still the :args element,
+              ;; even though it is a keyword.
+              (cddr current))
+         (if (eq (cadr current) :args)
+             ;; If :args is explicitly specified, obey it.
+             (setq current nil)
+           ;; Some other irrelevant keyword.
+           (setq current (cdr (cdr current))))
+       (setcdr current (list :args (cdr current)))
+       (setq current nil)))
+    (while (and args (not done))       ;Look in ARGS.
+      (cond ((eq (car args) :args)
+            ;; Handle explicit specification of :args.
+            (setq args (cadr args)
+                  done t))
+           ((keywordp (car args))
+            (setq args (cddr args)))
+           (t (setq done t))))
+    (when done
+      (widget-put widget :args args))

     ;; Then Convert the widget.
     (setq type widget)
     (while type
     ;; Then Convert the widget.
     (setq type widget)
     (while type


@@ -670,201 +754,287 @@ The optional ARGS are additional keyword arguments."
            (setq widget (funcall convert-widget widget))))
       (setq type (get (car type) 'widget-type)))
     ;; Finally set the keyword args.
            (setq widget (funcall convert-widget widget))))
       (setq type (get (car type) 'widget-type)))
     ;; Finally set the keyword args.

-    (while keys 
+    (while keys

       (let ((next (nth 0 keys)))
       (let ((next (nth 0 keys)))

-       (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:))
-           (progn 
+       (if (keywordp next)
+           (progn

              (widget-put widget next (nth 1 keys))
              (setq keys (nthcdr 2 keys)))
          (setq keys nil))))
     ;; Convert the :value to internal format.
     (if (widget-member widget :value)
              (widget-put widget next (nth 1 keys))
              (setq keys (nthcdr 2 keys)))
          (setq keys nil))))
     ;; Convert the :value to internal format.
     (if (widget-member widget :value)

-       (let ((value (widget-get widget :value)))
-         (widget-put widget
-                     :value (widget-apply widget :value-to-internal value))))
+       (widget-put widget
+                   :value (widget-apply widget
+                                        :value-to-internal
+                                        (widget-get widget :value))))

     ;; Return the newly create widget.
     widget))
 
     ;; Return the newly create widget.
     widget))
 

+;;;###autoload

 (defun widget-insert (&rest args)
 (defun widget-insert (&rest args)

-  "Call `insert' with ARGS and make the text read only."
+  "Call `insert' with ARGS even if surrounding text is read only."

   (let ((inhibit-read-only t)
   (let ((inhibit-read-only t)

-       after-change-functions
-       (from (point)))
-    (apply 'insert args)
-    (widget-specify-text from (point))))
+       (inhibit-modification-hooks t))
+    (apply 'insert args)))
+
+(defun widget-convert-text (type from to
+                                &optional button-from button-to
+                                &rest args)
+  "Return a widget of type TYPE with endpoint FROM TO.
+Optional ARGS are extra keyword arguments for TYPE.
+and TO will be used as the widgets end points. If optional arguments
+BUTTON-FROM and BUTTON-TO are given, these will be used as the widgets
+button end points.
+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)))
+    (set-marker-insertion-type from t)
+    (set-marker-insertion-type to nil)
+    (widget-put widget :from from)
+    (widget-put widget :to to)
+    (when button-from
+      (widget-specify-button widget button-from button-to))
+    widget))
+
+(defun widget-convert-button (type from to &rest args)
+  "Return a widget of type TYPE with endpoint FROM TO.
+Optional ARGS are extra keyword arguments for TYPE.
+No text will be inserted to the buffer, instead the text between FROM
+and TO will be used as the widgets end points, as well as the widgets
+button end points."
+  (apply 'widget-convert-text type from to from to args))
+
+(defun widget-leave-text (widget)
+  "Remove markers and overlays from WIDGET and its children."
+  (let ((button (widget-get widget :button-overlay))
+       (sample (widget-get widget :sample-overlay))
+       (doc (widget-get widget :doc-overlay))
+       (field (widget-get widget :field-overlay)))
+    (set-marker (widget-get widget :from) nil)
+    (set-marker (widget-get widget :to) nil)
+    (when button
+      (delete-overlay button))
+    (when sample
+      (delete-overlay sample))
+    (when doc
+      (delete-overlay doc))
+    (when field
+      (delete-overlay field))
+    (mapc 'widget-leave-text (widget-get widget :children))))

 
 ;;; Keymap and Commands.
 
 
 ;;; Keymap and Commands.
 

-(defvar widget-keymap nil
+;;;###autoload
+(defvar widget-keymap
+  (let ((map (make-sparse-keymap)))
+    (define-key map "\t" 'widget-forward)
+    (define-key map [(shift tab)] 'widget-backward)
+    (define-key map [backtab] 'widget-backward)
+    (define-key map [down-mouse-2] 'widget-button-click)
+    (define-key map "\C-m" 'widget-button-press)
+    map)

   "Keymap containing useful binding for buffers containing widgets.
 Recommended as a parent keymap for modes using widgets.")
 
   "Keymap containing useful binding for buffers containing widgets.
 Recommended as a parent keymap for modes using widgets.")
 

-(unless widget-keymap 
-  (setq widget-keymap (make-sparse-keymap))
-  (define-key widget-keymap "\C-k" 'widget-kill-line)
-  (define-key widget-keymap "\t" 'widget-forward)
-  (define-key widget-keymap "\M-\t" 'widget-backward)
-  (define-key widget-keymap [(shift tab)] 'widget-backward)
-  (define-key widget-keymap [backtab] 'widget-backward)
-  (if (string-match "XEmacs" (emacs-version))
-      (progn 
-       (define-key widget-keymap [button2] 'widget-button-click)
-       (define-key widget-keymap [button1] 'widget-button1-click))
-    (define-key widget-keymap [mouse-2] 'ignore)
-    (define-key widget-keymap [down-mouse-2] 'widget-button-click))
-  (define-key widget-keymap "\C-m" 'widget-button-press))
-

 (defvar widget-global-map global-map
 (defvar widget-global-map global-map

-  "Keymap used for events the widget does not handle themselves.")
+  "Keymap used for events a widget does not handle itself.")

 (make-variable-buffer-local 'widget-global-map)
 
 (make-variable-buffer-local 'widget-global-map)
 

-(defvar widget-field-keymap nil
+(defvar widget-field-keymap
+  (let ((map (copy-keymap widget-keymap)))
+    (define-key map "\C-k" 'widget-kill-line)
+    (define-key map "\M-\t" 'widget-complete)
+    (define-key map "\C-m" 'widget-field-activate)
+    ;; Since the widget code uses a `field' property to identify fields,
+    ;; ordinary beginning-of-line does the right thing.
+    ;;  (define-key map "\C-a" 'widget-beginning-of-line)
+    (define-key map "\C-e" 'widget-end-of-line)
+    map)

   "Keymap used inside an editable field.")
 
   "Keymap used inside an editable field.")
 

-(unless widget-field-keymap 
-  (setq widget-field-keymap (copy-keymap widget-keymap))
-  (unless (string-match "XEmacs" (emacs-version))
-    (define-key widget-field-keymap [menu-bar] 'nil))
-  (define-key widget-field-keymap "\C-m" 'widget-field-activate)
-  (define-key widget-field-keymap "\C-a" 'widget-beginning-of-line)
-  (define-key widget-field-keymap "\C-e" 'widget-end-of-line)
-  (set-keymap-parent widget-field-keymap global-map))
-
-(defvar widget-text-keymap nil
+(defvar widget-text-keymap
+  (let ((map (copy-keymap widget-keymap)))
+    ;; Since the widget code uses a `field' property to identify fields,
+    ;; ordinary beginning-of-line does the right thing.
+    ;;  (define-key map "\C-a" 'widget-beginning-of-line)
+    (define-key map "\C-e" 'widget-end-of-line)
+    map)

   "Keymap used inside a text field.")
 
   "Keymap used inside a text field.")
 

-(unless widget-text-keymap 
-  (setq widget-text-keymap (copy-keymap widget-keymap))
-  (unless (string-match "XEmacs" (emacs-version))
-    (define-key widget-text-keymap [menu-bar] 'nil))
-  (define-key widget-text-keymap "\C-a" 'widget-beginning-of-line)
-  (define-key widget-text-keymap "\C-e" 'widget-end-of-line)
-  (set-keymap-parent widget-text-keymap global-map))
-

 (defun widget-field-activate (pos &optional event)
 (defun widget-field-activate (pos &optional event)

-  "Activate the ediable field at point."
+  "Invoke the editable field at point."

   (interactive "@d")
   (interactive "@d")

-  (let ((field (get-text-property pos 'field)))
+  (let ((field (widget-field-at pos)))

     (if field
        (widget-apply-action field event)
       (call-interactively
        (lookup-key widget-global-map (this-command-keys))))))
 
     (if field
        (widget-apply-action field event)
       (call-interactively
        (lookup-key widget-global-map (this-command-keys))))))
 

+(defface widget-button-pressed-face
+  '((((class color))
+     (:foreground "red"))
+    (t
+     (:weight bold :underline t)))
+  "Face used for pressed buttons."
+  :group 'widget-faces)
+

 (defun widget-button-click (event)
 (defun widget-button-click (event)

-  "Activate button below mouse pointer."
-  (interactive "@e")
-  (cond ((and (fboundp 'event-glyph)
-             (event-glyph event))
-        (let ((widget (glyph-property (event-glyph event) 'widget)))
-          (if widget
-              (widget-apply-action widget event)
-            (message "You clicked on a glyph."))))
-       ((event-point event)
-        (let ((button (get-text-property (event-point event) 'button)))
-          (if button
-              (widget-apply-action button event)
-            (call-interactively 
-             (or (lookup-key widget-global-map [ button2 ])
-                 (lookup-key widget-global-map [ down-mouse-2 ])
-                 (lookup-key widget-global-map [ mouse-2]))))))
-       (t
-        (message "You clicked somewhere weird."))))
-
-(defun widget-button1-click (event)
-  "Activate glyph below mouse pointer."
-  (interactive "@e")
-  (if (and (fboundp 'event-glyph)
-          (event-glyph event))
-      (let ((widget (glyph-property (event-glyph event) 'widget)))
-       (if widget
-           (widget-apply-action widget event)
-         (message "You clicked on a glyph.")))
-    (call-interactively (lookup-key widget-global-map (this-command-keys)))))
+  "Invoke the button that the mouse is pointing at."
+  (interactive "e")
+  (if (widget-event-point event)
+      (let* ((pos (widget-event-point event))
+            (start (event-start event))
+            (button (get-char-property
+                     pos 'button (and (windowp (posn-window start))
+                                      (window-buffer (posn-window start))))))
+       (if button
+           ;; Mouse click on a widget button.  Do the following
+           ;; in a save-excursion so that the click on the button
+           ;; doesn't change point.
+           (save-selected-window
+             (select-window (posn-window (event-start event)))
+             (save-excursion
+               (goto-char (posn-point (event-start event)))
+               (let* ((overlay (widget-get button :button-overlay))
+                      (face (overlay-get overlay 'face))
+                      (mouse-face (overlay-get overlay 'mouse-face)))
+                 (unwind-protect
+                     ;; Read events, including mouse-movement events
+                     ;; until we receive a release event.  Highlight/
+                     ;; unhighlight the button the mouse was initially
+                     ;; on when we move over it.
+                     (let ((track-mouse t))
+                       (save-excursion
+                         (when face    ; avoid changing around image
+                           (overlay-put overlay
+                                        'face widget-button-pressed-face)
+                           (overlay-put overlay
+                                        'mouse-face widget-button-pressed-face))
+                         (unless (widget-apply button :mouse-down-action event)
+                           (while (not (widget-button-release-event-p event))
+                             (setq event (read-event)
+                                   pos (widget-event-point event))
+                             (if (and pos
+                                      (eq (get-char-property pos 'button)
+                                          button))
+                                 (when face
+                                   (overlay-put overlay
+                                                'face
+                                                widget-button-pressed-face)
+                                   (overlay-put overlay
+                                                'mouse-face
+                                                widget-button-pressed-face))
+                               (overlay-put overlay 'face face)
+                               (overlay-put overlay 'mouse-face mouse-face))))
+
+                         ;; When mouse is released over the button, run
+                         ;; its action function.
+                         (when (and pos
+                                    (eq (get-char-property pos 'button) button))
+                           (widget-apply-action button event))))
+                   (overlay-put overlay 'face face)
+                   (overlay-put overlay 'mouse-face mouse-face))))
+
+             (unless (pos-visible-in-window-p (widget-event-point event))
+               (mouse-set-point event)
+               (beginning-of-line)
+               (recenter))
+             )
+
+           (let ((up t) command)
+             ;; Mouse click not on a widget button.  Find the global
+             ;; command to run, and check whether it is bound to an
+             ;; up event.
+             (mouse-set-point event)
+             (if (memq (event-basic-type event) '(mouse-1 down-mouse-1))
+                 (cond ((setq command  ;down event
+                              (lookup-key widget-global-map [down-mouse-1]))
+                        (setq up nil))
+                       ((setq command  ;up event
+                              (lookup-key widget-global-map [mouse-1]))))
+               (cond ((setq command    ;down event
+                            (lookup-key widget-global-map [down-mouse-2]))
+                      (setq up nil))
+                     ((setq command    ;up event
+                            (lookup-key widget-global-map [mouse-2])))))
+             (when up
+               ;; Don't execute up events twice.
+               (while (not (widget-button-release-event-p event))
+                 (setq event (read-event))))
+             (when command
+               (call-interactively command)))))
+    (message "You clicked somewhere weird.")))

 
 (defun widget-button-press (pos &optional event)
 
 (defun widget-button-press (pos &optional event)

-  "Activate button at POS."
+  "Invoke button at POS."

   (interactive "@d")
   (interactive "@d")

-  (let ((button (get-text-property pos 'button)))
+  (let ((button (get-char-property pos 'button)))

     (if button
        (widget-apply-action button event)
       (let ((command (lookup-key widget-global-map (this-command-keys))))
        (when (commandp command)
          (call-interactively command))))))
 
     (if button
        (widget-apply-action button event)
       (let ((command (lookup-key widget-global-map (this-command-keys))))
        (when (commandp command)
          (call-interactively command))))))
 

+(defun widget-tabable-at (&optional pos)
+  "Return the tabable widget at POS, or nil.
+POS defaults to the value of (point)."
+  (let ((widget (widget-at pos)))
+    (if widget
+       (let ((order (widget-get widget :tab-order)))
+         (if order
+             (if (>= order 0)
+                 widget)
+           widget)))))
+
+(defvar widget-use-overlay-change t
+  "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.")
+

 (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."

-  (while (> arg 0)
-    (setq arg (1- arg))
-    (let ((next (cond ((get-text-property (point) 'button)
-                      (next-single-property-change (point) 'button))
-                     ((get-text-property (point) 'field)
-                      (next-single-property-change (point) 'field))
-                     (t
-                      (point)))))
-      (if (null next)                  ; Widget extends to end. of buffer
-         (setq next (point-min)))
-      (let ((button (next-single-property-change next 'button))
-           (field (next-single-property-change next 'field)))
-       (cond ((or (get-text-property next 'button)
-                  (get-text-property next 'field))
-              (goto-char next))
-             ((and button field)
-              (goto-char (min button field)))
-             (button (goto-char button))
-             (field (goto-char field))
-             (t
-              (let ((button (next-single-property-change (point-min) 'button))
-                    (field (next-single-property-change (point-min) 'field)))
-                (cond ((and button field) (goto-char (min button field)))
-                      (button (goto-char button))
-                      (field (goto-char field))
-                      (t
-                       (error "No buttons or fields found"))))))
-       (setq button (widget-at (point)))
-       (if (or (and button (widget-get button :tab-order)
-                    (< (widget-get button :tab-order) 0))
-               (and button (not (widget-apply button :active))))
+  (or (bobp) (> arg 0) (backward-char))
+  (let ((wrapped 0)
+       (number arg)
+       (old (widget-tabable-at)))
+    ;; Forward.
+    (while (> arg 0)
+      (cond ((eobp)
+            (goto-char (point-min))
+            (setq wrapped (1+ wrapped)))
+           (widget-use-overlay-change
+            (goto-char (next-overlay-change (point))))
+           (t
+            (forward-char 1)))
+      (and (= wrapped 2)
+          (eq arg number)
+          (error "No buttons or fields found"))
+      (let ((new (widget-tabable-at)))
+       (when new
+         (unless (eq new old)
+           (setq arg (1- arg))
+           (setq old new)))))
+    ;; Backward.
+    (while (< arg 0)
+      (cond ((bobp)
+            (goto-char (point-max))
+            (setq wrapped (1+ wrapped)))
+           (widget-use-overlay-change
+            (goto-char (previous-overlay-change (point))))
+           (t
+            (backward-char 1)))
+      (and (= wrapped 2)
+          (eq arg number)
+          (error "No buttons or fields found"))
+      (let ((new (widget-tabable-at)))
+       (when new
+         (unless (eq new old)

            (setq arg (1+ arg))))))
            (setq arg (1+ arg))))))

-  (while (< arg 0)
-    (if (= (point-min) (point))
-       (forward-char 1))
-    (setq arg (1+ arg))
-    (let ((previous (cond ((get-text-property (1- (point)) 'button)
-                          (previous-single-property-change (point) 'button))
-                         ((get-text-property (1- (point)) 'field)
-                          (previous-single-property-change (point) 'field))
-                         (t
-                          (point)))))
-      (if (null previous)              ; Widget extends to beg. of buffer
-         (setq previous (point-max)))
-      (let ((button (previous-single-property-change previous 'button))
-           (field (previous-single-property-change previous 'field)))
-       (cond ((and button field)
-              (goto-char (max button field)))
-             (button (goto-char button))
-             (field (goto-char field))
-             (t
-              (let ((button (previous-single-property-change
-                             (point-max) 'button))
-                    (field (previous-single-property-change
-                            (point-max) 'field)))
-                (cond ((and button field) (goto-char (max button field)))
-                      (button (goto-char button))
-                      (field (goto-char field))
-                      (t
-                       (error "No buttons or fields found"))))))))
-    (let ((button (previous-single-property-change (point) 'button))
-         (field (previous-single-property-change (point) 'field)))
-      (cond ((and button field)
-            (goto-char (max button field)))
-           (button (goto-char button))
-           (field (goto-char field)))
-      (setq button (widget-at (point)))
-      (if (or (and button (widget-get button :tab-order)
-                  (< (widget-get button :tab-order) 0))
-             (and button (not (widget-apply button :active))))
-         (setq arg (1- arg)))))
+    (let ((new (widget-tabable-at)))
+      (while (eq (widget-tabable-at) new)
+       (backward-char)))
+    (forward-char))

   (widget-echo-help (point))
   (run-hooks 'widget-move-hook))
 
   (widget-echo-help (point))
   (run-hooks 'widget-move-hook))
 


@@ -882,60 +1052,90 @@ With optional ARG, move across that many fields."
   (run-hooks 'widget-backward-hook)
   (widget-move (- arg)))
 
   (run-hooks 'widget-backward-hook)
   (widget-move (- arg)))
 

-(defun widget-beginning-of-line ()
-  "Go to beginning of field or beginning of line, whichever is first."
-  (interactive)
-  (let ((bol (save-excursion (beginning-of-line) (point)))
-       (prev (previous-single-property-change (point) 'field)))
-    (goto-char (max bol (or prev bol)))))
+;; Since the widget code uses a `field' property to identify fields,
+;; ordinary beginning-of-line does the right thing.
+(defalias 'widget-beginning-of-line 'beginning-of-line)

 
 (defun widget-end-of-line ()
 
 (defun widget-end-of-line ()

-  "Go to end of field or end of line, whichever is first."
+  "Go to end of field or end of line, whichever is first.
+Trailing spaces at the end of padded fields are not considered part of
+the field."

   (interactive)
   (interactive)

-  (let ((bol (save-excursion (end-of-line) (point)))
-       (prev (next-single-property-change (point) 'field)))
-    (goto-char (min bol (or prev bol)))))
+  ;; Ordinary end-of-line does the right thing, because we're inside
+  ;; text with a `field' property.
+  (end-of-line)
+  (unless (eolp)
+    ;; ... except that we want to ignore trailing spaces in fields that
+    ;; aren't terminated by a newline, because they are used as padding,
+    ;; and ignored when extracting the entered value of the field.
+    (skip-chars-backward " " (field-beginning (1- (point))))))

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

-  (let ((field (get-text-property (point) 'field))
-       (newline (save-excursion (search-forward "\n")))
-       (next (next-single-property-change (point) 'field)))
-    (if (and field (> newline next))
-       (kill-region (point) next)
+  (let* ((field (widget-field-find (point)))
+        (end (and field (widget-field-end field))))
+    (if (and field (> (line-beginning-position 2) end))
+       (kill-region (point) end)

       (call-interactively 'kill-line))))
 
       (call-interactively 'kill-line))))
 

+(defcustom widget-complete-field (lookup-key global-map "\M-\t")
+  "Default function to call for completion inside fields."
+  :options '(ispell-complete-word complete-tag lisp-complete-symbol)
+  :type 'function
+  :group 'widgets)
+
+(defun widget-narrow-to-field ()
+  "Narrow to field"
+  (interactive)
+  (let ((field (widget-field-find (point))))
+    (if field
+       (narrow-to-region (line-beginning-position) (line-end-position)))))
+
+(defun widget-complete ()
+  "Complete content of editable field from point.
+When not inside a field, move to the previous button or field."
+  (interactive)
+  (let ((field (widget-field-find (point))))
+    (if field
+       (save-restriction
+         (widget-narrow-to-field)
+         (widget-apply field :complete))
+         (error "Not in an editable field"))))
+

 ;;; Setting up the buffer.
 
 ;;; Setting up the buffer.
 

-(defvar widget-field-new nil)
-;; List of all newly created editable fields in the buffer.
+(defvar widget-field-new nil
+  "List of all newly created editable fields in the buffer.")

 (make-variable-buffer-local 'widget-field-new)
 
 (make-variable-buffer-local 'widget-field-new)
 

-(defvar widget-field-list nil)
-;; List of all editable fields in the buffer.
+(defvar widget-field-list nil
+  "List of all editable fields in the buffer.")

 (make-variable-buffer-local 'widget-field-list)
 
 (make-variable-buffer-local 'widget-field-list)
 

+(defun widget-at (&optional pos)
+  "The button or field at POS (default, point)."
+  (or (get-char-property (or pos (point)) 'button)
+      (widget-field-at pos)))
+
+;;;###autoload

 (defun widget-setup ()
   "Setup current buffer so editing string widgets works."
   (let ((inhibit-read-only t)
 (defun widget-setup ()
   "Setup current buffer so editing string widgets works."
   (let ((inhibit-read-only t)

-       (after-change-functions nil)
+       (inhibit-modification-hooks t)

        field)
     (while widget-field-new
       (setq field (car widget-field-new)
            widget-field-new (cdr widget-field-new)
            widget-field-list (cons field widget-field-list))
        field)
     (while widget-field-new
       (setq field (car widget-field-new)
            widget-field-new (cdr widget-field-new)
            widget-field-list (cons field widget-field-list))

-      (let ((from (widget-get field :value-from))
-           (to (widget-get field :value-to)))
-       (widget-specify-field field from to)
-       (move-marker from (1- from))
-       (move-marker to (1+ to)))))
+      (let ((from (car (widget-get field :field-overlay)))
+           (to (cdr (widget-get field :field-overlay))))
+       (widget-specify-field field
+                             (marker-position from) (marker-position to))
+       (set-marker from nil)
+       (set-marker to nil))))

   (widget-clear-undo)
   (widget-clear-undo)

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

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


@@ -945,111 +1145,243 @@ With optional ARG, move across that many fields."
 ;; The widget data before the change.
 (make-variable-buffer-local 'widget-field-was)
 
 ;; The widget data before the change.
 (make-variable-buffer-local 'widget-field-was)
 

+(defun widget-field-at (pos)
+  "Return the widget field at POS, or nil if none."
+  (let ((field (get-char-property (or pos (point)) 'field)))
+    (if (eq field 'boundary)
+       nil
+      field)))
+
+(defun widget-field-buffer (widget)
+  "Return the buffer of WIDGET's editing field."
+  (let ((overlay (widget-get widget :field-overlay)))
+    (cond ((overlayp overlay)
+          (overlay-buffer overlay))
+         ((consp overlay)
+          (marker-buffer (car overlay))))))
+
+(defun widget-field-start (widget)
+  "Return the start of WIDGET's editing field."
+  (let ((overlay (widget-get widget :field-overlay)))
+    (if (overlayp overlay)
+       (overlay-start overlay)
+      (car overlay))))
+
+(defun widget-field-end (widget)
+  "Return the end of WIDGET's editing field."
+  (let ((overlay (widget-get widget :field-overlay)))
+    ;; Don't subtract one if local-map works at the end of the overlay,
+    ;; or if a special `boundary' field has been added after the widget
+    ;; field.
+    (if (overlayp overlay)
+       (if (and (not (eq (get-char-property (overlay-end overlay)
+                                            'field
+                                            (widget-field-buffer widget))
+                         'boundary))
+                (or widget-field-add-space
+                    (null (widget-get widget :size))))
+           (1- (overlay-end overlay))
+         (overlay-end overlay))
+      (cdr overlay))))
+

 (defun widget-field-find (pos)
 (defun widget-field-find (pos)

-  ;; Find widget whose editing field is located at POS.
-  ;; Return nil if POS is not inside and editing field.
-  ;; 
-  ;; This is only used in `widget-field-modified', since ordinarily
-  ;; you would just test the field property.
+  "Return the field at POS.
+Unlike (get-char-property POS 'field) this, works with empty fields too."

   (let ((fields widget-field-list)
        field found)
     (while fields
       (setq field (car fields)
            fields (cdr fields))
   (let ((fields widget-field-list)
        field found)
     (while fields
       (setq field (car fields)
            fields (cdr fields))

-      (let ((from (widget-get field :value-from))
-           (to (widget-get field :value-to)))
-       (if (and from to (< from pos) (> to  pos))
-           (setq fields nil
-                 found field))))
+      (when (and (<= (widget-field-start field) pos)
+                (<= pos (widget-field-end field)))
+       (when found
+         (error "Overlapping fields"))
+       (setq found field)))

     found))
 
     found))
 

+(defun widget-before-change (from to)
+  ;; This is how, for example, a variable changes its state to `modified'.
+  ;; when it is being edited.
+  (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)
+            (signal 'text-read-only
+                    '("Change should be restricted to a single field")))
+           ((null from-field)
+            (add-hook 'post-command-hook 'widget-add-change nil t)
+            (signal 'text-read-only
+                    '("Attempt to change text outside editable field")))
+           (widget-field-use-before-change
+            (widget-apply from-field :notify from-field))))))
+
+(defun widget-add-change ()
+  (remove-hook 'post-command-hook 'widget-add-change t)
+  (add-hook 'before-change-functions 'widget-before-change nil t)
+  (add-hook 'after-change-functions 'widget-after-change nil t))
+

 (defun widget-after-change (from to old)
 (defun widget-after-change (from to old)

-  ;; Adjust field size and text properties.
-  (condition-case nil
-      (let ((field (widget-field-find from))
-           (inhibit-read-only t))
-       (cond ((null field))
-             ((not (eq field (widget-field-find to)))
-              (debug)
-              (message "Error: `widget-after-change' called on two fields"))
-             (t
-              (let ((size (widget-get field :size)))
-                (if size 
-                    (let ((begin (1+ (widget-get field :value-from)))
-                          (end (1- (widget-get field :value-to))))
-                      (widget-specify-field-update field begin end)
-                      (cond ((< (- end begin) size)
-                             ;; Field too small.
-                             (save-excursion
-                               (goto-char end)
-                               (insert-char ?\  (- (+ begin size) end))
-                               (widget-specify-field-update field 
-                                                            begin
-                                                            (+ begin size))))
-                            ((> (- end begin) size)
-                             ;; Field too large and
-                             (if (or (< (point) (+ begin size))
-                                     (> (point) end))
-                                 ;; Point is outside extra space.
-                                 (setq begin (+ begin size))
-                               ;; Point is within the extra space.
-                               (setq begin (point)))
-                             (save-excursion
-                               (goto-char end)
-                               (while (and (eq (preceding-char) ?\ )
-                                           (> (point) begin))
-                                 (delete-backward-char 1))))))
-                  (widget-specify-field-update field from to)))
-              (widget-apply field :notify field))))
-    (error (debug))))
+  "Adjust field size and text properties."
+  (let ((field (widget-field-find from))
+       (other (widget-field-find to)))
+    (when field
+      (unless (eq field other)
+       (error "Change in different fields"))
+      (let ((size (widget-get field :size)))
+       (when size
+         (let ((begin (widget-field-start field))
+               (end (widget-field-end field)))
+           (cond ((< (- end begin) size)
+                  ;; Field too small.
+                  (save-excursion
+                    (goto-char end)
+                    (insert-char ?\  (- (+ begin size) end))))
+                 ((> (- end begin) size)
+                  ;; Field too large and
+                  (if (or (< (point) (+ begin size))
+                          (> (point) end))
+                      ;; Point is outside extra space.
+                      (setq begin (+ begin size))
+                    ;; Point is within the extra space.
+                    (setq begin (point)))
+                  (save-excursion
+                    (goto-char end)
+                    (while (and (eq (preceding-char) ?\ )
+                                (> (point) begin))
+                      (delete-backward-char 1)))))))
+       (widget-specify-secret field))
+      (widget-apply field :notify field))))

 
 ;;; Widget Functions
 ;;
 
 ;;; Widget Functions
 ;;

-;; These functions are used in the definition of multiple widgets. 
+;; These functions are used in the definition of multiple widgets.
+
+(defun widget-parent-action (widget &optional event)
+  "Tell :parent of WIDGET to handle the :action.
+Optional EVENT is the event that triggered the action."
+  (widget-apply (widget-get widget :parent) :action event))

 
 (defun widget-children-value-delete (widget)
   "Delete all :children and :buttons in WIDGET."
 
 (defun widget-children-value-delete (widget)
   "Delete all :children and :buttons in WIDGET."

-  (mapcar 'widget-delete (widget-get widget :children))
+  (mapc 'widget-delete (widget-get widget :children))

   (widget-put widget :children nil)
   (widget-put widget :children nil)

-  (mapcar 'widget-delete (widget-get widget :buttons))
+  (mapc 'widget-delete (widget-get widget :buttons))

   (widget-put widget :buttons nil))
 
   (widget-put widget :buttons nil))
 

-(defun widget-types-convert-widget (widget)
+(defun widget-children-validate (widget)
+  "All the :children must be valid."
+  (let ((children (widget-get widget :children))
+       child found)
+    (while (and children (not found))
+      (setq child (car children)
+           children (cdr children)
+           found (widget-apply child :validate)))
+    found))
+
+(defun widget-child-value-get (widget)
+  "Get the value of the first member of :children in WIDGET."
+  (widget-value (car (widget-get widget :children))))
+
+(defun widget-child-value-inline (widget)
+  "Get the inline value of the first member of :children in WIDGET."
+  (widget-apply (car (widget-get widget :children)) :value-inline))
+
+(defun widget-child-validate (widget)
+  "The result of validating the first member of :children in WIDGET."
+  (widget-apply (car (widget-get widget :children)) :validate))
+
+(defun widget-type-value-create (widget)
+  "Convert and instantiate the value of the :type attribute of WIDGET.
+Store the newly created widget in the :children attribute.
+
+The value of the :type attribute should be an unconverted widget type."
+  (let ((value (widget-get widget :value))
+       (type (widget-get widget :type)))
+    (widget-put widget :children
+                (list (widget-create-child-value widget
+                                                 (widget-convert type)
+                                                 value)))))
+
+(defun widget-type-default-get (widget)
+  "Get default value from the :type attribute of WIDGET.
+
+The value of the :type attribute should be an unconverted widget type."
+  (widget-default-get (widget-convert (widget-get widget :type))))
+
+(defun widget-type-match (widget value)
+  "Non-nil if the :type value of WIDGET matches VALUE.
+
+The value of the :type attribute should be an unconverted widget type."
+  (widget-apply (widget-convert (widget-get widget :type)) :match value))
+
+(defun widget-types-copy (widget)
+  "Copy :args as widget types in WIDGET."
+  (widget-put widget :args (mapcar 'widget-copy (widget-get widget :args)))
+  widget)
+
+;; Made defsubst to speed up face editor creation.
+(defsubst widget-types-convert-widget (widget)

   "Convert :args as widget types in WIDGET."
   (widget-put widget :args (mapcar 'widget-convert (widget-get widget :args)))
   widget)
 
   "Convert :args as widget types in WIDGET."
   (widget-put widget :args (mapcar 'widget-convert (widget-get widget :args)))
   widget)
 

+(defun widget-value-convert-widget (widget)
+  "Initialize :value from :args in WIDGET."
+  (let ((args (widget-get widget :args)))
+    (when args
+      (widget-put widget :value (car args))
+      ;; Don't convert :value here, as this is done in `widget-convert'.
+      ;; (widget-put widget :value (widget-apply widget
+      ;;                                     :value-to-internal (car args)))
+      (widget-put widget :args nil)))
+  widget)
+
+(defun widget-value-value-get (widget)
+  "Return the :value property of WIDGET."
+  (widget-get widget :value))
+

 ;;; The `default' Widget.
 
 (define-widget 'default nil
   "Basic widget other widgets are derived from."
   :value-to-internal (lambda (widget value) value)
   :value-to-external (lambda (widget value) value)
 ;;; The `default' Widget.
 
 (define-widget 'default nil
   "Basic widget other widgets are derived from."
   :value-to-internal (lambda (widget value) value)
   :value-to-external (lambda (widget value) value)

+  :button-prefix 'widget-button-prefix
+  :button-suffix 'widget-button-suffix
+  :complete 'widget-default-complete

   :create 'widget-default-create
   :indent nil
   :offset 0
   :format-handler 'widget-default-format-handler
   :create 'widget-default-create
   :indent nil
   :offset 0
   :format-handler 'widget-default-format-handler

-  :button-face-get 'widget-default-button-face-get 
-  :sample-face-get 'widget-default-sample-face-get 
+  :button-face-get 'widget-default-button-face-get
+  :sample-face-get 'widget-default-sample-face-get

   :delete 'widget-default-delete
   :delete 'widget-default-delete

+  :copy 'identity

   :value-set 'widget-default-value-set
   :value-inline 'widget-default-value-inline
   :value-set 'widget-default-value-set
   :value-inline 'widget-default-value-inline

+  :value-delete 'ignore
+  :default-get 'widget-default-default-get

   :menu-tag-get 'widget-default-menu-tag-get
   :menu-tag-get 'widget-default-menu-tag-get

-  :validate (lambda (widget) nil)
+  :validate #'ignore

   :active 'widget-default-active
   :activate 'widget-specify-active
   :deactivate 'widget-default-deactivate
   :active 'widget-default-active
   :activate 'widget-specify-active
   :deactivate 'widget-default-deactivate

+  :mouse-down-action #'ignore

   :action 'widget-default-action
   :notify 'widget-default-notify
   :prompt-value 'widget-default-prompt-value)
 
   :action 'widget-default-action
   :notify 'widget-default-notify
   :prompt-value 'widget-default-prompt-value)
 

+(defun widget-default-complete (widget)
+  "Call the value of the :complete-function property of WIDGET.
+If that does not exists, call the value of `widget-complete-field'."
+  (call-interactively (or (widget-get widget :complete-function)
+                         widget-complete-field)))
+

 (defun widget-default-create (widget)
   "Create WIDGET at point in the current buffer."
   (widget-specify-insert
    (let ((from (point))
 (defun widget-default-create (widget)
   "Create WIDGET at point in the current buffer."
   (widget-specify-insert
    (let ((from (point))

-        (tag (widget-get widget :tag))
-        (glyph (widget-get widget :tag-glyph))
-        (doc (widget-get widget :doc))

         button-begin button-end
         sample-begin sample-end
         doc-begin doc-end
         button-begin button-end
         sample-begin sample-end
         doc-begin doc-end


@@ -1058,13 +1390,15 @@ With optional ARG, move across that many fields."
      (goto-char from)
      ;; Parse escapes in format.
      (while (re-search-forward "%\\(.\\)" nil t)
      (goto-char from)
      ;; Parse escapes in format.
      (while (re-search-forward "%\\(.\\)" nil t)

-       (let ((escape (aref (match-string 1) 0)))
-        (replace-match "" t t)
+       (let ((escape (char-after (match-beginning 1))))
+        (delete-backward-char 2)

         (cond ((eq escape ?%)
         (cond ((eq escape ?%)

-               (insert "%"))
+               (insert ?%))

               ((eq escape ?\[)
               ((eq escape ?\[)

-               (setq button-begin (point)))
+               (setq button-begin (point))
+               (insert (widget-get-indirect widget :button-prefix)))

               ((eq escape ?\])
               ((eq escape ?\])

+               (insert (widget-get-indirect widget :button-suffix))

                (setq button-end (point)))
               ((eq escape ?\{)
                (setq sample-begin (point)))
                (setq button-end (point)))
               ((eq escape ?\{)
                (setq sample-begin (point)))


@@ -1072,29 +1406,32 @@ With optional ARG, move across that many fields."
                (setq sample-end (point)))
               ((eq escape ?n)
                (when (widget-get widget :indent)
                (setq sample-end (point)))
               ((eq escape ?n)
                (when (widget-get widget :indent)

-                 (insert "\n")
+                 (insert ?\n)

                  (insert-char ?  (widget-get widget :indent))))
               ((eq escape ?t)
                  (insert-char ?  (widget-get widget :indent))))
               ((eq escape ?t)

-               (cond (glyph 
-                      (widget-glyph-insert widget (or tag "image") glyph))
-                     (tag
-                      (insert tag))
-                     (t
-                      (let ((standard-output (current-buffer)))
-                        (princ (widget-get widget :value))))))
+               (let ((image (widget-get widget :tag-glyph))
+                     (tag (widget-get widget :tag)))
+                 (cond (image
+                        (widget-image-insert widget (or tag "image") image))
+                       (tag
+                        (insert tag))
+                       (t
+                        (princ (widget-get widget :value)
+                               (current-buffer))))))

               ((eq escape ?d)
               ((eq escape ?d)

-               (when doc
-                 (setq doc-begin (point))
-                 (insert doc)
-                 (while (eq (preceding-char) ?\n)
-                   (delete-backward-char 1))
-                 (insert "\n")
-                 (setq doc-end (point))))
+               (let ((doc (widget-get widget :doc)))
+                 (when doc
+                   (setq doc-begin (point))
+                   (insert doc)
+                   (while (eq (preceding-char) ?\n)
+                     (delete-backward-char 1))
+                   (insert ?\n)
+                   (setq doc-end (point)))))

               ((eq escape ?v)
                (if (and button-begin (not button-end))
                    (widget-apply widget :value-create)
                  (setq value-pos (point))))
               ((eq escape ?v)
                (if (and button-begin (not button-end))
                    (widget-apply widget :value-create)
                  (setq value-pos (point))))

-              (t 
+              (t

                (widget-apply widget :format-handler escape)))))
      ;; Specify button, sample, and doc, and insert value.
      (and button-begin button-end
                (widget-apply widget :format-handler escape)))))
      ;; Specify button, sample, and doc, and insert value.
      (and button-begin button-end


@@ -1106,9 +1443,8 @@ With optional ARG, move across that many fields."
      (when value-pos
        (goto-char value-pos)
        (widget-apply widget :value-create)))
      (when value-pos
        (goto-char value-pos)
        (widget-apply widget :value-create)))

-   (let ((from (copy-marker (point-min)))
-        (to (copy-marker (point-max))))
-     (widget-specify-text from to)
+   (let ((from (point-min-marker))
+        (to (point-max-marker)))

      (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)


@@ -1117,60 +1453,76 @@ With optional ARG, move across that many fields."
 
 (defun widget-default-format-handler (widget escape)
   ;; We recognize the %h escape by default.
 
 (defun widget-default-format-handler (widget escape)
   ;; We recognize the %h escape by default.

-  (let* ((buttons (widget-get widget :buttons))
-        (doc-property (widget-get widget :documentation-property))
-        (doc-try (cond ((widget-get widget :doc))
-                       ((symbolp doc-property)
-                        (documentation-property (widget-get widget :value)
-                                                doc-property))
-                       (t
-                        (funcall doc-property (widget-get widget :value)))))
-        (doc-text (and (stringp doc-try)
-                       (> (length doc-try) 1)
-                       doc-try)))
+  (let* ((buttons (widget-get widget :buttons)))

     (cond ((eq escape ?h)
     (cond ((eq escape ?h)

-          (when doc-text
-            (and (eq (preceding-char) ?\n)
-                 (widget-get widget :indent)
-                 (insert-char ?  (widget-get widget :indent)))
-            ;; The `*' in the beginning is redundant.
-            (when (eq (aref doc-text  0) ?*)
-              (setq doc-text (substring doc-text 1)))
-            ;; Get rid of trailing newlines.
-            (when (string-match "\n+\\'" doc-text)
-              (setq doc-text (substring doc-text 0 (match-beginning 0))))
-            (push (if (string-match "\n." doc-text)
-                      ;; Allow multiline doc to be hiden.
-                      (widget-create-child-and-convert
-                       widget 'widget-help 
-                       :doc (progn
-                              (string-match "\\`.*" doc-text)
-                              (match-string 0 doc-text))
-                       :widget-doc doc-text
-                       "?")
-                    ;; A single line is just inserted.
-                    (widget-create-child-and-convert
-                     widget 'item :format "%d" :doc doc-text nil))
-                  buttons)))
-         (t 
+          (let* ((doc-property (widget-get widget :documentation-property))
+                 (doc-try (cond ((widget-get widget :doc))
+                                ((functionp doc-property)
+                                 (funcall doc-property
+                                          (widget-get widget :value)))
+                                ((symbolp doc-property)
+                                 (documentation-property
+                                  (widget-get widget :value)
+                                  doc-property))))
+                 (doc-text (and (stringp doc-try)
+                                (> (length doc-try) 1)
+                                doc-try))
+                 (doc-indent (widget-get widget :documentation-indent)))
+            (when doc-text
+              (and (eq (preceding-char) ?\n)
+                   (widget-get widget :indent)
+                   (insert-char ?  (widget-get widget :indent)))
+              ;; The `*' in the beginning is redundant.
+              (when (eq (aref doc-text  0) ?*)
+                (setq doc-text (substring doc-text 1)))
+              ;; Get rid of trailing newlines.
+              (when (string-match "\n+\\'" doc-text)
+                (setq doc-text (substring doc-text 0 (match-beginning 0))))
+              (push (widget-create-child-and-convert
+                     widget 'documentation-string
+                     :indent (cond ((numberp doc-indent )
+                                    doc-indent)
+                                   ((null doc-indent)
+                                    nil)
+                                   (t 0))
+                     doc-text)
+                    buttons))))
+         (t

           (error "Unknown escape `%c'" escape)))
     (widget-put widget :buttons buttons)))
 
 (defun widget-default-button-face-get (widget)
   ;; Use :button-face or widget-button-face
           (error "Unknown escape `%c'" escape)))
     (widget-put widget :buttons buttons)))
 
 (defun widget-default-button-face-get (widget)
   ;; Use :button-face or widget-button-face

-  (or (widget-get widget :button-face) 'widget-button-face))
+  (or (widget-get widget :button-face)
+      (let ((parent (widget-get widget :parent)))
+       (if parent
+           (widget-apply parent :button-face-get)
+         widget-button-face))))

 
 (defun widget-default-sample-face-get (widget)
   ;; Use :sample-face.
   (widget-get widget :sample-face))
 
 (defun widget-default-delete (widget)
 
 (defun widget-default-sample-face-get (widget)
   ;; Use :sample-face.
   (widget-get widget :sample-face))
 
 (defun widget-default-delete (widget)

-  ;; Remove widget from the buffer.
+  "Remove widget from the buffer."

   (let ((from (widget-get widget :from))
        (to (widget-get widget :to))
   (let ((from (widget-get widget :from))
        (to (widget-get widget :to))

-       (inhibit-read-only t)
-       after-change-functions)
+       (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))
+       (inhibit-modification-hooks t)
+       (inhibit-read-only t))

     (widget-apply widget :value-delete)
     (widget-apply widget :value-delete)

+    (widget-children-value-delete widget)
+    (when inactive-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))


@@ -1179,31 +1531,50 @@ With optional ARG, move across that many fields."
   (widget-clear-undo))
 
 (defun widget-default-value-set (widget value)
   (widget-clear-undo))
 
 (defun widget-default-value-set (widget value)

-  ;; Recreate widget with new value.
-  (save-excursion
-    (goto-char (widget-get widget :from))
-    (widget-apply widget :delete)
-    (widget-put widget :value value)
-    (widget-apply widget :create)))
+  "Recreate widget with new value."
+  (let* ((old-pos (point))
+        (from (copy-marker (widget-get widget :from)))
+        (to (copy-marker (widget-get widget :to)))
+        (offset (if (and (<= from old-pos) (<= old-pos to))
+                    (if (>= old-pos (1- to))
+                        (- old-pos to 1)
+                      (- old-pos from)))))
+    ;;??? Bug: this ought to insert the new value before deleting the old one,
+    ;; so that markers on either side of the value automatically
+    ;; stay on the same side.  -- rms.
+    (save-excursion
+      (goto-char (widget-get widget :from))
+      (widget-apply widget :delete)
+      (widget-put widget :value value)
+      (widget-apply widget :create))
+    (if offset
+       (if (< offset 0)
+           (goto-char (+ (widget-get widget :to) offset 1))
+         (goto-char (min (+ from offset) (1- (widget-get widget :to))))))))

 
 (defun widget-default-value-inline (widget)
 
 (defun widget-default-value-inline (widget)

-  ;; Wrap value in a list unless it is inline.
+  "Wrap value in a list unless it is inline."

   (if (widget-get widget :inline)
       (widget-value widget)
     (list (widget-value widget))))
 
   (if (widget-get widget :inline)
       (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)
 (defun widget-default-menu-tag-get (widget)

-  ;; Use tag or value for menus.
+  "Use tag or value for menus."

   (or (widget-get widget :menu-tag)
       (widget-get widget :tag)
       (widget-princ-to-string (widget-get widget :value))))
 
 (defun widget-default-active (widget)
   "Return t iff this widget active (user modifiable)."
   (or (widget-get widget :menu-tag)
       (widget-get widget :tag)
       (widget-princ-to-string (widget-get widget :value))))
 
 (defun widget-default-active (widget)
   "Return t iff this widget active (user modifiable)."

-  (and (not (widget-get widget :inactive))
-       (let ((parent (widget-get widget :parent)))
-        (or (null parent) 
-            (widget-apply parent :active)))))
+  (or (widget-get widget :always-active)
+      (and (not (widget-get widget :inactive))
+          (let ((parent (widget-get widget :parent)))
+            (or (null parent)
+                (widget-apply parent :active))))))

 
 (defun widget-default-deactivate (widget)
   "Make WIDGET inactive for user modifications."
 
 (defun widget-default-deactivate (widget)
   "Make WIDGET inactive for user modifications."


@@ -1212,49 +1583,39 @@ With optional ARG, move across that many fields."
                           (widget-get widget :to)))
 
 (defun widget-default-action (widget &optional event)
                           (widget-get widget :to)))
 
 (defun widget-default-action (widget &optional event)

-  ;; Notify the parent when a widget change
+  "Notify the parent when a widget changes."

   (let ((parent (widget-get widget :parent)))
     (when parent
       (widget-apply parent :notify widget event))))
 
 (defun widget-default-notify (widget child &optional event)
   (let ((parent (widget-get widget :parent)))
     (when parent
       (widget-apply parent :notify widget event))))
 
 (defun widget-default-notify (widget child &optional event)

-  ;; Pass notification to parent.
+  "Pass notification to parent."

   (widget-default-action widget event))
 
 (defun widget-default-prompt-value (widget prompt value unbound)
   (widget-default-action widget event))
 
 (defun widget-default-prompt-value (widget prompt value unbound)

-  ;; Read an arbitrary value.  Stolen from `set-variable'.
-;;  (let ((initial (if unbound
-;;                  nil
-;;                ;; It would be nice if we could do a `(cons val 1)' here.
-;;                (prin1-to-string (custom-quote value))))))
-  (eval-minibuffer prompt ))
+  "Read an arbitrary value.  Stolen from `set-variable'."
+;; (let ((initial (if unbound
+;; nil
+;; It would be nice if we could do a `(cons val 1)' here.
+;; (prin1-to-string (custom-quote value))))))
+  (eval-minibuffer prompt))

 
 ;;; The `item' Widget.
 
 (define-widget 'item 'default
   "Constant items for inclusion in other widgets."
 
 ;;; The `item' Widget.
 
 (define-widget 'item 'default
   "Constant items for inclusion in other widgets."

-  :convert-widget 'widget-item-convert-widget
+  :convert-widget 'widget-value-convert-widget

   :value-create 'widget-item-value-create
   :value-delete 'ignore
   :value-create 'widget-item-value-create
   :value-delete 'ignore

-  :value-get 'widget-item-value-get
+  :value-get 'widget-value-value-get

   :match 'widget-item-match
   :match-inline 'widget-item-match-inline
   :action 'widget-item-action
   :format "%t\n")
 
   :match 'widget-item-match
   :match-inline 'widget-item-match-inline
   :action 'widget-item-action
   :format "%t\n")
 

-(defun widget-item-convert-widget (widget)
-  ;; Initialize :value from :args in WIDGET.
-  (let ((args (widget-get widget :args)))
-    (when args 
-      (widget-put widget :value (widget-apply widget
-                                             :value-to-internal (car args)))
-      (widget-put widget :args nil)))
-  widget)
-

 (defun widget-item-value-create (widget)
 (defun widget-item-value-create (widget)

-  ;; Insert the printed representation of the value.
-  (let ((standard-output (current-buffer)))
-    (princ (widget-get widget :value))))
+  "Insert the printed representation of the value."
+  (princ (widget-get widget :value) (current-buffer)))

 
 (defun widget-item-match (widget value)
   ;; Match if the value is the same.
 
 (defun widget-item-match (widget value)
   ;; Match if the value is the same.


@@ -1265,64 +1626,85 @@ With optional ARG, move across that many fields."
   (let ((value (widget-get widget :value)))
     (and (listp value)
         (<= (length value) (length values))
   (let ((value (widget-get widget :value)))
     (and (listp value)
         (<= (length value) (length values))

-        (let ((head (subseq values 0 (length value))))
+        (let ((head (widget-sublist values 0 (length value))))

           (and (equal head value)
           (and (equal head value)

-               (cons head (subseq values (length value))))))))
+               (cons head (widget-sublist values (length value))))))))
+
+(defun widget-sublist (list start &optional end)
+  "Return the sublist of LIST from START to END.
+If END is omitted, it defaults to the length of LIST."
+  (if (> start 0) (setq list (nthcdr start list)))
+  (if end
+      (unless (<= end start)
+       (setq list (copy-sequence list))
+       (setcdr (nthcdr (- end start 1) list) nil)
+       list)
+    (copy-sequence list)))

 
 (defun widget-item-action (widget &optional event)
   ;; Just notify itself.
   (widget-apply widget :notify widget event))
 
 
 (defun widget-item-action (widget &optional event)
   ;; Just notify itself.
   (widget-apply widget :notify widget event))
 

-(defun widget-item-value-get (widget)
-  ;; Items are simple.
-  (widget-get widget :value))
-

 ;;; The `push-button' Widget.
 
 ;;; The `push-button' Widget.
 

-(defcustom widget-push-button-gui t
-  "If non nil, use GUI push buttons when available."
-  :group 'widgets
-  :type 'boolean)
+;; (defcustom widget-push-button-gui t
+;;   "If non nil, use GUI push buttons when available."
+;;   :group 'widgets
+;;   :type 'boolean)

 
 ;; Cache already created GUI objects.
 
 ;; Cache already created GUI objects.

-(defvar widget-push-button-cache nil)
+;; (defvar widget-push-button-cache nil)
+
+(defcustom widget-push-button-prefix "["
+  "String used as prefix for buttons."
+  :type 'string
+  :group 'widget-button)
+
+(defcustom widget-push-button-suffix "]"
+  "String used as suffix for buttons."
+  :type 'string
+  :group 'widget-button)

 
 (define-widget 'push-button 'item
   "A pushable button."
 
 (define-widget 'push-button 'item
   "A pushable button."

+  :button-prefix ""
+  :button-suffix ""

   :value-create 'widget-push-button-value-create
   :value-create 'widget-push-button-value-create

-  :text-format "[%s]"

   :format "%[%v%]")
 
 (defun widget-push-button-value-create (widget)
   :format "%[%v%]")
 
 (defun widget-push-button-value-create (widget)

-  ;; Insert text representing the `on' and `off' states.
+  "Insert text representing the `on' and `off' states."

   (let* ((tag (or (widget-get widget :tag)
                  (widget-get widget :value)))
   (let* ((tag (or (widget-get widget :tag)
                  (widget-get widget :value)))

-        (text (format (widget-get widget :text-format) tag))
-        (gui (cdr (assoc tag widget-push-button-cache))))
-    (if (and (fboundp 'make-gui-button)
-            (fboundp 'make-glyph)
-            widget-push-button-gui
-            (fboundp 'device-on-window-system-p)
-            (device-on-window-system-p)
-            (string-match "XEmacs" emacs-version))
-       (progn 
-         (unless gui
-           (setq gui (make-gui-button tag 'widget-gui-action widget))
-           (push (cons tag gui) widget-push-button-cache))
-         (widget-glyph-insert-glyph widget text
-                                    (make-glyph (car (aref gui 1)))))
+        (tag-glyph (widget-get widget :tag-glyph))
+        (text (concat widget-push-button-prefix
+                      tag widget-push-button-suffix)))
+    (if tag-glyph
+       (widget-image-insert widget text tag-glyph)

       (insert text))))
 
       (insert text))))
 

-(defun widget-gui-action (widget)
-  "Apply :action for WIDGET."
-  (widget-apply-action widget (this-command-keys)))
+;; (defun widget-gui-action (widget)
+;;   "Apply :action for WIDGET."
+;;   (widget-apply-action widget (this-command-keys)))

 
 ;;; The `link' Widget.
 
 
 ;;; The `link' Widget.
 

+(defcustom widget-link-prefix "["
+  "String used as prefix for links."
+  :type 'string
+  :group 'widget-button)
+
+(defcustom widget-link-suffix "]"
+  "String used as suffix for links."
+  :type 'string
+  :group 'widget-button)
+

 (define-widget 'link 'item
   "An embedded link."
 (define-widget 'link 'item
   "An embedded link."

+  :button-prefix 'widget-link-prefix
+  :button-suffix 'widget-link-suffix

   :help-echo "Follow the link."
   :help-echo "Follow the link."

-  :format "%[_%t_%]")
+  :format "%[%t%]")

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


@@ -1332,17 +1714,7 @@ With optional ARG, move across that many fields."
 
 (defun widget-info-link-action (widget &optional event)
   "Open the info node specified by WIDGET."
 
 (defun widget-info-link-action (widget &optional event)
   "Open the info node specified by WIDGET."

-  (Info-goto-node (widget-value widget))
-  ;; Steal button release event.
-  (if (and (fboundp 'button-press-event-p)
-          (fboundp 'next-command-event))
-      ;; XEmacs
-      (and event
-          (button-press-event-p event)
-          (next-command-event))
-    ;; Emacs
-    (when (memq 'down (event-modifiers event))
-      (read-event))))
+  (info (widget-value widget)))

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


@@ -1352,97 +1724,156 @@ With optional ARG, move across that many fields."
 
 (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.
+
+(define-widget 'file-link 'link
+  "A link to a file."
+  :action 'widget-file-link-action)
+
+(defun widget-file-link-action (widget &optional event)
+  "Find the file specified by WIDGET."
+  (find-file (widget-value widget)))
+
+;;; The `emacs-library-link' Widget.
+
+(define-widget 'emacs-library-link 'link
+  "A link to an Emacs Lisp library file."
+  :action 'widget-emacs-library-link-action)
+
+(defun widget-emacs-library-link-action (widget &optional event)
+  "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
   "An editable text field."
 
 ;;; The `editable-field' Widget.
 
 (define-widget 'editable-field 'default
   "An editable text field."

-  :convert-widget 'widget-item-convert-widget
+  :convert-widget 'widget-value-convert-widget

   :keymap widget-field-keymap
   :format "%v"
   :keymap widget-field-keymap
   :format "%v"

+  :help-echo "M-TAB: complete field; RET: enter value"

   :value ""
   :value ""

+  :prompt-internal 'widget-field-prompt-internal
+  :prompt-history 'widget-field-history
+  :prompt-value 'widget-field-prompt-value

   :action 'widget-field-action
   :validate 'widget-field-validate
   :valid-regexp ""
   :action 'widget-field-action
   :validate 'widget-field-validate
   :valid-regexp ""

-  :error "No match"
+  :error "Field's value doesn't match allowed forms"

   :value-create 'widget-field-value-create
   :value-delete 'widget-field-value-delete
   :value-get 'widget-field-value-get
   :match 'widget-field-match)
 
   :value-create 'widget-field-value-create
   :value-delete 'widget-field-value-delete
   :value-get 'widget-field-value-get
   :match 'widget-field-match)
 

-;; History of field minibuffer edits.
-(defvar widget-field-history nil)
+(defvar widget-field-history nil
+  "History of field minibuffer edits.")
+
+(defun widget-field-prompt-internal (widget prompt initial history)
+  "Read string for WIDGET promptinhg with PROMPT.
+INITIAL is the initial input and HISTORY is a symbol containing
+the earlier input."
+  (read-string prompt initial history))
+
+(defun widget-field-prompt-value (widget prompt value unbound)
+  "Prompt for a string."
+  (widget-apply widget
+               :value-to-external
+               (widget-apply widget
+                             :prompt-internal prompt
+                             (unless unbound
+                               (cons (widget-apply widget
+                                                   :value-to-internal value)
+                                     0))
+                             (widget-get widget :prompt-history))))
+
+(defvar widget-edit-functions nil)

 
 (defun widget-field-action (widget &optional event)
 
 (defun widget-field-action (widget &optional event)

-  ;; Edit the value in the minibuffer.
-  (let ((tag (widget-apply widget :menu-tag-get))
-       (invalid (widget-apply widget :validate)))
-    (when invalid
-      (error (widget-get invalid :error)))
-    (widget-value-set widget 
-                     (widget-apply widget 
-                                   :value-to-external
-                                   (read-string (concat tag ": ") 
-                                                (widget-apply 
-                                                 widget
-                                                 :value-to-internal
-                                                 (widget-value widget))
-                                                'widget-field-history)))
-    (widget-apply widget :notify widget event)
-    (widget-setup)))
+  "Move to next field."
+  (widget-forward 1)
+  (run-hook-with-args 'widget-edit-functions widget))

 
 (defun widget-field-validate (widget)
 
 (defun widget-field-validate (widget)

-  ;; Valid if the content matches `:valid-regexp'.
-  (save-excursion
-    (let ((value (widget-apply widget :value-get))
-         (regexp (widget-get widget :valid-regexp)))
-      (if (string-match regexp value)
-         nil
-       widget))))
+  "Valid if the content matches `:valid-regexp'."
+  (unless (string-match (widget-get widget :valid-regexp)
+                       (widget-apply widget :value-get))
+    widget))

 
 (defun widget-field-value-create (widget)
 
 (defun widget-field-value-create (widget)

-  ;; Create an editable text field.
-  (insert " ")
+  "Create an editable text field."

   (let ((size (widget-get widget :size))
        (value (widget-get widget :value))
   (let ((size (widget-get widget :size))
        (value (widget-get widget :value))

-       (from (point)))
+       (from (point))
+       ;; This is changed to a real overlay in `widget-setup'.  We
+       ;; need the end points to behave differently until
+       ;; `widget-setup' is called.
+       (overlay (cons (make-marker) (make-marker))))
+    (widget-put widget :field-overlay overlay)

     (insert value)
     (and size
         (< (length value) size)
         (insert-char ?\  (- size (length value))))
     (unless (memq widget widget-field-list)
       (setq widget-field-new (cons widget widget-field-new)))
     (insert value)
     (and size
         (< (length value) size)
         (insert-char ?\  (- size (length value))))
     (unless (memq widget widget-field-list)
       (setq widget-field-new (cons widget widget-field-new)))

-    (widget-put widget :value-to (copy-marker (point)))
-    (set-marker-insertion-type (widget-get widget :value-to) nil)
-    (if (null size)
-       (insert ?\n)
-      (insert ?\ ))
-    (widget-put widget :value-from (copy-marker from))
-    (set-marker-insertion-type (widget-get widget :value-from) t)))
+    (move-marker (cdr overlay) (point))
+    (set-marker-insertion-type (cdr overlay) nil)
+    (when (null size)
+      (insert ?\n))
+    (move-marker (car overlay) from)
+    (set-marker-insertion-type (car overlay) t)))

 
 (defun widget-field-value-delete (widget)
 
 (defun widget-field-value-delete (widget)

-  ;; Remove the widget from the list of active editing fields.
+  "Remove the widget from the list of active editing fields."

   (setq widget-field-list (delq widget widget-field-list))
   (setq widget-field-list (delq widget widget-field-list))

+  (setq widget-field-new (delq widget widget-field-new))

   ;; These are nil if the :format string doesn't contain `%v'.
   ;; These are nil if the :format string doesn't contain `%v'.

-  (when (widget-get widget :value-from)
-    (set-marker (widget-get widget :value-from) nil))
-  (when (widget-get widget :value-from)
-    (set-marker (widget-get widget :value-to) nil)))
+  (let ((overlay (widget-get widget :field-overlay)))
+    (when (overlayp overlay)
+      (delete-overlay overlay))))

 
 (defun widget-field-value-get (widget)
 
 (defun widget-field-value-get (widget)

-  ;; Return current text in editing field.
-  (let ((from (widget-get widget :value-from))
-       (to (widget-get widget :value-to))
+  "Return current text in editing field."
+  (let ((from (widget-field-start widget))
+       (to (widget-field-end widget))
+       (buffer (widget-field-buffer widget))

        (size (widget-get widget :size))
        (secret (widget-get widget :secret))
        (old (current-buffer)))
     (if (and from to)
        (size (widget-get widget :size))
        (secret (widget-get widget :secret))
        (old (current-buffer)))
     (if (and from to)

-       (progn 
-         (set-buffer (marker-buffer from))
-         (setq from (1+ from)
-               to (1- to))
+       (progn
+         (set-buffer buffer)

          (while (and size
                      (not (zerop size))
                      (> to from)
          (while (and size
                      (not (zerop size))
                      (> to from)


@@ -1453,7 +1884,7 @@ With optional ARG, move across that many fields."
              (let ((index 0))
                (while (< (+ from index) to)
                  (aset result index
              (let ((index 0))
                (while (< (+ from index) to)
                  (aset result index

-                       (get-text-property (+ from index) 'secret))
+                       (get-char-property (+ from index) 'secret))

                  (setq index (1+ index)))))
            (set-buffer old)
            result))
                  (setq index (1+ index)))))
            (set-buffer old)
            result))


@@ -1466,22 +1897,24 @@ With optional ARG, move across that many fields."
 ;;; The `text' Widget.
 
 (define-widget 'text 'editable-field
 ;;; The `text' Widget.
 
 (define-widget 'text 'editable-field

-  :keymap widget-text-keymap
-  "A multiline text area.")
+  "A multiline text area."
+  :keymap widget-text-keymap)

 
 ;;; The `menu-choice' Widget.
 
 (define-widget 'menu-choice 'default
   "A menu of options."
   :convert-widget  'widget-types-convert-widget
 
 ;;; The `menu-choice' Widget.
 
 (define-widget 'menu-choice 'default
   "A menu of options."
   :convert-widget  'widget-types-convert-widget

+  :copy 'widget-types-copy

   :format "%[%t%]: %v"
   :case-fold t
   :tag "choice"
   :void '(item :format "invalid (%t)\n")
   :value-create 'widget-choice-value-create
   :format "%[%t%]: %v"
   :case-fold t
   :tag "choice"
   :void '(item :format "invalid (%t)\n")
   :value-create 'widget-choice-value-create

-  :value-delete 'widget-children-value-delete
-  :value-get 'widget-choice-value-get
-  :value-inline 'widget-choice-value-inline
+  :value-get 'widget-child-value-get
+  :value-inline 'widget-child-value-inline
+  :default-get 'widget-choice-default-get
+  :mouse-down-action 'widget-choice-mouse-down-action

   :action 'widget-choice-action
   :error "Make a choice"
   :validate 'widget-choice-validate
   :action 'widget-choice-action
   :error "Make a choice"
   :validate 'widget-choice-validate


@@ -1489,32 +1922,66 @@ With optional ARG, move across that many fields."
   :match-inline 'widget-choice-match-inline)
 
 (defun widget-choice-value-create (widget)
   :match-inline 'widget-choice-match-inline)
 
 (defun widget-choice-value-create (widget)

-  ;; Insert the first choice that matches the value.
+  "Insert the first choice that matches the value."

   (let ((value (widget-get widget :value))
        (args (widget-get widget :args))
   (let ((value (widget-get widget :value))
        (args (widget-get widget :args))

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

        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)))))
-
-(defun widget-choice-value-get (widget)
-  ;; Get value of the child widget.
-  (widget-value (car (widget-get widget :children))))
+    (if (and explicit (equal value (widget-get widget :explicit-choice-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-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
+when he invoked the menu."
+  :type 'boolean
+  :group 'widgets)

 
 

-(defun widget-choice-value-inline (widget)
-  ;; Get value of the child widget.
-  (widget-apply (car (widget-get widget :children)) :value-inline))
+(defun widget-choice-mouse-down-action (widget &optional event)
+  ;; Return non-nil if we need a menu.
+  (let ((args (widget-get widget :args))
+       (old (widget-get widget :choice)))
+    (cond ((not (display-popup-menus-p))
+          ;; No place to pop up a menu.
+          nil)
+         ((< (length args) 2)
+          ;; Empty or singleton list, just return the value.
+          nil)
+         ((> (length args) widget-menu-max-size)
+          ;; Too long, prompt.
+          nil)
+         ((> (length args) 2)
+          ;; Reasonable sized list, use menu.
+          t)
+         ((and widget-choice-toggle (memq old args))
+          ;; We toggle.
+          nil)
+         (t
+          ;; Ask which of the two.
+          t))))

 
 (defun widget-choice-action (widget &optional event)
   ;; Make a choice.
 
 (defun widget-choice-action (widget &optional event)
   ;; Make a choice.


@@ -1522,6 +1989,7 @@ With optional ARG, move across that many fields."
        (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)))


@@ -1534,7 +2002,8 @@ With optional ARG, move across that many fields."
                 nil)
                ((= (length args) 1)
                 (nth 0 args))
                 nil)
                ((= (length args) 1)
                 (nth 0 args))

-               ((and (= (length args) 2)
+               ((and widget-choice-toggle
+                     (= (length args) 2)

                      (memq old args))
                 (if (eq old (nth 0 args))
                     (nth 1 args)
                      (memq old args))
                 (if (eq old (nth 0 args))
                     (nth 1 args)


@@ -1547,22 +2016,26 @@ With optional ARG, move across that many fields."
                         (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)))
-      (widget-apply widget :notify widget event)
-      (widget-setup))))
+      ;; 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)))
+      (widget-value-set widget (widget-default-get current))
+      (widget-setup)
+      (widget-apply widget :notify widget event)))
+  (run-hook-with-args 'widget-edit-functions widget))

 
 (defun widget-choice-validate (widget)
   ;; Valid if we have made a valid choice.
 
 (defun widget-choice-validate (widget)
   ;; Valid if we have made a valid choice.

-  (let ((void (widget-get widget :void))
-       (choice (widget-get widget :choice))
-       (child (car (widget-get widget :children))))
-    (if (eq void choice)
-       widget
-      (widget-apply child :validate))))
+  (if (eq (widget-get widget :void) (widget-get widget :choice))
+      widget
+    (widget-apply (car (widget-get widget :children)) :validate)))

 
 (defun widget-choice-match (widget value)
   ;; Matches if one of the choices matches.
 
 (defun widget-choice-match (widget value)
   ;; Matches if one of the choices matches.


@@ -1596,29 +2069,54 @@ With optional ARG, move across that many fields."
   :off "off")
 
 (defun widget-toggle-value-create (widget)
   :off "off")
 
 (defun widget-toggle-value-create (widget)

-  ;; Insert text representing the `on' and `off' states.
+  "Insert text representing the `on' and `off' states."

   (if (widget-value widget)
   (if (widget-value widget)

-      (widget-glyph-insert widget 
-                          (widget-get widget :on) 
-                          (widget-get widget :on-glyph))
-    (widget-glyph-insert widget
-                        (widget-get widget :off)
-                        (widget-get widget :off-glyph))))
+      (let ((image (widget-get widget :on-glyph)))
+       (and (display-graphic-p)
+            (listp image)
+            (not (eq (car image) 'image))
+            (widget-put widget :on-glyph (setq image (eval image))))
+       (widget-image-insert widget
+                            (widget-get widget :on)
+                            image))
+    (let ((image (widget-get widget :off-glyph)))
+      (and (display-graphic-p)
+          (listp image)
+          (not (eq (car image) 'image))
+          (widget-put widget :off-glyph (setq image (eval image))))
+      (widget-image-insert widget (widget-get widget :off) image))))

 
 (defun widget-toggle-action (widget &optional event)
   ;; Toggle value.
   (widget-value-set widget (not (widget-value widget)))
 
 (defun widget-toggle-action (widget &optional event)
   ;; Toggle value.
   (widget-value-set widget (not (widget-value widget)))

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

 
 ;;; The `checkbox' Widget.
 
 (define-widget 'checkbox 'toggle
   "A checkbox toggle."
 
 ;;; The `checkbox' Widget.
 
 (define-widget 'checkbox 'toggle
   "A checkbox toggle."

+  :button-suffix ""
+  :button-prefix ""

   :format "%[%v%]"
   :on "[X]"
   :format "%[%v%]"
   :on "[X]"

-  :on-glyph "check1"
+  ;; We could probably do the same job as the images using single
+  ;; space characters in a boxed face with a stretch specification to
+  ;; make them square.
+  :on-glyph '(create-image "\300\300\141\143\067\076\034\030"
+                          'xbm t :width 8 :height 8
+                          :background "grey75" ; like default mode line
+                          :foreground "black"
+                          :relief -2
+                          :ascent 'center)

   :off "[ ]"
   :off "[ ]"

-  :off-glyph "check0"
+  :off-glyph '(create-image (make-string 8 0)
+                           'xbm t :width 8 :height 8
+                           :background "grey75"
+                           :foreground "black"
+                           :relief -2
+                           :ascent 'center)
+  :help-echo "Toggle this item."

   :action 'widget-checkbox-action)
 
 (defun widget-checkbox-action (widget &optional event)
   :action 'widget-checkbox-action)
 
 (defun widget-checkbox-action (widget &optional event)


@@ -1635,13 +2133,12 @@ With optional ARG, move across that many fields."
 (define-widget 'checklist 'default
   "A multiple choice widget."
   :convert-widget 'widget-types-convert-widget
 (define-widget 'checklist 'default
   "A multiple choice widget."
   :convert-widget 'widget-types-convert-widget

+  :copy 'widget-types-copy

   :format "%v"
   :offset 4
   :entry-format "%b %v"
   :format "%v"
   :offset 4
   :entry-format "%b %v"

-  :menu-tag "checklist"

   :greedy nil
   :value-create 'widget-checklist-value-create
   :greedy nil
   :value-create 'widget-checklist-value-create

-  :value-delete 'widget-children-value-delete

   :value-get 'widget-checklist-value-get
   :validate 'widget-checklist-validate
   :match 'widget-checklist-match
   :value-get 'widget-checklist-value-get
   :validate 'widget-checklist-validate
   :match 'widget-checklist-match


@@ -1651,18 +2148,18 @@ With optional ARG, move across that many fields."
   ;; Insert all values
   (let ((alist (widget-checklist-match-find widget (widget-get widget :value)))
        (args (widget-get widget :args)))
   ;; Insert all values
   (let ((alist (widget-checklist-match-find widget (widget-get widget :value)))
        (args (widget-get widget :args)))

-    (while args 
+    (while args

       (widget-checklist-add-item widget (car args) (assq (car args) alist))
       (setq args (cdr args)))
     (widget-put widget :children (nreverse (widget-get widget :children)))))
 
 (defun widget-checklist-add-item (widget type chosen)
       (widget-checklist-add-item widget (car args) (assq (car args) alist))
       (setq args (cdr args)))
     (widget-put widget :children (nreverse (widget-get widget :children)))))
 
 (defun widget-checklist-add-item (widget type chosen)

-  ;; Create checklist item in WIDGET of type TYPE.
-  ;; If the item is checked, CHOSEN is a cons whose cdr is the value.
+  "Create checklist item in WIDGET of type TYPE.
+If the item is checked, CHOSEN is a cons whose cdr is the value."

   (and (eq (preceding-char) ?\n)
        (widget-get widget :indent)
        (insert-char ?  (widget-get widget :indent)))
   (and (eq (preceding-char) ?\n)
        (widget-get widget :indent)
        (insert-char ?  (widget-get widget :indent)))

-  (widget-specify-insert 
+  (widget-specify-insert

    (let* ((children (widget-get widget :children))
          (buttons (widget-get widget :buttons))
          (button-args (or (widget-get type :sibling-args)
    (let* ((children (widget-get widget :children))
          (buttons (widget-get widget :buttons))
          (button-args (or (widget-get type :sibling-args)


@@ -1673,10 +2170,10 @@ With optional ARG, move across that many fields."
      (goto-char from)
      ;; Parse % escapes in format.
      (while (re-search-forward "%\\([bv%]\\)" nil t)
      (goto-char from)
      ;; Parse % escapes in format.
      (while (re-search-forward "%\\([bv%]\\)" nil t)

-       (let ((escape (aref (match-string 1) 0)))
-        (replace-match "" t t)
+       (let ((escape (char-after (match-beginning 1))))
+        (delete-backward-char 2)

         (cond ((eq escape ?%)
         (cond ((eq escape ?%)

-               (insert "%"))
+               (insert ?%))

               ((eq escape ?b)
                (setq button (apply 'widget-create-child-and-convert
                                    widget 'checkbox
               ((eq escape ?b)
                (setq button (apply 'widget-create-child-and-convert
                                    widget 'checkbox


@@ -1694,7 +2191,7 @@ With optional ARG, move across that many fields."
                            (t
                             (widget-create-child-value
                              widget type (car (cdr chosen)))))))
                            (t
                             (widget-create-child-value
                              widget type (car (cdr chosen)))))))

-              (t 
+              (t

                (error "Unknown escape `%c'" escape)))))
      ;; Update properties.
      (and button child (widget-put child :button button))
                (error "Unknown escape `%c'" escape)))))
      ;; Update properties.
      (and button child (widget-put child :button button))


@@ -1713,7 +2210,7 @@ With optional ARG, move across that many fields."
        found rest)
     (while values
       (let ((answer (widget-checklist-match-up args values)))
        found rest)
     (while values
       (let ((answer (widget-checklist-match-up args values)))

-       (cond (answer 
+       (cond (answer

               (let ((vals (widget-match-inline answer values)))
                 (setq found (append found (car vals))
                       values (cdr vals)
               (let ((vals (widget-match-inline answer values)))
                 (setq found (append found (car vals))
                       values (cdr vals)


@@ -1721,46 +2218,45 @@ With optional ARG, move across that many fields."
              (greedy
               (setq rest (append rest (list (car values)))
                     values (cdr values)))
              (greedy
               (setq rest (append rest (list (car values)))
                     values (cdr values)))

-             (t 
+             (t

               (setq rest (append rest values)
                     values nil)))))
     (cons found rest)))
 
 (defun widget-checklist-match-find (widget vals)
               (setq rest (append rest values)
                     values nil)))))
     (cons found rest)))
 
 (defun widget-checklist-match-find (widget vals)

-  ;; Find the vals which match a type in the checklist.
-  ;; Return an alist of (TYPE MATCH).
+  "Find the vals which match a type in the checklist.
+Return an alist of (TYPE MATCH)."

   (let ((greedy (widget-get widget :greedy))
        (args (copy-sequence (widget-get widget :args)))
        found)
     (while vals
       (let ((answer (widget-checklist-match-up args vals)))
   (let ((greedy (widget-get widget :greedy))
        (args (copy-sequence (widget-get widget :args)))
        found)
     (while vals
       (let ((answer (widget-checklist-match-up args vals)))

-       (cond (answer 
+       (cond (answer

               (let ((match (widget-match-inline answer vals)))
                 (setq found (cons (cons answer (car match)) found)
                       vals (cdr match)
                       args (delq answer args))))
              (greedy
               (setq vals (cdr vals)))
               (let ((match (widget-match-inline answer vals)))
                 (setq found (cons (cons answer (car match)) found)
                       vals (cdr match)
                       args (delq answer args))))
              (greedy
               (setq vals (cdr vals)))

-             (t 
+             (t

               (setq vals nil)))))
     found))
 
 (defun widget-checklist-match-up (args vals)
               (setq vals nil)))))
     found))
 
 (defun widget-checklist-match-up (args vals)

-  ;; Rerturn the first type from ARGS that matches VALS.
+  "Return the first type from ARGS that matches VALS."

   (let (current found)
     (while (and args (null found))
       (setq current (car args)
            args (cdr args)
            found (widget-match-inline current vals)))
     (if found
   (let (current found)
     (while (and args (null found))
       (setq current (car args)
            args (cdr args)
            found (widget-match-inline current vals)))
     (if found

-       current
-      nil)))
+       current)))

 
 (defun widget-checklist-value-get (widget)
   ;; The values of all selected items.
   (let ((children (widget-get widget :children))
        child result)
 
 (defun widget-checklist-value-get (widget)
   ;; The values of all selected items.
   (let ((children (widget-get widget :children))
        child result)

-    (while children 
+    (while children

       (setq child (car children)
            children (cdr children))
       (if (widget-value (widget-get child :button))
       (setq child (car children)
            children (cdr children))
       (if (widget-value (widget-get child :button))


@@ -1789,19 +2285,17 @@ With optional ARG, move across that many fields."
 
 (define-widget 'choice-item 'item
   "Button items that delegate action events to their parents."
 
 (define-widget 'choice-item 'item
   "Button items that delegate action events to their parents."

-  :action 'widget-choice-item-action
+  :action 'widget-parent-action

   :format "%[%t%] \n")
 
   :format "%[%t%] \n")
 

-(defun widget-choice-item-action (widget &optional event)
-  ;; Tell parent what happened.
-  (widget-apply (widget-get widget :parent) :action event))
-

 ;;; The `radio-button' Widget.
 
 (define-widget 'radio-button 'toggle
   "A radio button for use in the `radio' widget."
   :notify 'widget-radio-button-notify
   :format "%[%v%]"
 ;;; The `radio-button' Widget.
 
 (define-widget 'radio-button 'toggle
   "A radio button for use in the `radio' widget."
   :notify 'widget-radio-button-notify
   :format "%[%v%]"

+  :button-suffix ""
+  :button-prefix ""

   :on "(*)"
   :on-glyph "radio1"
   :off "( )"
   :on "(*)"
   :on-glyph "radio1"
   :off "( )"


@@ -1816,12 +2310,11 @@ With optional ARG, move across that many fields."
 (define-widget 'radio-button-choice 'default
   "Select one of multiple options."
   :convert-widget 'widget-types-convert-widget
 (define-widget 'radio-button-choice 'default
   "Select one of multiple options."
   :convert-widget 'widget-types-convert-widget

+  :copy 'widget-types-copy

   :offset 4
   :format "%v"
   :entry-format "%b %v"
   :offset 4
   :format "%v"
   :entry-format "%b %v"

-  :menu-tag "radio"

   :value-create 'widget-radio-value-create
   :value-create 'widget-radio-value-create

-  :value-delete 'widget-children-value-delete

   :value-get 'widget-radio-value-get
   :value-inline 'widget-radio-value-inline
   :value-set 'widget-radio-value-set
   :value-get 'widget-radio-value-get
   :value-inline 'widget-radio-value-inline
   :value-set 'widget-radio-value-set


@@ -1835,7 +2328,7 @@ With optional ARG, move across that many fields."
   ;; Insert all values
   (let ((args (widget-get widget :args))
        arg)
   ;; Insert all values
   (let ((args (widget-get widget :args))
        arg)

-    (while args 
+    (while args

       (setq arg (car args)
            args (cdr args))
       (widget-radio-add-item widget arg))))
       (setq arg (car args)
            args (cdr args))
       (widget-radio-add-item widget arg))))


@@ -1846,7 +2339,7 @@ With optional ARG, move across that many fields."
   (and (eq (preceding-char) ?\n)
        (widget-get widget :indent)
        (insert-char ?  (widget-get widget :indent)))
   (and (eq (preceding-char) ?\n)
        (widget-get widget :indent)
        (insert-char ?  (widget-get widget :indent)))

-  (widget-specify-insert 
+  (widget-specify-insert

    (let* ((value (widget-get widget :value))
          (children (widget-get widget :children))
          (buttons (widget-get widget :buttons))
    (let* ((value (widget-get widget :value))
          (children (widget-get widget :children))
          (buttons (widget-get widget :buttons))


@@ -1860,13 +2353,13 @@ With optional ARG, move across that many fields."
      (goto-char from)
      ;; Parse % escapes in format.
      (while (re-search-forward "%\\([bv%]\\)" nil t)
      (goto-char from)
      ;; Parse % escapes in format.
      (while (re-search-forward "%\\([bv%]\\)" nil t)

-       (let ((escape (aref (match-string 1) 0)))
-        (replace-match "" t t)
+       (let ((escape (char-after (match-beginning 1))))
+        (delete-backward-char 2)

         (cond ((eq escape ?%)
         (cond ((eq escape ?%)

-               (insert "%"))
+               (insert ?%))

               ((eq escape ?b)
                (setq button (apply 'widget-create-child-and-convert
               ((eq escape ?b)
                (setq button (apply 'widget-create-child-and-convert

-                                   widget 'radio-button 
+                                   widget 'radio-button

                                    :value (not (null chosen))
                                    button-args)))
               ((eq escape ?v)
                                    :value (not (null chosen))
                                    button-args)))
               ((eq escape ?v)


@@ -1874,14 +2367,14 @@ With optional ARG, move across that many fields."
                                (widget-create-child-value
                                 widget type value)
                              (widget-create-child widget type)))
                                (widget-create-child-value
                                 widget type value)
                              (widget-create-child widget type)))

-               (unless chosen 
+               (unless chosen

                  (widget-apply child :deactivate)))
                  (widget-apply child :deactivate)))

-              (t 
+              (t

                (error "Unknown escape `%c'" escape)))))
      ;; Update properties.
      (when chosen
        (widget-put widget :choice type))
                (error "Unknown escape `%c'" escape)))))
      ;; Update properties.
      (when chosen
        (widget-put widget :choice type))

-     (when button 
+     (when button

        (widget-put child :button button)
        (widget-put widget :buttons (nconc buttons (list button))))
      (when child
        (widget-put child :button button)
        (widget-put widget :buttons (nconc buttons (list button))))
      (when child


@@ -1900,11 +2393,9 @@ With optional ARG, move across that many fields."
     (while children
       (setq current (car children)
            children (cdr children))
     (while children
       (setq current (car children)
            children (cdr children))

-      (let* ((button (widget-get current :button))
-            (value (widget-apply button :value-get)))
-       (when value
-         (setq found current
-               children nil))))
+      (when (widget-apply (widget-get current :button) :value-get)
+       (setq found current
+             children nil)))

     found))
 
 (defun widget-radio-value-inline (widget)
     found))
 
 (defun widget-radio-value-inline (widget)


@@ -1914,11 +2405,9 @@ With optional ARG, move across that many fields."
     (while children
       (setq current (car children)
            children (cdr children))
     (while children
       (setq current (car children)
            children (cdr children))

-      (let* ((button (widget-get current :button))
-            (value (widget-apply button :value-get)))
-       (when value
-         (setq found (widget-apply current :value-inline)
-               children nil))))
+      (when (widget-apply (widget-get current :button) :value-get)
+       (setq found (widget-apply current :value-inline)
+             children nil)))

     found))
 
 (defun widget-radio-value-set (widget value)
     found))
 
 (defun widget-radio-value-set (widget value)


@@ -1934,8 +2423,8 @@ With optional ARG, move across that many fields."
             (match (and (not found)
                         (widget-apply current :match value))))
        (widget-value-set button match)
             (match (and (not found)
                         (widget-apply current :match value))))
        (widget-value-set button match)

-       (if match 
-           (progn 
+       (if match
+           (progn

              (widget-value-set current value)
              (widget-apply current :activate))
          (widget-apply current :deactivate))
              (widget-value-set current value)
              (widget-apply current :activate))
          (widget-apply current :deactivate))


@@ -1983,7 +2472,7 @@ With optional ARG, move across that many fields."
 
 (defun widget-insert-button-action (widget &optional event)
   ;; Ask the parent to insert a new item.
 
 (defun widget-insert-button-action (widget &optional event)
   ;; Ask the parent to insert a new item.

-  (widget-apply (widget-get widget :parent) 
+  (widget-apply (widget-get widget :parent)

                :insert-before (widget-get widget :widget)))
 
 ;;; The `delete-button' Widget.
                :insert-before (widget-get widget :widget)))
 
 ;;; The `delete-button' Widget.


@@ -1996,28 +2485,27 @@ With optional ARG, move across that many fields."
 
 (defun widget-delete-button-action (widget &optional event)
   ;; Ask the parent to insert a new item.
 
 (defun widget-delete-button-action (widget &optional event)
   ;; Ask the parent to insert a new item.

-  (widget-apply (widget-get widget :parent) 
+  (widget-apply (widget-get widget :parent)

                :delete-at (widget-get widget :widget)))
 
 ;;; The `editable-list' Widget.
 
                :delete-at (widget-get widget :widget)))
 
 ;;; The `editable-list' Widget.
 

-(defcustom widget-editable-list-gui nil
-  "If non nil, use GUI push-buttons in editable list when available."
-  :type 'boolean
-  :group 'widgets)
+;; (defcustom widget-editable-list-gui nil
+;;   "If non nil, use GUI push-buttons in editable list when available."
+;;   :type 'boolean
+;;   :group 'widgets)

 
 (define-widget 'editable-list 'default
   "A variable list of widgets of the same type."
   :convert-widget 'widget-types-convert-widget
 
 (define-widget 'editable-list 'default
   "A variable list of widgets of the same type."
   :convert-widget 'widget-types-convert-widget

+  :copy 'widget-types-copy

   :offset 12
   :format "%v%i\n"
   :format-handler 'widget-editable-list-format-handler
   :entry-format "%i %d %v"
   :offset 12
   :format "%v%i\n"
   :format-handler 'widget-editable-list-format-handler
   :entry-format "%i %d %v"

-  :menu-tag "editable-list"

   :value-create 'widget-editable-list-value-create
   :value-create 'widget-editable-list-value-create

-  :value-delete 'widget-children-value-delete

   :value-get 'widget-editable-list-value-get
   :value-get 'widget-editable-list-value-get

-  :validate 'widget-editable-list-validate
+  :validate 'widget-children-validate

   :match 'widget-editable-list-match
   :match-inline 'widget-editable-list-match-inline
   :insert-before 'widget-editable-list-insert-before
   :match 'widget-editable-list-match
   :match-inline 'widget-editable-list-match-inline
   :insert-before 'widget-editable-list-insert-before


@@ -2025,21 +2513,22 @@ With optional ARG, move across that many fields."
 
 (defun widget-editable-list-format-handler (widget escape)
   ;; We recognize the insert button.
 
 (defun widget-editable-list-format-handler (widget escape)
   ;; We recognize the insert button.

-  (let ((widget-push-button-gui widget-editable-list-gui))
+    ;; (let ((widget-push-button-gui widget-editable-list-gui))

     (cond ((eq escape ?i)
           (and (widget-get widget :indent)
     (cond ((eq escape ?i)
           (and (widget-get widget :indent)

-               (insert-char ?  (widget-get widget :indent)))
-          (apply 'widget-create-child-and-convert 
+               (insert-char ?\  (widget-get widget :indent)))
+          (apply 'widget-create-child-and-convert

                  widget 'insert-button
                  (widget-get widget :append-button-args)))
                  widget 'insert-button
                  (widget-get widget :append-button-args)))

-         (t 
-          (widget-default-format-handler widget escape)))))
+         (t
+          (widget-default-format-handler widget escape)))
+    ;; )
+  )

 
 (defun widget-editable-list-value-create (widget)
   ;; Insert all values
   (let* ((value (widget-get widget :value))
         (type (nth 0 (widget-get widget :args)))
 
 (defun widget-editable-list-value-create (widget)
   ;; Insert all values
   (let* ((value (widget-get widget :value))
         (type (nth 0 (widget-get widget :args)))

-        (inlinep (widget-get type :inline))

         children)
     (widget-put widget :value-pos (copy-marker (point)))
     (set-marker-insertion-type (widget-get widget :value-pos) t)
         children)
     (widget-put widget :value-pos (copy-marker (point)))
     (set-marker-insertion-type (widget-get widget :value-pos) t)


@@ -2048,7 +2537,7 @@ With optional ARG, move across that many fields."
        (if answer
            (setq children (cons (widget-editable-list-entry-create
                                  widget
        (if answer
            (setq children (cons (widget-editable-list-entry-create
                                  widget

-                                 (if inlinep
+                                 (if (widget-get type :inline)

                                      (car answer)
                                    (car (car answer)))
                                  t)
                                      (car answer)
                                    (car (car answer)))
                                  t)


@@ -2062,16 +2551,6 @@ With optional ARG, move across that many fields."
   (apply 'append (mapcar (lambda (child) (widget-apply child :value-inline))
                         (widget-get widget :children))))
 
   (apply 'append (mapcar (lambda (child) (widget-apply child :value-inline))
                         (widget-get widget :children))))
 

-(defun widget-editable-list-validate (widget)
-  ;; All the chilren must be valid.
-  (let ((children (widget-get widget :children))
-       child found)
-    (while (and children (not found))
-      (setq child (car children)
-           children (cdr children)
-           found (widget-apply child :validate)))
-    found))
-

 (defun widget-editable-list-match (widget value)
   ;; Value must be a list and all the members must match the type.
   (and (listp value)
 (defun widget-editable-list-match (widget value)
   ;; Value must be a list and all the members must match the type.
   (and (listp value)


@@ -2083,7 +2562,7 @@ With optional ARG, move across that many fields."
        found)
     (while (and value ok)
       (let ((answer (widget-match-inline type value)))
        found)
     (while (and value ok)
       (let ((answer (widget-match-inline type value)))

-       (if answer 
+       (if answer

            (setq found (append found (car answer))
                  value (cdr answer))
          (setq ok nil))))
            (setq found (append found (car answer))
                  value (cdr answer))
          (setq ok nil))))


@@ -2094,25 +2573,24 @@ With optional ARG, move across that many fields."
   (save-excursion
     (let ((children (widget-get widget :children))
          (inhibit-read-only t)
   (save-excursion
     (let ((children (widget-get widget :children))
          (inhibit-read-only t)

+         before-change-functions

          after-change-functions)
          after-change-functions)

-      (cond (before 
+      (cond (before

             (goto-char (widget-get before :entry-from)))
            (t
             (goto-char (widget-get widget :value-pos))))
             (goto-char (widget-get before :entry-from)))
            (t
             (goto-char (widget-get widget :value-pos))))

-      (let ((child (widget-editable-list-entry-create 
+      (let ((child (widget-editable-list-entry-create

                    widget nil nil)))
        (when (< (widget-get child :entry-from) (widget-get widget :from))
          (set-marker (widget-get widget :from)
                      (widget-get child :entry-from)))
                    widget nil nil)))
        (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))
            (setq children (cdr children)))
          (setcdr children (cons child (cdr children)))))))
   (widget-setup)
        (if (eq (car children) before)
            (widget-put widget :children (cons child children))
          (while (not (eq (car (cdr children)) before))
            (setq children (cdr children)))
          (setcdr children (cons child (cdr children)))))))
   (widget-setup)

- widget (widget-apply widget :notify widget))
+  (widget-apply widget :notify widget))

 
 (defun widget-editable-list-delete-at (widget child)
   ;; Delete child from list of children.
 
 (defun widget-editable-list-delete-at (widget child)
   ;; Delete child from list of children.


@@ -2120,6 +2598,7 @@ With optional ARG, move across that many fields."
     (let ((buttons (copy-sequence (widget-get widget :buttons)))
          button
          (inhibit-read-only t)
     (let ((buttons (copy-sequence (widget-get widget :buttons)))
          button
          (inhibit-read-only t)

+         before-change-functions

          after-change-functions)
       (while buttons
        (setq button (car buttons)
          after-change-functions)
       (while buttons
        (setq button (car buttons)


@@ -2131,6 +2610,7 @@ With optional ARG, move across that many fields."
     (let ((entry-from (widget-get child :entry-from))
          (entry-to (widget-get child :entry-to))
          (inhibit-read-only t)
     (let ((entry-from (widget-get child :entry-from))
          (entry-to (widget-get child :entry-to))
          (inhibit-read-only t)

+         before-change-functions

          after-change-functions)
       (widget-delete child)
       (delete-region entry-from entry-to)
          after-change-functions)
       (widget-delete child)
       (delete-region entry-from entry-to)


@@ -2143,19 +2623,19 @@ With optional ARG, move across that many fields."
 (defun widget-editable-list-entry-create (widget value conv)
   ;; Create a new entry to the list.
   (let ((type (nth 0 (widget-get widget :args)))
 (defun widget-editable-list-entry-create (widget value conv)
   ;; Create a new entry to the list.
   (let ((type (nth 0 (widget-get widget :args)))

-       (widget-push-button-gui widget-editable-list-gui)
+       ;; (widget-push-button-gui widget-editable-list-gui)

        child delete insert)
        child delete insert)

-    (widget-specify-insert 
+    (widget-specify-insert

      (save-excursion
        (and (widget-get widget :indent)
      (save-excursion
        (and (widget-get widget :indent)

-           (insert-char ?  (widget-get widget :indent)))
+           (insert-char ?\  (widget-get widget :indent)))

        (insert (widget-get widget :entry-format)))
      ;; Parse % escapes in format.
      (while (re-search-forward "%\\(.\\)" nil t)
        (insert (widget-get widget :entry-format)))
      ;; Parse % escapes in format.
      (while (re-search-forward "%\\(.\\)" nil t)

-       (let ((escape (aref (match-string 1) 0)))
-        (replace-match "" t t)
+       (let ((escape (char-after (match-beginning 1))))
+        (delete-backward-char 2)

         (cond ((eq escape ?%)
         (cond ((eq escape ?%)

-               (insert "%"))
+               (insert ?%))

               ((eq escape ?i)
                (setq insert (apply 'widget-create-child-and-convert
                                    widget 'insert-button
               ((eq escape ?i)
                (setq insert (apply 'widget-create-child-and-convert
                                    widget 'insert-button


@@ -2166,36 +2646,37 @@ With optional ARG, move across that many fields."
                                    (widget-get widget :delete-button-args))))
               ((eq escape ?v)
                (if conv
                                    (widget-get widget :delete-button-args))))
               ((eq escape ?v)
                (if conv

-                   (setq child (widget-create-child-value 
+                   (setq child (widget-create-child-value

                                 widget type value))
                                 widget type value))

-                 (setq child (widget-create-child widget type))))
-              (t 
+                 (setq child (widget-create-child-value
+                              widget type (widget-default-get type)))))
+              (t

                (error "Unknown escape `%c'" escape)))))
                (error "Unknown escape `%c'" escape)))))

-     (widget-put widget 
-                :buttons (cons delete 
-                               (cons insert
-                                     (widget-get widget :buttons))))
-     (let ((entry-from (copy-marker (point-min)))
-          (entry-to (copy-marker (point-max))))
-       (widget-specify-text entry-from entry-to)
+     (let ((buttons (widget-get widget :buttons)))
+       (if insert (push insert buttons))
+       (if delete (push delete buttons))
+       (widget-put widget :buttons buttons))
+     (let ((entry-from (point-min-marker))
+          (entry-to (point-max-marker)))

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

-    (widget-put insert :widget child)
-    (widget-put delete :widget child)
+    (if insert (widget-put insert :widget child))
+    (if delete (widget-put delete :widget child))

     child))
 
 ;;; The `group' Widget.
 
 (define-widget 'group 'default
     child))
 
 ;;; The `group' Widget.
 
 (define-widget 'group 'default

-  "A widget which group other widgets inside."
+  "A widget which groups other widgets inside."

   :convert-widget 'widget-types-convert-widget
   :convert-widget 'widget-types-convert-widget

+  :copy 'widget-types-copy

   :format "%v"
   :value-create 'widget-group-value-create
   :format "%v"
   :value-create 'widget-group-value-create

-  :value-delete 'widget-children-value-delete

   :value-get 'widget-editable-list-value-get
   :value-get 'widget-editable-list-value-get

-  :validate 'widget-editable-list-validate
+  :default-get 'widget-group-default-get
+  :validate 'widget-children-validate

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


@@ -2211,16 +2692,20 @@ With optional ARG, move across that many fields."
            value (cdr answer))
       (and (eq (preceding-char) ?\n)
           (widget-get widget :indent)
            value (cdr answer))
       (and (eq (preceding-char) ?\n)
           (widget-get widget :indent)

-          (insert-char ?  (widget-get widget :indent)))
+          (insert-char ?\  (widget-get widget :indent)))

       (push (cond ((null answer)
                   (widget-create-child widget arg))
                  ((widget-get arg :inline)
       (push (cond ((null answer)
                   (widget-create-child widget arg))
                  ((widget-get arg :inline)

-                  (widget-create-child-value widget arg  (car answer)))
+                  (widget-create-child-value widget arg (car answer)))

                  (t
                  (t

-                  (widget-create-child-value widget arg  (car (car answer)))))
+                  (widget-create-child-value widget arg (car (car answer)))))

            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)


@@ -2235,31 +2720,167 @@ With optional ARG, move across that many fields."
       (setq argument (car args)
            args (cdr args)
            answer (widget-match-inline argument vals))
       (setq argument (car args)
            args (cdr args)
            answer (widget-match-inline argument vals))

-      (if answer 
+      (if answer

          (setq vals (cdr answer)
                found (append found (car answer)))
        (setq vals nil
              args nil)))
     (if answer
          (setq vals (cdr answer)
                found (append found (car answer)))
        (setq vals nil
              args nil)))
     (if answer

-       (cons found vals)
-      nil)))
+       (cons found vals))))

 
 

-;;; The `widget-help' Widget.
+;;; The `visibility' Widget.

 
 

-(define-widget 'widget-help 'push-button
-  "The widget documentation button."
-  :format "%[[%t]%] %d"
-  :help-echo "Toggle display of documentation."
-  :action 'widget-help-action)
+(define-widget 'visibility 'item
+  "An indicator and manipulator for hidden items."
+  :format "%[%v%]"
+  :button-prefix ""
+  :button-suffix ""
+  :on "Hide"
+  :off "Show"
+  :value-create 'widget-visibility-value-create
+  :action 'widget-toggle-action
+  :match (lambda (widget value) t))

 
 

-(defun widget-help-action (widget &optional event)
-  "Toggle documentation for WIDGET."
-  (let ((old (widget-get widget :doc))
-       (new (widget-get widget :widget-doc)))
-    (widget-put widget :doc new)
-    (widget-put widget :widget-doc old))
-  (widget-value-set widget (widget-value widget)))
+(defun widget-visibility-value-create (widget)
+  ;; Insert text representing the `on' and `off' states.
+  (let ((on (widget-get widget :on))
+       (off (widget-get widget :off)))
+    (if on
+       (setq on (concat widget-push-button-prefix
+                        on
+                        widget-push-button-suffix))
+      (setq on ""))
+    (if off
+       (setq off (concat widget-push-button-prefix
+                         off
+                         widget-push-button-suffix))
+      (setq off ""))
+    (if (widget-value widget)
+       (widget-image-insert widget on "down" "down-pushed")
+      (widget-image-insert widget off "right" "right-pushed"))))
+
+;;; The `documentation-link' Widget.
+;;
+;; This is a helper widget for `documentation-string'.
+
+(define-widget 'documentation-link 'link
+  "Link type used in documentation strings."
+  :tab-order -1
+  :help-echo "Describe this symbol"
+  :action 'widget-documentation-link-action)
+
+(defun widget-documentation-link-action (widget &optional event)
+  "Display documentation for WIDGET's value.  Ignore optional argument EVENT."
+  (let* ((string (widget-get widget :value))
+        (symbol (intern string)))
+    (if (and (fboundp symbol) (boundp symbol))
+       ;; If there are two doc strings, give the user a way to pick one.
+       (apropos (concat "\\`" (regexp-quote string) "\\'"))
+      (if (fboundp symbol)
+         (describe-function symbol)
+       (describe-variable symbol)))))
+
+(defcustom widget-documentation-links t
+  "Add hyperlinks to documentation strings when non-nil."
+  :type 'boolean
+  :group 'widget-documentation)
+
+(defcustom widget-documentation-link-regexp "`\\([^\n`' ]+\\)'"
+  "Regexp for matching potential links in documentation strings.
+The first group should be the link itself."
+  :type 'regexp
+  :group 'widget-documentation)
+
+(defcustom widget-documentation-link-p 'intern-soft
+  "Predicate used to test if a string is useful as a link.
+The value should be a function.  The function will be called one
+argument, a string, and should return non-nil if there should be a
+link for that string."
+  :type 'function
+  :options '(widget-documentation-link-p)
+  :group 'widget-documentation)
+
+(defcustom widget-documentation-link-type 'documentation-link
+  "Widget type used for links in documentation strings."
+  :type 'symbol
+  :group 'widget-documentation)
+
+(defun widget-documentation-link-add (widget from to)
+  (widget-specify-doc widget from to)
+  (when widget-documentation-links
+    (let ((regexp widget-documentation-link-regexp)
+         (buttons (widget-get widget :buttons))
+         (widget-mouse-face (default-value 'widget-mouse-face))
+         (widget-button-face widget-documentation-face)
+         (widget-button-pressed-face widget-documentation-face))
+      (save-excursion
+       (goto-char from)
+       (while (re-search-forward regexp to t)
+         (let ((name (match-string 1))
+               (begin (match-beginning 1))
+               (end (match-end 1)))
+           (when (funcall widget-documentation-link-p name)
+             (push (widget-convert-button widget-documentation-link-type
+                                          begin end :value name)
+                   buttons)))))
+      (widget-put widget :buttons buttons)))
+  (let ((indent (widget-get widget :indent)))
+    (when (and indent (not (zerop indent)))
+      (save-excursion
+       (save-restriction
+         (narrow-to-region from to)
+         (goto-char (point-min))
+         (while (search-forward "\n" nil t)
+           (insert-char ?\  indent)))))))

 
 

+;;; The `documentation-string' Widget.
+
+(define-widget 'documentation-string 'item
+  "A documentation string."
+  :format "%v"
+  :action 'widget-documentation-string-action
+  :value-create 'widget-documentation-string-value-create)
+
+(defun widget-documentation-string-value-create (widget)
+  ;; Insert documentation string.
+  (let ((doc (widget-value widget))
+       (indent (widget-get widget :indent))
+       (shown (widget-get (widget-get widget :parent) :documentation-shown))
+       (start (point)))
+    (if (string-match "\n" doc)
+       (let ((before (substring doc 0 (match-beginning 0)))
+             (after (substring doc (match-beginning 0)))
+             button)
+         (insert before ?\ )
+         (widget-documentation-link-add widget start (point))
+         (setq button
+               (widget-create-child-and-convert
+                widget 'visibility
+                :help-echo "Show or hide rest of the documentation."
+                :on "Hide Rest"
+                :off "More"
+                :always-active t
+                :action 'widget-parent-action
+                shown))
+         (when shown
+           (setq start (point))
+           (when (and indent (not (zerop indent)))
+             (insert-char ?\  indent))
+           (insert after)
+           (widget-documentation-link-add widget start (point)))
+         (widget-put widget :buttons (list button)))
+      (insert doc)
+      (widget-documentation-link-add widget start (point))))
+  (insert ?\n))
+
+(defun widget-documentation-string-action (widget &rest ignore)
+  ;; Toggle documentation.
+  (let ((parent (widget-get widget :parent)))
+    (widget-put parent :documentation-shown
+               (not (widget-get parent :documentation-shown))))
+  ;; Redraw.
+  (widget-value-set widget (widget-value widget)))
+\f

 ;;; The Sexp Widgets.
 
 (define-widget 'const 'item
 ;;; The Sexp Widgets.
 
 (define-widget 'const 'item


@@ -2284,85 +2905,130 @@ With optional ARG, move across that many fields."
   :format "%v\n%h"
   :documentation-property 'variable-documentation)
 
   :format "%v\n%h"
   :documentation-property 'variable-documentation)
 

-(define-widget 'string 'editable-field
-  "A string"
-  :prompt-value 'widget-string-prompt-value
-  :tag "String"
-  :format "%[%t%]: %v")
+(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'.")
 

-(defun widget-string-prompt-value (widget prompt value unbound)
-  ;; Read a string.
-  (read-string prompt (if unbound nil (cons value 1))
-              'widget-string-prompt-value-history))
+(define-widget 'string 'editable-field
+  "A string"
+  :tag "String"
+  :format "%{%t%}: %v"
+  :complete-function 'ispell-complete-word
+  :prompt-history 'widget-string-prompt-value-history)

 
 (define-widget 'regexp 'string
   "A regular expression."
   :match 'widget-regexp-match
   :validate 'widget-regexp-validate
 
 (define-widget 'regexp 'string
   "A regular expression."
   :match 'widget-regexp-match
   :validate 'widget-regexp-validate

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

   :tag "Regexp")
 
 (defun widget-regexp-match (widget value)
   ;; Match valid regexps.
   (and (stringp value)
   :tag "Regexp")
 
 (defun widget-regexp-match (widget value)
   ;; Match valid regexps.
   (and (stringp value)

-       (condition-case data
+       (condition-case nil

           (prog1 t
             (string-match value ""))
         (error nil))))
 
 (defun widget-regexp-validate (widget)
   "Check that the value of WIDGET is a valid regexp."
           (prog1 t
             (string-match value ""))
         (error nil))))
 
 (defun widget-regexp-validate (widget)
   "Check that the value of WIDGET is a valid regexp."

-  (let ((val (widget-value widget)))
-    (condition-case data
-       (prog1 nil
-         (string-match val ""))
-      (error (widget-put widget :error (error-message-string data))
-            widget))))
+  (condition-case data
+      (prog1 nil
+       (string-match (widget-value widget) ""))
+    (error (widget-put widget :error (error-message-string data))
+          widget)))

 
 (define-widget 'file 'string
 
 (define-widget 'file 'string

-  "A file widget.  
-It will read a file name from the minibuffer when activated."
+  "A file widget.
+It will read a file name from the minibuffer when invoked."
+  :complete-function 'widget-file-complete

   :prompt-value 'widget-file-prompt-value
   :prompt-value 'widget-file-prompt-value

-  :format "%[%t%]: %v"
-  :tag "File"
-  :action 'widget-file-action)
+  :format "%{%t%}: %v"
+  ;; Doesn't work well with terminating newline.
+  ;; :value-face 'widget-single-line-field-face
+  :tag "File")
+
+(defun widget-file-complete ()
+  "Perform completion on file name preceding point."
+  (interactive)
+  (let* ((end (point))
+        (beg (save-excursion
+               (skip-chars-backward "^ ")
+               (point)))
+        (pattern (buffer-substring beg end))
+        (name-part (file-name-nondirectory pattern))
+        (directory (file-name-directory pattern))
+        (completion (file-name-completion name-part directory)))
+    (cond ((eq completion t))
+         ((null completion)
+          (message "Can't find completion for \"%s\"" pattern)
+          (ding))
+         ((not (string= name-part completion))
+          (delete-region beg end)
+          (insert (expand-file-name completion directory)))
+         (t
+          (message "Making completion list...")
+          (with-output-to-temp-buffer "*Completions*"
+            (display-completion-list
+             (sort (file-name-all-completions name-part directory)
+                   'string<)))
+          (message "Making completion list...%s" "done")))))

 
 (defun widget-file-prompt-value (widget prompt value unbound)
   ;; Read file from minibuffer.
   (abbreviate-file-name
    (if unbound
        (read-file-name prompt)
 
 (defun widget-file-prompt-value (widget prompt value unbound)
   ;; Read file from minibuffer.
   (abbreviate-file-name
    (if unbound
        (read-file-name prompt)

-     (let ((prompt2 (concat prompt "(default `" value "') "))
+     (let ((prompt2 (format "%s (default %s) " prompt value))

           (dir (file-name-directory value))
           (file (file-name-nondirectory value))
           (must-match (widget-get widget :must-match)))
        (read-file-name prompt2 dir nil must-match file)))))
 
           (dir (file-name-directory value))
           (file (file-name-nondirectory value))
           (must-match (widget-get widget :must-match)))
        (read-file-name prompt2 dir nil must-match file)))))
 

-(defun widget-file-action (widget &optional event)
-  ;; Read a file name from the minibuffer.
-  (let* ((value (widget-value widget))
-        (dir (file-name-directory value))
-        (file (file-name-nondirectory value))
-        (menu-tag (widget-apply widget :menu-tag-get))
-        (must-match (widget-get widget :must-match))
-        (answer (read-file-name (concat menu-tag ": (default `" value "') ")
-                                dir nil must-match file)))
-    (widget-value-set widget (abbreviate-file-name answer))
-    (widget-apply widget :notify widget event)
-    (widget-setup)))
-
+;;;(defun widget-file-action (widget &optional event)
+;;;  ;; Read a file name from the minibuffer.
+;;;  (let* ((value (widget-value widget))
+;;;     (dir (file-name-directory value))
+;;;     (file (file-name-nondirectory value))
+;;;     (menu-tag (widget-apply widget :menu-tag-get))
+;;;     (must-match (widget-get widget :must-match))
+;;;     (answer (read-file-name (concat menu-tag ": (default `" value "') ")
+;;;                             dir nil must-match file)))
+;;;    (widget-value-set widget (abbreviate-file-name answer))
+;;;    (widget-setup)
+;;;    (widget-apply widget :notify widget event)))
+
+;; Fixme: use file-name-as-directory.

 (define-widget 'directory 'file
 (define-widget 'directory 'file

-  "A directory widget.  
-It will read a directory name from the minibuffer when activated."
+  "A directory widget.
+It will read a directory name from the minibuffer when invoked."

   :tag "Directory")
 
   :tag "Directory")
 

-(define-widget 'symbol 'string
-  "A lisp symbol."
+(defvar widget-symbol-prompt-value-history nil
+  "History of input to `widget-symbol-prompt-value'.")
+
+(define-widget 'symbol 'editable-field
+  "A Lisp symbol."

   :value nil
   :tag "Symbol"
   :value nil
   :tag "Symbol"

+  :format "%{%t%}: %v"

   :match (lambda (widget value) (symbolp value))
   :match (lambda (widget value) (symbolp value))

+  :complete-function 'lisp-complete-symbol
+  :prompt-internal 'widget-symbol-prompt-internal
+  :prompt-match 'symbolp
+  :prompt-history 'widget-symbol-prompt-value-history

   :value-to-internal (lambda (widget value)
                       (if (symbolp value)
                           (symbol-name value)
   :value-to-internal (lambda (widget value)
                       (if (symbolp value)
                           (symbol-name value)


@@ -2372,29 +3038,109 @@ It will read a directory name from the minibuffer when activated."
                           (intern value)
                         value)))
 
                           (intern value)
                         value)))
 

+(defun widget-symbol-prompt-internal (widget prompt initial history)
+  ;; Read file from minibuffer.
+  (let ((answer (completing-read prompt obarray
+                                (widget-get widget :prompt-match)
+                                nil initial history)))
+    (if (and (stringp answer)
+            (not (zerop (length answer))))
+       answer
+      (error "No value"))))
+
+(defvar widget-function-prompt-value-history nil
+  "History of input to `widget-function-prompt-value'.")
+

 (define-widget 'function 'sexp
 (define-widget 'function 'sexp

-  ;; Should complete on functions.
-  "A lisp function."
+  "A Lisp function."
+  :complete-function (lambda ()
+                      (interactive)
+                      (lisp-complete-symbol 'fboundp))
+  :prompt-value 'widget-field-prompt-value
+  :prompt-internal 'widget-symbol-prompt-internal
+  :prompt-match 'fboundp
+  :prompt-history 'widget-function-prompt-value-history
+  :action 'widget-field-action
+  :match-alternatives '(functionp)
+  :validate (lambda (widget)
+             (unless (functionp (widget-value widget))
+               (widget-put widget :error (format "Invalid function: %S"
+                                                 (widget-value widget)))
+               widget))
+  :value 'ignore

   :tag "Function")
 
   :tag "Function")
 

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

 (define-widget 'variable 'symbol
 (define-widget 'variable 'symbol

-  ;; Should complete on variables.
-  "A lisp variable."
+  "A Lisp variable."
+  :prompt-match 'boundp
+  :prompt-history 'widget-variable-prompt-value-history
+  :complete-function (lambda ()
+                      (interactive)
+                      (lisp-complete-symbol 'boundp))

   :tag "Variable")
 
   :tag "Variable")
 

-(define-widget 'sexp 'string
-  "An arbitrary lisp expression."
+(defvar widget-coding-system-prompt-value-history nil
+  "History of input to `widget-coding-system-prompt-value'.")
+
+(define-widget 'coding-system 'symbol
+  "A MULE coding-system."
+  :format "%{%t%}: %v"
+  :tag "Coding system"
+  :base-only nil
+  :prompt-history 'widget-coding-system-prompt-value-history
+  :prompt-value 'widget-coding-system-prompt-value
+  :action 'widget-coding-system-action
+  :complete-function (lambda ()
+                      (interactive)
+                      (lisp-complete-symbol 'coding-system-p))
+  :validate (lambda (widget)
+             (unless (coding-system-p (widget-value widget))
+               (widget-put widget :error (format "Invalid coding system: %S"
+                                                 (widget-value widget)))
+               widget))
+  :value 'undecided
+  :prompt-match 'coding-system-p)
+
+(defun widget-coding-system-prompt-value (widget prompt value unbound)
+  "Read coding-system from minibuffer."
+  (if (widget-get widget :base-only)
+      (intern
+       (completing-read (format "%s (default %s) " prompt value)
+                       (mapcar #'list (coding-system-list t)) nil nil nil
+                       coding-system-history))
+      (read-coding-system (format "%s (default %s) " prompt value) value)))
+
+(defun widget-coding-system-action (widget &optional event)
+  (let ((answer
+        (widget-coding-system-prompt-value
+         widget
+         (widget-apply widget :menu-tag-get)
+         (widget-value widget)
+         t)))
+    (widget-value-set widget answer)
+    (widget-apply widget :notify widget event)
+    (widget-setup)))
+\f
+(define-widget 'sexp 'editable-field
+  "An arbitrary Lisp expression."

   :tag "Lisp expression"
   :tag "Lisp expression"

+  :format "%{%t%}: %v"

   :value nil
   :validate 'widget-sexp-validate
   :match (lambda (widget value) t)
   :value-to-internal 'widget-sexp-value-to-internal
   :value-to-external (lambda (widget value) (read value))
   :value nil
   :validate 'widget-sexp-validate
   :match (lambda (widget value) t)
   :value-to-internal 'widget-sexp-value-to-internal
   :value-to-external (lambda (widget value) (read value))

+  :prompt-history 'widget-sexp-prompt-value-history

   :prompt-value 'widget-sexp-prompt-value)
 
 (defun widget-sexp-value-to-internal (widget value)
   ;; Use pp for printer representation.
   :prompt-value 'widget-sexp-prompt-value)
 
 (defun widget-sexp-value-to-internal (widget value)
   ;; Use pp for printer representation.

-  (let ((pp (pp-to-string value)))
+  (let ((pp (if (symbolp value)
+               (prin1-to-string value)
+             (pp-to-string value))))

     (while (string-match "\n\\'" pp)
       (setq pp (substring pp 0 -1)))
     (if (or (string-match "\n\\'" pp)
     (while (string-match "\n\\'" pp)
       (setq pp (substring pp 0 -1)))
     (if (or (string-match "\n\\'" pp)


@@ -2404,25 +3150,32 @@ It will read a directory name from the minibuffer when activated."
 
 (defun widget-sexp-validate (widget)
   ;; Valid if we can read the string and there is no junk left after it.
 
 (defun widget-sexp-validate (widget)
   ;; Valid if we can read the string and there is no junk left after it.

-  (save-excursion
-    (let ((buffer (set-buffer (get-buffer-create " *Widget Scratch*"))))
-      (erase-buffer)
-      (insert (widget-apply widget :value-get))
-      (goto-char (point-min))
+  (with-temp-buffer
+    (insert (widget-apply widget :value-get))
+    (goto-char (point-min))
+    (let (err)

       (condition-case data
       (condition-case data

-         (let ((value (read buffer)))
+         (progn
+           ;; Avoid a confusing end-of-file error.
+           (skip-syntax-forward "\\s-")

            (if (eobp)
            (if (eobp)

-               (if (widget-apply widget :match value)
-                   nil
-                 (widget-put widget :error (widget-get widget :type-error))
-                 widget)
-             (widget-put widget
-                         :error (format "Junk at end of expression: %s"
-                                        (buffer-substring (point)
-                                                          (point-max))))
-             widget))
-       (error (widget-put widget :error (error-message-string data))
-              widget)))))
+               (setq err "Empty sexp -- use `nil'?")
+             (unless (widget-apply widget :match (read (current-buffer)))
+               (setq err (widget-get widget :type-error))))
+           ;; Allow whitespace after expression.
+           (skip-syntax-forward "\\s-")
+           (if (and (not (eobp))
+                    (not err))
+               (setq err (format "Junk at end of expression: %s"
+                                 (buffer-substring (point)
+                                                   (point-max))))))
+       (end-of-file                    ; Avoid confusing error message.
+        (setq err "Unbalanced sexp"))
+       (error (setq err (error-message-string data))))
+      (if (not err)
+         nil
+       (widget-put widget :error err)
+       widget))))

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


@@ -2430,72 +3183,91 @@ It will read a directory name from the minibuffer when activated."
 (defun widget-sexp-prompt-value (widget prompt value unbound)
   ;; Read an arbitrary sexp.
   (let ((found (read-string prompt
 (defun widget-sexp-prompt-value (widget prompt value unbound)
   ;; Read an arbitrary sexp.
   (let ((found (read-string prompt

-                           (if unbound nil (cons (prin1-to-string value) 1))
-                           'widget-sexp-prompt-value)))
-    (let ((buffer (set-buffer (get-buffer-create " *Widget Scratch*"))))
-      (erase-buffer)
-      (insert found)
-      (goto-char (point-min))
-      (let ((answer (read buffer)))
-       (unless (eobp)
-         (error "Junk at end of expression: %s"
-                (buffer-substring (point) (point-max))))
-       answer))))
-  
-(define-widget 'integer 'sexp
+                           (if unbound nil (cons (prin1-to-string value) 0))
+                           (widget-get widget :prompt-history))))
+    (let ((answer (read-from-string found)))
+      (unless (= (cdr answer) (length found))
+       (error "Junk at end of expression: %s"
+              (substring found (cdr answer))))
+      (car answer))))
+
+(define-widget 'restricted-sexp 'sexp
+  "A Lisp expression restricted to values that match.
+To use this type, you must define :match or :match-alternatives."
+  :type-error "The specified value is not valid"
+  :match 'widget-restricted-sexp-match
+  :value-to-internal (lambda (widget value)
+                      (if (widget-apply widget :match value)
+                          (prin1-to-string value)
+                        value)))
+
+(defun widget-restricted-sexp-match (widget value)
+  (let ((alternatives (widget-get widget :match-alternatives))
+       matched)
+    (while (and alternatives (not matched))
+      (if (cond ((functionp (car alternatives))
+                (funcall (car alternatives) value))
+               ((and (consp (car alternatives))
+                     (eq (car (car alternatives)) 'quote))
+                (eq value (nth 1 (car alternatives)))))
+         (setq matched t))
+      (setq alternatives (cdr alternatives)))
+    matched))
+\f
+(define-widget 'integer 'restricted-sexp

   "An integer."
   :tag "Integer"
   :value 0
   :type-error "This field should contain an integer"
   "An integer."
   :tag "Integer"
   :value 0
   :type-error "This field should contain an integer"

-  :value-to-internal (lambda (widget value)
-                      (if (integerp value) 
-                          (prin1-to-string value)
-                        value))
-  :match (lambda (widget value) (integerp value)))
+  :match-alternatives '(integerp))
+
+(define-widget 'number 'restricted-sexp
+  "A number (floating point or integer)."
+  :tag "Number"
+  :value 0.0
+  :type-error "This field should contain a number (floating point or integer)"
+  :match-alternatives '(numberp))
+
+(define-widget 'float 'restricted-sexp
+  "A floating point number."
+  :tag "Floating point number"
+  :value 0.0
+  :type-error "This field should contain a floating point number"
+  :match-alternatives '(floatp))

 
 

-(define-widget 'character 'string
-  "An character."
+(define-widget 'character 'editable-field
+  "A character."

   :tag "Character"
   :value 0
   :tag "Character"
   :value 0

-  :size 1 
+  :size 1

   :format "%{%t%}: %v\n"
   :valid-regexp "\\`.\\'"
   :error "This field should contain a single character"
   :value-to-internal (lambda (widget value)
   :format "%{%t%}: %v\n"
   :valid-regexp "\\`.\\'"
   :error "This field should contain a single character"
   :value-to-internal (lambda (widget value)

-                      (if (integerp value) 
-                          (char-to-string value)
-                        value))
+                      (if (stringp value)
+                          value
+                        (char-to-string value)))

   :value-to-external (lambda (widget value)
                       (if (stringp value)
                           (aref value 0)
                         value))
   :value-to-external (lambda (widget value)
                       (if (stringp value)
                           (aref value 0)
                         value))

-  :match (lambda (widget value) (integerp value)))
-
-(define-widget 'number 'sexp
-  "A floating point number."
-  :tag "Number"
-  :value 0.0
-  :type-error "This field should contain a number"
-  :value-to-internal (lambda (widget value)
-                      (if (numberp value)
-                          (prin1-to-string value)
-                        value))
-  :match (lambda (widget value) (numberp value)))
+  :match (lambda (widget value)
+          (char-valid-p value)))

 
 (define-widget 'list 'group
 
 (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
   :value-to-internal (lambda (widget value) (append value nil))
   :value-to-external (lambda (widget value) (apply 'vector value)))
 
   :tag "Vector"
   :format "%{%t%}:\n%v"
   :match 'widget-vector-match
   :value-to-internal (lambda (widget value) (append value nil))
   :value-to-external (lambda (widget value) (apply 'vector value)))
 

-(defun widget-vector-match (widget value) 
+(defun widget-vector-match (widget value)

   (and (vectorp value)
        (widget-group-match widget
                           (widget-apply widget :value-to-internal value))))
   (and (vectorp value)
        (widget-group-match widget
                           (widget-apply widget :value-to-internal value))))


@@ -2508,22 +3280,213 @@ It will read a directory name from the minibuffer when activated."
   :value-to-internal (lambda (widget value)
                       (list (car value) (cdr value)))
   :value-to-external (lambda (widget value)
   :value-to-internal (lambda (widget value)
                       (list (car value) (cdr value)))
   :value-to-external (lambda (widget value)

-                      (cons (nth 0 value) (nth 1 value))))
+                      (apply 'cons value)))

 
 

-(defun widget-cons-match (widget value) 
+(defun widget-cons-match (widget value)

   (and (consp value)
        (widget-group-match widget
                           (widget-apply widget :value-to-internal value))))
   (and (consp value)
        (widget-group-match widget
                           (widget-apply widget :value-to-internal value))))

+\f
+;;; The `lazy' Widget.
+;;
+;; Recursive datatypes.
+
+(define-widget 'lazy 'default
+  "Base widget for recursive datastructures.
+
+The `lazy' widget will, when instantiated, contain a single inferior
+widget, of the widget type specified by the :type parameter.  The
+value of the `lazy' widget is the same as the value of the inferior
+widget.  When deriving a new widget from the 'lazy' widget, the :type
+parameter is allowed to refer to the widget currently being defined,
+thus allowing recursive datastructures to be described.
+
+The :type parameter takes the same arguments as the defcustom
+parameter with the same name.
+
+Most composite widgets, i.e. widgets containing other widgets, does
+not allow recursion.  That is, when you define a new widget type, none
+of the inferior widgets may be of the same type you are currently
+defining.
+
+In Lisp, however, it is custom to define datastructures in terms of
+themselves.  A list, for example, is defined as either nil, or a cons
+cell whose cdr itself is a list.  The obvious way to translate this
+into a widget type would be
+
+  (define-widget 'my-list 'choice
+    \"A list of sexps.\"
+    :tag \"Sexp list\"
+    :args '((const nil) (cons :value (nil) sexp my-list)))
+
+Here we attempt to define my-list as a choice of either the constant
+nil, or a cons-cell containing a sexp and my-lisp.  This will not work
+because the `choice' widget does not allow recursion.
+
+Using the `lazy' widget you can overcome this problem, as in this
+example:
+
+  (define-widget 'sexp-list 'lazy
+    \"A list of sexps.\"
+    :tag \"Sexp list\"
+    :type '(choice (const nil) (cons :value (nil) sexp sexp-list)))"
+  :format "%{%t%}: %v"
+  ;; We don't convert :type because we want to allow recursive
+  ;; datastructures.  This is slow, so we should not create speed
+  ;; critical widgets by deriving from this.
+  :convert-widget 'widget-value-convert-widget
+  :value-create 'widget-type-value-create
+  :value-get 'widget-child-value-get
+  :value-inline 'widget-child-value-inline
+  :default-get 'widget-type-default-get
+  :match 'widget-type-match
+  :validate 'widget-child-validate)
+
+\f
+;;; The `plist' Widget.
+;;
+;; Property lists.
+
+(define-widget 'plist 'list
+  "A property list."
+  :key-type '(symbol :tag "Key")
+  :value-type '(sexp :tag "Value")
+  :convert-widget 'widget-plist-convert-widget
+  :tag "Plist")
+
+(defvar widget-plist-value-type)       ;Dynamic variable
+
+(defun widget-plist-convert-widget (widget)
+  ;; Handle `:options'.
+  (let* ((options (widget-get widget :options))
+        (widget-plist-value-type (widget-get widget :value-type))
+        (other `(editable-list :inline t
+                               (group :inline t
+                                      ,(widget-get widget :key-type)
+                                      ,widget-plist-value-type)))
+        (args (if options
+                  (list `(checklist :inline t
+                                    :greedy t
+                                    ,@(mapcar 'widget-plist-convert-option
+                                              options))
+                        other)
+                (list other))))
+    (widget-put widget :args args)
+    widget))

 
 

+(defun widget-plist-convert-option (option)
+  ;; Convert a single plist option.
+  (let (key-type value-type)
+    (if (listp option)
+       (let ((key (nth 0 option)))
+         (setq value-type (nth 1 option))
+         (if (listp key)
+             (setq key-type key)
+           (setq key-type `(const ,key))))
+      (setq key-type `(const ,option)
+           value-type widget-plist-value-type))
+    `(group :format "Key: %v" :inline t ,key-type ,value-type)))
+
+
+;;; The `alist' Widget.
+;;
+;; Association lists.
+
+(define-widget 'alist 'list
+  "An association list."
+  :key-type '(sexp :tag "Key")
+  :value-type '(sexp :tag "Value")
+  :convert-widget 'widget-alist-convert-widget
+  :tag "Alist")
+
+(defvar widget-alist-value-type)       ;Dynamic variable
+
+(defun widget-alist-convert-widget (widget)
+  ;; Handle `:options'.
+  (let* ((options (widget-get widget :options))
+        (widget-alist-value-type (widget-get widget :value-type))
+        (other `(editable-list :inline t
+                               (cons :format "%v"
+                                     ,(widget-get widget :key-type)
+                                     ,widget-alist-value-type)))
+        (args (if options
+                  (list `(checklist :inline t
+                                    :greedy t
+                                    ,@(mapcar 'widget-alist-convert-option
+                                              options))
+                        other)
+                (list other))))
+    (widget-put widget :args args)
+    widget))
+
+(defun widget-alist-convert-option (option)
+  ;; Convert a single alist option.
+  (let (key-type value-type)
+    (if (listp option)
+       (let ((key (nth 0 option)))
+         (setq value-type (nth 1 option))
+         (if (listp key)
+             (setq key-type key)
+           (setq key-type `(const ,key))))
+      (setq key-type `(const ,option)
+           value-type widget-alist-value-type))
+    `(cons :format "Key: %v" ,key-type ,value-type)))
+\f

 (define-widget 'choice 'menu-choice
   "A union of several sexp types."
   :tag "Choice"
 (define-widget 'choice 'menu-choice
   "A union of several sexp types."
   :tag "Choice"

-  :format "%[%t%]: %v")
+  :format "%{%t%}: %[Value Menu%] %v"
+  :button-prefix 'widget-push-button-prefix
+  :button-suffix 'widget-push-button-suffix
+  :prompt-value 'widget-choice-prompt-value)

 
 

+(defun widget-choice-prompt-value (widget prompt value unbound)
+  "Make a choice."
+  (let ((args (widget-get widget :args))
+       (completion-ignore-case (widget-get widget :case-fold))
+       current choices old)
+    ;; Find the first arg that matches VALUE.
+    (let ((look args))
+      (while look
+       (if (widget-apply (car look) :match value)
+           (setq old (car look)
+                 look nil)
+         (setq look (cdr look)))))
+    ;; Find new choice.
+    (setq current
+         (cond ((= (length args) 0)
+                nil)
+               ((= (length args) 1)
+                (nth 0 args))
+               ((and (= (length args) 2)
+                     (memq old args))
+                (if (eq old (nth 0 args))
+                    (nth 1 args)
+                  (nth 0 args)))
+               (t
+                (while args
+                  (setq current (car args)
+                        args (cdr args))
+                  (setq choices
+                        (cons (cons (widget-apply current :menu-tag-get)
+                                    current)
+                              choices)))
+                (let ((val (completing-read prompt choices nil t)))
+                  (if (stringp val)
+                      (let ((try (try-completion val choices)))
+                        (when (stringp try)
+                          (setq val try))
+                        (cdr (assoc val choices)))
+                    nil)))))
+    (if current
+       (widget-prompt-value current prompt nil t)
+      value)))
+\f

 (define-widget 'radio 'radio-button-choice
   "A union of several sexp types."
   :tag "Choice"
 (define-widget 'radio 'radio-button-choice
   "A union of several sexp types."
   :tag "Choice"

-  :format "%{%t%}:\n%v")
+  :format "%{%t%}:\n%v"
+  :prompt-value 'widget-choice-prompt-value)

 
 (define-widget 'repeat 'editable-list
   "A variable length homogeneous list."
 
 (define-widget 'repeat 'editable-list
   "A variable length homogeneous list."


@@ -2539,140 +3502,88 @@ It will read a directory name from the minibuffer when activated."
   "To be nil or non-nil, that is the question."
   :tag "Boolean"
   :prompt-value 'widget-boolean-prompt-value
   "To be nil or non-nil, that is the question."
   :tag "Boolean"
   :prompt-value 'widget-boolean-prompt-value

-  :format "%{%t%}: %[%v%]\n")
+  :button-prefix 'widget-push-button-prefix
+  :button-suffix 'widget-push-button-suffix
+  :format "%{%t%}: %[Toggle%]  %v\n"
+  :on "on (non-nil)"
+  :off "off (nil)")

 
 (defun widget-boolean-prompt-value (widget prompt value unbound)
   ;; Toggle a boolean.
 
 (defun widget-boolean-prompt-value (widget prompt value unbound)
   ;; Toggle a boolean.

-  (cond (unbound
-        (y-or-n-p prompt))
-       (value
-        (message "Off")
-        nil)
-       (t
-        (message "On")
-        t)))
-
+  (y-or-n-p prompt))
+\f

 ;;; 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)
-  ;; We create a face from the value.
-  (require 'facemenu)
-  (condition-case nil
-      (facemenu-get-face (intern (concat "fg:" (widget-value widget))))
-    (error 'default)))
-
-(define-widget 'color 'push-button
+;; Fixme: match
+(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")
-
-(defvar widget-color-choice-list nil)
-;; Variable holding the possible colors.
-
-(defun widget-color-choice-list ()
-  (unless widget-color-choice-list
-    (setq widget-color-choice-list 
-         (mapcar '(lambda (color) (list color))
-                 (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")
+  :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."
+  (require 'facemenu)                  ; for facemenu-color-alist
+  (let* ((prefix (buffer-substring-no-properties (widget-field-start widget)
+                                                (point)))
+        (list (or facemenu-color-alist (defined-colors)))
+        (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...")
+          (with-output-to-temp-buffer "*Completions*"
+            (display-completion-list (all-completions prefix list nil)))
+          (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)))))
+    (if (color-defined-p value)
+       (list (cons 'foreground-color value))
+      'default)))

 
 (defun widget-color-action (widget &optional event)
 
 (defun widget-color-action (widget &optional event)

-  ;; Prompt for a color.
+  "Prompt for a color."

   (let* ((tag (widget-apply widget :menu-tag-get))
         (prompt (concat tag ": "))
   (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))
+        (answer (facemenu-read-color prompt)))

     (unless (zerop (length answer))
       (widget-value-set widget answer)
     (unless (zerop (length answer))
       (widget-value-set widget answer)

-      (widget-apply widget :notify widget event)
-      (widget-setup))))
-
+      (widget-setup)
+      (widget-apply widget :notify widget event))))
+
+(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))
+\f

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

-(defun widget-echo-help-mouse ()
-  "Display the help message for the widget under the mouse.
-Enable with (run-with-idle-timer 1 t 'widget-echo-help-mouse)"
-  (let* ((pos (mouse-position))
-        (frame (car pos))
-        (x (car (cdr pos)))
-        (y (cdr (cdr pos)))
-        (win (window-at x y frame))
-        (where (coordinates-in-window-p (cons x y) win)))
-    (when (consp where)
-      (save-window-excursion
-       (progn ; save-excursion
-         (select-window win)
-         (let* ((result (compute-motion (window-start win)
-                                        '(0 . 0)
-                                        (window-end win)
-                                        where
-                                        (window-width win)
-                                        (cons (window-hscroll) 0)
-                                        win)))
-           (when (and (eq (nth 1 result) x)
-                      (eq (nth 2 result) y))
-             (widget-echo-help (nth 0 result))))))))
-  (unless track-mouse
-    (setq track-mouse t)
-    (add-hook 'post-command-hook 'widget-stop-mouse-tracking)))
-
-(defun widget-stop-mouse-tracking (&rest args)
-  "Stop the mouse tracking done while idle."
-  (remove-hook 'post-command-hook 'widget-stop-mouse-tracking)
-  (setq track-mouse nil))
-
-(defun widget-at (pos)
-  "The button or field at POS."
-  (or (get-text-property pos 'button)
-      (get-text-property pos 'field)))
-

 (defun widget-echo-help (pos)
 (defun widget-echo-help (pos)

-  "Display the help echo for widget at POS."
+  "Display help-echo text for widget at POS."

   (let* ((widget (widget-at pos))
         (help-echo (and widget (widget-get widget :help-echo))))
   (let* ((widget (widget-at pos))
         (help-echo (and widget (widget-get widget :help-echo))))

-    (cond ((stringp help-echo)
-          (message "%s" help-echo))
-         ((and (symbolp help-echo) (fboundp help-echo)
-               (stringp (setq help-echo (funcall help-echo widget))))
-          (message "%s" help-echo)))))
+    (if (functionp help-echo)
+       (setq help-echo (funcall help-echo widget)))
+    (if help-echo (message "%s" (eval help-echo)))))

 
 ;;; The End:
 
 (provide 'wid-edit)
 
 
 ;;; The End:
 
 (provide 'wid-edit)
 

-;; wid-edit.el ends here
+;;; arch-tag: a076e75e-18a1-4b46-8be5-3f317bcbc707
+;;; wid-edit.el ends here